Dialogboxen

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. VBA bietet dafür einen eigenen, einfacher zu handhabenden Dateidialog.

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, dann gleich eigene Formulare zu erstellen.

ChooseColor

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

ChooseFont

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

LockWorkStation

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