Praktischerweise kann man in VBA Formulare
programmieren - in Microsoft Access geht das sogar noch
einfacher als in anderen Applikationen. Manchmal ist es aber sinnvoll, dem User
eine Standarddialogbox anzuzeigen. Microsoft Excel und
Microsoft Word bieten dafür die Auflistung
Application.Dialogs zum Aufruf ihrer jeweiligen Standarddialoge. Aber
auch Windows selbst bietet Standarddialoge, die über die API angesprochen werden
können.
Auf API-Dateidialoge wird hier nicht eingegangen. In VBA ist dafür schon ein einfacher zu handhabender Dateidialog integriert.
Das Aussehen der meisten Dialogboxen kann über verschiedene Parameter angepasst
werden. Die meisten Anpassungen sind einfach durchzuführen, aber es gibt oft auch
folgende Parameter: lCustData, lpfnHook, lpTemplateName, ENABLEHOOK,
ENABLETEMPLATE, ENABLETEMPLATEHANDLE. Damit kann das Aussehen der Dialogboxen
mit sogenannten „Templates“ noch weiter verändert werden. Hier wird darauf allerdings
nicht eingegangen. Es dürfte einfacher sein, statt dessen gleich VBA-eigene
Formulare zu nutzen.
Zeigt einen Farbauswahldialog an und gibt einen Farbcode im
RGB-Format zurück. War die Funktion
erfolgreich und wurde nicht „Abbrechen“ gewählt, ist der Rückgabewert
True.
Das Aussehen des Dialogs kann mit den Flags angepasst werden, von denen mehrere
mit Or verknüpft werden können.
Mit hwndOwner kann ein Verweis zu einem
anderen, schon geöffneten Fenster hergestellt werden. Falls dieses Fenster eine
Hilfe für die Farbauswahl kennen sollte, bekäme auch der Hilfebutton, der mit
CC_SHOWHELP eingeblendet werden kann, eine Funktion.
#If VBA7 Then Private Declare PtrSafe Function ChooseColorA Lib "comdlg32" _ (lpcc As CHOOSECOLOR_TYPE) As Boolean Private Type CHOOSECOLOR_TYPE lStructSize As Long 'Strukturgröße hwndOwner As LongPtr hInstance As LongPtr rgbResult As Long 'Rückgabewert lpCustColors As LongPtr 'Zeiger auf benutzerdefinierte Farben Flags As eFlags lCustData As LongPtr lpfnHook As LongPtr lpTemplateName As String End Type #Else Private Declare Function ChooseColorA Lib "comdlg32" _ (lpcc As CHOOSECOLOR_TYPE) As Boolean Private Type CHOOSECOLOR_TYPE lStructSize As Long hwndOwner As Long hInstance As Long rgbResult As Long lpCustColors As Long Flags As eFlags lCustData As Long lpfnHook As Long lpTemplateName As String End Type #End If Private Enum eFlags CC_ANYCOLOR = &H100 'Anwender kann alle Farben wählen CC_ENABLEHOOK = &H10 'Nachrichten abfangen. Für Templates CC_ENABLETEMPLATE = &H20 'Dialogbox Template CC_ENABLETEMPLATEHANDLE = &H40 'Benutzt Template, ignoriert Templatenamen CC_FULLOPEN = &H2 'Öffnen mit Vollauswahl aller Farben CC_PREVENTFULLOPEN = &H4 'Deaktiviert den Button zur Vollauswahl CC_RGBINIT = &H1 'Vorgabe eines Rückgabewertes in rgbResult CC_SHOWHELP = &H8 'Hilfe-Button anzeigen CC_SOLIDCOLOR = &H80 'nur Grundfarben (kein Dithering) End Enum
Public Function apiChooseColor() As Long Dim CC As CHOOSECOLOR_TYPE Static lngFarben(15) As Long 'Static: benutzerdefinierte Farben halten 'Einige benutzerdefinierte Farben lngFarben(0) = RGB(255, 100, 100) lngFarben(1) = RGB(100, 255, 100) lngFarben(2) = RGB(100, 100, 255) #If Win64 Then CC.lStructSize = LenB(CC) #Else CC.lStructSize = Len(CC) #End If With CC .Flags = CC_RGBINIT Or CC_FULLOPEN .rgbResult = RGB(255, 0, 0) .lpCustColors = VarPtr(lngFarben(0)) End With If ChooseColorA(CC) Then apiChooseColor = CC.rgbResult 'gewählte Farbe zurückgeben Else apiChooseColor = -1 'falls 'Abbrechen' gewählt wurde End If End Function
Zeigt einen Schriftartendialog an und gibt die Angaben zur Schriftart zurück.
War die Funktion erfolgreich und wurde nicht „Abbrechen“ gewählt, ist der Rückgabewert
True.
Das Aussehen des Dialogs kann mit den Flags angepasst werden, von denen mehrere
mit Or verknüpft werden können.
Mit hwndOwner kann ein Verweis zu einem
anderen, schon geöffneten Fenster hergestellt werden. Falls dieses Fenster eine
Hilfe für den Schriftartendialog kennen sollte, bekäme auch der Hilfebutton, der
mit CF_SHOWHELP eingeblendet werden kann, eine Funktion.
#If VBA7 Then Private Declare PtrSafe Function ChooseFontA Lib "comdlg32" _ (lpcf As CHOOSEFONT_TYPE) As Boolean Private Type CHOOSEFONT_TYPE lStructSize As Long 'Strukturgröße hwndOwner As LongPtr hDC As LongPtr 'Drucker Handle lpLogFont As LongPtr 'Zeiger auf LOGFONT iPointSize As Long 'Schriftgröße in pt. Durch 10 teilen! Flags As eFlags rgbColors As Long 'mit eFlags.CF_EFFECTS: Farbwert (RGB) lCustData As LongPtr lpfnHook As LongPtr lpTemplateName As String hInstance As LongPtr lpszStyle As String nFontType As Long nSizeMin As Long 'mit eFlags.CF_LIMITSIZE: Min.größe des Fonts in pt nSizeMax As Long 'mit eFlags.CF_LIMITSIZE: Max.größe des Fonts in pt End Type #Else Private Declare Function ChooseFontA Lib "comdlg32" _ (lpcf As CHOOSEFONT_TYPE) As Boolean Private Type CHOOSEFONT_TYPE lStructSize As Long hwndOwner As Long hDC As Long lpLogFont As Long iPointSize As Long Flags As eFlags rgbColors As Long lCustData As Long lpfnHook As Long lpTemplateName As String hInstance As Long lpszStyle As String nFontType As Long nSizeMin As Long nSizeMax As Long End Type #End If Private Type LOGFONT lfHeight As Long lfWidth As Long lfEscapement As Long lfOrientation As Long lfWeight As eWeight 'fett lfItalic As Byte 'ungleich 0: kursiv lfUnderline As Byte 'ungleich 0: unterstrichen lfStrikeOut As Byte 'ungleich 0: durchgestrichen lfCharSet As Byte 'Zeichensatz (Skript) aus eCharSet lfOutPrecision As Byte lfClipPrecision As Byte lfQuality As Byte lfPitchAndFamily As Byte lfFaceName As String * 32 'Fontname End Type Private Enum eFlags 'Aussehen der Dialogbox: Was wird darauf angezeigt? CF_SHOWHELP = &H4 'Hilfe-Button CF_APPLY = &H200 'Übernehmen-Button, Werte werden gespeichert CF_EFFECTS = &H100 'Effekte: Unterstrichen, Durchgestrichen, Farbe CF_NOSCRIPTSEL = &H800000 'Deaktiviert Zeichensatzselektion (Scriptselektion) CF_LIMITSIZE = &H2000 'nur Schriftgrößen von nSizeMin bis nSizeMax CF_FORCEFONTEXIST = &H10000 'Warnung beim Eintippen von nicht aufgeführtem Font CF_NOSIMULATIONS = &H1000 'keine Simulation 'Angezeigte Werte beim Start der Dialogbox: CF_INITTOLOGFONTSTRUCT = &H40 'Voreinstellungen aus der LOGFONT-Struktur CF_NOFACESEL = &H80000 'trotz CF_INITTOLOGFONTSTRUCT kein Fontnamen CF_NOSIZESEL = &H200000 'trotz CF_INITTOLOGFONTSTRUCT keine Standardgröße CF_NOSTYLESEL = &H100000 'trotz CF_INITTOLOGFONTSTRUCT kein Standard-Stil 'Weitere Anpassungen mit Templates: CF_ENABLEHOOK = &H8 'Nachrichten abfangen CF_ENABLETEMPLATE = &H10 'benutze Template CF_ENABLETEMPLATEHANDLE = &H20 'benutze Templatehandle 'Welche Fonts werden gelistet? CF_FIXEDPITCHONLY = &H4000 'nur Fixed-Pitch Fonts CF_INACTIVEFONTS = &H2000000 'auch versteckte Fonts (ab Windows7) CF_NOVECTORFONTS = &H800 'keine Vector-Fonts CF_NOVERTFONTS = &H1000000 'nur horizontal ausgerichtete Fonts CF_SCALABLEONLY = &H20000 'nur skalierbare Fonts CF_SCRIPTSONLY = &H400 'nur Windows- oder Unicode-Fonts CF_SELECTSCRIPT = &H400000 'nur Fonts, die LF.lfCharSet entsprechen CF_TTONLY = &H40000 'nur TrueType-Fonts CF_BOTH = &H3 '= CF_SCREENFONTS + CF_PRINTERFONTS CF_SCREENFONTS = &H1 'nur Bildschirm-Fonts CF_PRINTERFONTS = &H2 'nur Fonts des hDC-Druckers. Wird ohne hDC ignoriert 'zeigt außerdem Beschreibung zur Schriftart End Enum 'wie fett ist fett? Private Enum eWeight FW_DONTCARE = 0 'Standardwert der Schriftart FW_THIN = 100 'sehr dünn FW_EXTRALIGHT = 200 'extra dünn FW_LIGHT = 300 'dünn FW_NORMAL = 400 'normal FW_MEDIUM = 500 'mittel FW_SEMIBOLD = 600 'etwas fett FW_BOLD = 700 'fett FW_EXTRABOLD = 800 'extra fett FW_HEAVY = 900 'sehr fett End Enum 'eFlags.CF_SELECTSCRIPT beschränkt Auswahl auf Fonts, die ein Charset unterstützen Private Enum eCharSet ANSI_CHARSET = 0 'Ansi Zeichensatz ARABIC_CHARSET = 178 'Arabisch BALTIC_CHARSET = 186 'Baltisch CHINESEBIG5_CHARSET = 136 'Chinesisch DEFAULT_CHARSET = 1 'Standard (gemäß LOCALE Einstellungen) EASTEUROPE_CHARSET = 238 'Osteuropäisch GB2312_CHARSET = 134 'Englisch GREEK_CHARSET = 161 'Griechisch HANGUL_CHARSET = 129 'Hangul (koreanisch) HEBREW_CHARSET = 177 'Hebräisch JOHAB_CHARSET = 130 'Johab (koreanisch) MAC_CHARSET = 77 'Mac OEM_CHARSET = 255 'OEM (betriebssystemabhängig) RUSSIAN_CHARSET = 204 'Russisch SHIFTJIS_CHARSET = 128 'ShiftJis (japanisch) SYMBOL_CHARSET = 2 'Symbolisch THAI_CHARSET = 222 'Thailändisch TURKISH_CHARSET = 162 'Türkisch End Enum
Public Function apiChooseFont() As String Static LF As LOGFONT, CF As CHOOSEFONT_TYPE 'Static: benutzerdefinierte Auswahl halten With CF .Flags = CF_EFFECTS Or CF_INITTOLOGFONTSTRUCT _ Or CF_FORCEFONTEXIST Or CF_PRINTERFONTS Or CF_APPLY If (.Flags And CF_EFFECTS) Then 'Wenn CF_EFFECTS... .rgbColors = RGB(128, 0, 0) '...evtl Farbe angeben Else .rgbColors = 0 End If If (.Flags And CF_SELECTSCRIPT) Then 'Wenn CF_SELECTSCRIPT... LF.lfCharSet = eCharSet.SYMBOL_CHARSET '...einen Charset angeben Else LF.lfCharSet = eCharSet.DEFAULT_CHARSET End If .lpLogFont = VarPtr(LF) End With #If Win64 Then CF.lStructSize = LenB(CF) #Else CF.lStructSize = Len(CF) #End If If ChooseFontA(CF) Then 'Dialog aufrufen und Ergebnis auswerten apiChooseFont = Replace(StrConv(LF.lfFaceName, vbUnicode), vbNullChar, "") 'Fontname If Len(apiChooseFont) Then 'Wenn Font ausgewählt wurde apiChooseFont = "'" & apiChooseFont & "' " & CF.iPointSize / 10 & "pt " 'Fontsize If (LF.lfItalic) Then apiChooseFont = apiChooseFont & "italic " 'kursiv If (LF.lfWeight) > 400 Then apiChooseFont = apiChooseFont & "bold " 'fett If (CF.Flags And CF_EFFECTS) Then 'Wenn Effekte angezeigt werden If (LF.lfUnderline) Then apiChooseFont = apiChooseFont & "underline " If (LF.lfStrikeOut) Then apiChooseFont = apiChooseFont & "strikeout " apiChooseFont = apiChooseFont & "&h" & Hex(CF.rgbColors) 'RGB-Farbe End If End If End If End Function
Eigentlich handelt es sich hierbei um keinen Dialog. LockWorkStation
sperrt den PC, so dass anschließend der User erst [Str][Alt][Entf]
drücken und dann sein Passwort eingeben muss.
#If VBA7 Then Public Declare PtrSafe Sub LockWorkStation Lib "user32" () #Else Public Declare Sub LockWorkStation Lib "user32" () #End If