Excel VBA Userform Control zur Font Auswahl und Größen-Festlegung

  • VB.NET

Es gibt 2 Antworten in diesem Thema. Der letzte Beitrag () ist von warbe.

    Excel VBA Userform Control zur Font Auswahl und Größen-Festlegung

    Ich suche ein Control für eine UserForm, die es dem Nutzer erlaubt einen Font aus den verfügbaren auszuwählen und seine Größe festzulegen.
    Gibt es so etwas fertig oder wie kann ich mir es zusammenbauen?
    Hallo.

    Du brauchst für Excel-VBA ein ActiveX-Control. Sowas wird normalerweise in C++ implementiert, geht aber auch in VB.NET. Schau zuerst in die Liste der MS CommonControls - die müsste einen Dialog beinhalten, der FontDialog heißt, soweit ich mich erinnere. Da VBA auf VB 6.0 basiert, sollte dir dieser Link weiterhelfen: msdn.microsoft.com/en-us/library/aa238850%28v=vs.60%29.aspx.
    Gruß
    hal2000
    Es wird ja oft empfohlen, anstatt alte Threads zu verwenden, lieber einen neuen erstellen. Das hat aber auch den Nachteil, dass sehr viele, letztendlich nur bedingt nützliche Ergebisse zu finden sind - so wie hier. Ich habe nähmlich inzwischen eine Lösung wie folgt implementiert, mit der ich sehr zufrieden bin. Ich kann damit nicht nur die Breite der UserForm definieren, sondern auch den Font und dessen Größe und ganz nebenbei natürlich auch den Text der im Antwort-Command-Button steht.

    Visual Basic-Quellcode

    1. Option Explicit
    2. Const sUsrFrm1 As String = "UserForm1" ' The default name of any new UserForm
    3. Const sDynFormName As String = "frmDynMsgBox" ' The name UserForm1 is renamend to
    4. Public Sub DynMsgBox(Optional ByVal sTitle As String = vbNullString, _
    5. Optional ByVal sMsg As String = vbNullString, _
    6. Optional ByVal siWidth As Single = 100, _
    7. Optional ByVal sFont As String = "Calibri", _
    8. Optional ByVal siFontSize As Single = 10, _
    9. Optional ByVal sReplyCaption As String = "Ok", _
    10. Optional ByVal bRemove As Boolean = False)
    11. ' ------------------------------------------------------------------------
    12. ' Dynamically creates a UserForm called 'frmDynMsgBox' with an optional
    13. ' Width ('siWidth), Font ('sFont') and Font Size ('siFontSize').
    14. ' The height is determined by the 'siWidth', the text in 'sMsg' and its
    15. ' format. Please note:
    16. ' When the form is removed with bRemove:=True, any subsequent call within
    17. ' the same procedure or loop will not work unless the Workbook is saved.
    18. ' The reason for this is, that the removal of the Code Module (in this
    19. ' case the UserForm) takes place when the procedure has ended, which
    20. ' contradicts re-using it. Thus, bRemove:=True causes the Workbook being
    21. ' saved - with Application.EnableEvents = False to limit side effects!
    22. ' If this save is inappropriate while the project is active, bRemove:=True
    23. ' should only be used along with Workbook_BeforeClose.
    24. ' ------------------------------------------------------------------------
    25. Dim bEnableEvents As Boolean
    26. Dim vbComp As VBComponent ' The UserForm
    27. Dim pOkButton As MSForms.CommandButton ' The Ok Button
    28. Dim pLabel As MSForms.Label ' The control for the message text
    29. Dim lLines As Long
    30. Dim i As Long ' VBA Code lines counter
    31. Dim siFormCenter As Single ' To center the reply button under the message text
    32. Dim ctl As Variant ' For an astonishing trick !!!
    33. On Error GoTo on_error
    34. If sMsg = vbNullString And bRemove Then GoTo remove_dyn_msg_box
    35. For Each vbComp In ThisWorkbook.VBProject.VBComponents
    36. ' ------------------------------------------------------------
    37. ' Either remove any remainings from previous calls or reuse it
    38. ' ------------------------------------------------------------
    39. With vbComp
    40. If .Name = sDynFormName Then
    41. '~~> Re-use the still existing UserForm
    42. For Each ctl In .Designer.Controls
    43. ' Does something magic since it won't work without it
    44. Next ctl
    45. .Properties("Width") = siWidth + 8
    46. .Properties("Caption") = sTitle
    47. siFormCenter = (siWidth + 8) / 2
    48. Set pLabel = .Designer.Controls("laMsg")
    49. With pLabel
    50. .Font = sFont
    51. .Font.Size = siFontSize
    52. .Caption = sMsg
    53. .AutoSize = False
    54. .Width = siWidth - 5
    55. .AutoSize = True
    56. End With
    57. Set pOkButton = .Designer.Controls("cmbOk")
    58. With pOkButton
    59. '~~> Position the OK-Button along with with the message text width and height
    60. .Top = pLabel.Top + pLabel.Height + 30
    61. .Left = siFormCenter - .Width / 2
    62. End With
    63. .Properties("Height") = pOkButton.Top + pOkButton.Height + 30
    64. GoTo dsply_form
    65. End If
    66. End With
    67. Next vbComp
    68. '~~> Dynamically create the UserForm which does not already exist.
    69. Set vbComp = ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_MSForm)
    70. With vbComp
    71. .Properties("Caption") = sTitle
    72. .Properties("Width") = siWidth + 8
    73. siFormCenter = (siWidth + 8) / 2
    74. .Properties("Name") = sDynFormName
    75. .Properties("Height") = 200
    76. Set pLabel = .Designer.Controls.Add("Forms.label.1", "laMsg")
    77. With pLabel
    78. .Font = sFont
    79. .Font.Size = siFontSize
    80. .Caption = sMsg
    81. .Left = 5
    82. .Top = 6
    83. .AutoSize = False
    84. .Width = siWidth - 5
    85. .AutoSize = True
    86. End With
    87. Set pOkButton = .Designer.Controls.Add("Forms.commandbutton.1", "cmbOk")
    88. With pOkButton
    89. .Caption = sReplyCaption
    90. .Top = pLabel.Top + pLabel.Height + 30
    91. .Left = siFormCenter - .Width / 2
    92. End With
    93. .Properties("Height") = pOkButton.Top + pOkButton.Height + 30
    94. With .CodeModule
    95. '~~> Write event code for the reply button(s)
    96. lLines = .CountOfLines
    97. i = 1
    98. .InsertLines lLines + i, "Public Sub cmbOk_Click()": i = i + 1
    99. .InsertLines lLines + i, " Unload Me": i = i + 1
    100. .InsertLines lLines + i, "End Sub"
    101. End With
    102. End With
    103. dsply_form:
    104. VBA.UserForms.Add(vbComp.Name).Show
    105. remove_dyn_msg_box:
    106. If bRemove Then
    107. ' -----------------------------------------------------------
    108. ' Attention! When the UserForm 'frmDynMsgBox' is removed and
    109. ' subsequently called within the same procedure this works
    110. ' only if the Workbook is saved after remove.
    111. ' Since this save may not only be time consuming but also may
    112. ' have unwanted side effects, removing the form is not recom-
    113. ' mendable when this procedure is subsequently called within
    114. ' a procedure but rather along with Workbook_BeforeClose.
    115. ' ------------------------------------------------------------
    116. For Each vbComp In ThisWorkbook.VBProject.VBComponents
    117. If vbComp.Name = sDynFormName Or vbComp.Name = sUsrFrm1 Then
    118. ThisWorkbook.VBProject.VBComponents.Remove vbComp
    119. End If
    120. Next vbComp
    121. '~~> Try to perform the save with minimum side effects possible
    122. With Application
    123. bEnableEvents = .EnableEvents
    124. .EnableEvents = False
    125. ThisWorkbook.Save
    126. .EnableEvents = bEnableEvents
    127. End With
    128. End If
    129. Exit Sub
    130. on_error:
    131. '~~> Remove any dynamically created UserForms
    132. For Each vbComp In ThisWorkbook.VBProject.VBComponents
    133. If vbComp.Name = sDynFormName Or vbComp.Name = sUsrFrm1 Then
    134. ThisWorkbook.VBProject.VBComponents.Remove vbComp
    135. End If
    136. Next vbComp
    137. End Sub


    Die Test-Arbeitsmappe enthält Test-Anwendungsbeispiele. Wenn dieser Code in ein Standard Modul kopiert wird sind noch die beiden Referenzen:
    - Microsoft Forms 2.0 (ggf. erst in der Liste sichtbar, wenn mit Durchsuchen im System32 Verzeichnis die FM20.dll ausgewählt wurde)
    - Microsoft Visual Basic for Aplications Extensibility 5.3
    erforderlich. Andernfalls gibt es einen Fehler "Benutzerdefinierter Typ nicht definiert".

    Dieser Beitrag wurde bereits 1 mal editiert, zuletzt von „warbe“ ()