¬ Home » Tipps & Tricks » Tipp 047 Feedback | Druckansicht

Tipp 047: Common Dialog Control ersetzen und ohne Steuerelement nachbauen

Autor: Thomas Geiger VB-Version: Visual Basic 6.0 Download: Beispielprojekt Tipp-047

Beschreibung

Das in Visual Studio enthaltene Common Dialog Control hält für den geneigten Programmierer zahlreiche nutzbringende Funktionen parat. So lassen sich beispielsweise die Windows-Standard-Dialoge zum "Datei öffnen" oder "Datei speichern" anzeigen. In aller Regel funktioniert dies auch einwandfrei und einer Verwendung des entsprechenden Steuerelements steht nichts im Wege.

Es kann jedoch Ausnahmesituationen geben in denen ein Rückgriff auf das Standard-Control nicht möglich ist. Wenn Sie in Ihrer Anwendung etwa eine Update-Routine integriert haben welche nur die Anwendung selbst aktualisiert jedoch keine Steuerelemente im System registrieren kann so können Sie wichtige neue Funktionen ggf. nicht per Online-Update nachreichen oder müssen den Benutzer zu einer kompletten Neuinstallation der Anwendung veranlassen.

Umso hilfreicher ist es, wenn Sie die vom Common Dialog Control gebotenen Funktionen mit eigenem Quellcode nachbilden können. Dieser Tipp zeigt wie dies funktioniert, zur einfacheren Verwendung sind dabei die verschiedenen Dialoge in einzelne Klassen gekapselt. Geboten werden die Umsetzungen des "Datei öffnen" und "Datei speichern"-Dialogs und der typische Verzeichnis-Browser.

Quellcode

Form1

CommandButton            Command1
CommandButton            Command2
CommandButton            Command3
Form                     Form1
Frame                    Frame1
Frame                    Frame2
Frame                    Frame3
Label                    Label1
Label                    Label2

' VISUAL BASIC WORLD
' ===========================================
' Das große Portal zum Thema Visual Basic.
'
' Wenn Ihnen dieser Source Code gefallen hat,
' dann empfehlen Sie Visual Basic World bitte
' weiter und/oder setzen Sie einen Link auf:
'
' http://www.visualbasicworld.de/
'
' Vernetzen Sie sich mit uns:
'
' http://twitter.com/visualbasicwrld
'
' Autor: Thomas Geiger


Option Explicit
 
Dim DlgOpen As Dlg_FileOpen
Dim DlgSave As Dlg_FileSave
Dim DlgBrowse As Dlg_Browse
 

 
 
Private Sub Command1_Click()
 
   DlgOpen.CancelError = True
   'DlgOpen.DefaultDirectory = "C:\"
   DlgOpen.DialogTitle = "Datei öffnen"
   DlgOpen.Filter = "Textdateien (*.txt)|*.txt|Word Dokumente (*.doc)|*.doc|Bitmaps (*.bmp)|*.bmp"
   DlgOpen.HwndOwner = Me.hWnd
 
   On Error GoTo abbr
   DlgOpen.ShowOpen
   Label1.Caption = DlgOpen.FileName
   Exit Sub
 
abbr:
   MsgBox "Abbrechen wurde gewählt"
 
End Sub
 

 
Private Sub Command2_Click()
 
   DlgSave.CancelError = True
   'DlgOpen.DefaultDirectory = "C:\"
   DlgSave.DialogTitle = "Datei speichern"
   DlgSave.Filter = "Textdateien (*.txt)|*.txt|Word Dokumente (*.doc)|*.doc|Bitmaps (*.bmp)|*.bmp"
   DlgSave.HwndOwner = Me.hWnd
 
   On Error GoTo abbr
   DlgSave.ShowSave
   Label2.Caption = DlgSave.FileName
   Exit Sub
 
abbr:
   MsgBox "Abbrechen wurde gewählt"
 
End Sub
 

 
Private Sub Command3_Click()
 
   DlgBrowse.CancelError = True
   DlgBrowse.HwndOwner = Me.hWnd
 
   On Error GoTo abbr
   DlgBrowse.ShowBrowse
   Label3.Caption = DlgBrowse.FolderName
   Exit Sub
 
abbr:
   MsgBox "Abbrechen wurde gewählt"
 
 
End Sub
 

 
 
Private Sub Form_Load()
 
   Set DlgOpen = New Dlg_FileOpen
   Set DlgSave = New Dlg_FileSave
   Set DlgBrowse = New Dlg_Browse
 
End Sub

Dlg_Browse

' VISUAL BASIC WORLD
' ===========================================
' Das große Portal zum Thema Visual Basic.
'
' Wenn Ihnen dieser Source Code gefallen hat,
' dann empfehlen Sie Visual Basic World bitte
' weiter und/oder setzen Sie einen Link auf:
'
' http://www.visualbasicworld.de/
'
' Vernetzen Sie sich mit uns:
'
' http://twitter.com/visualbasicwrld
'
' Autor: Thomas Geiger
 
'-----------------------------'
' Dlg_Browse - Version 1.00   '
' Written by Thomas Geiger    '
'-----------------------------'


'Unsere internen Variablen
Private tHwndOwner As Long
Private tText As String
Private tFolderName As String
Private tCancelError As Boolean
Private tBrowseIn As BrowseFolders
 
'API Deklarationen
Private Declare Function SHGetPathFromIDList Lib _
                "shell32.dll" Alias "SHGetPathFromIDListA" _
                (ByVal pidl As Long, ByVal pszPath As String) _
                As Long
 
Private Declare Function SHGetSpecialFolderLocation Lib _
                "shell32.dll" (ByVal HwndOwner As Long, _
                ByVal nFolder As Long, pidl As ITEMIDLIST) _
                As Long
 
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
                Alias "SHBrowseForFolderA" (lpBrowseInfo As _
                BROWSEINFO) As Long 'ITEMIDLIST
 
 
'Typen, die wir brauchen
Private Type SHITEMID
    cb As Long
    abID As Byte
End Type
Private Type ITEMIDLIST
    mkid As SHITEMID
End Type
Private Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type
Public Enum BrowseFolders
  BF_STANDART
  BF_DESKTOP
  BF_PROGRAMS
  BF_CONTROLS
  BF_PRINTERS
  BF_PERSONAL
  BF_FAVORITES
  BF_STARTUP
  BF_RECENT
  BF_SENDTO
  BF_BITBUCKET
  BF_STARTMENU
  BF_DESKTOPDIRECTORY
  BF_DRIVES
  BF_NETWORK
  BF_NETHOOD
  BF_FONTS
  BF_TEMPLATES
End Enum
 
'Und jetzt brauchen wir noch mehrere Konstanten
Private Const NOERROR = 0
Private Const CSIDL_DESKTOP = &H0
Private Const CSIDL_PROGRAMS = &H2
Private Const CSIDL_CONTROLS = &H3
Private Const CSIDL_PRINTERS = &H4
Private Const CSIDL_PERSONAL = &H5
Private Const CSIDL_FAVORITES = &H6
Private Const CSIDL_STARTUP = &H7
Private Const CSIDL_RECENT = &H8
Private Const CSIDL_SENDTO = &H9
Private Const CSIDL_BITBUCKET = &HA
Private Const CSIDL_STARTMENU = &HB
Private Const CSIDL_DESKTOPDIRECTORY = &H10
Private Const CSIDL_DRIVES = &H11
Private Const CSIDL_NETWORK = &H12
Private Const CSIDL_NETHOOD = &H13
Private Const CSIDL_FONTS = &H14
Private Const CSIDL_TEMPLATES = &H15
Private Const BIF_RETURNONLYFSDIRS = &H1
Private Const BIF_DONTGOBELOWDOMAIN = &H2
Private Const BIF_STATUSTEXT = &H4
Private Const BIF_RETURNFSANCESTORS = &H8
Private Const BIF_BROWSEFORCOMPUTER = &H1000
Private Const BIF_BROWSEFORPRINTER = &H2000
Private Const CLSCD_ERRNUMUSRCANCEL = 32755
Private Const CLSCD_ERRDESUSRCANCEL = "www.visualbasicworld.de - Version 1.00: Abbrechen wurde angeklickt"
 

 
Public Function ShowBrowse()
 
'============================================='
'Die Hauptfunktion, die das Dialogfeld anzeigt'
'============================================='
 
   'Variablen deklarieren
   Dim bi As BROWSEINFO
   Dim idl As ITEMIDLIST
   Dim rtn&, pidl&, path$, pos%
 
      'Strukturen erstellen und füllen
      bi.hOwner = tHwndOwner
      bi.lpszTitle = tText
 
      'Jetzt müssen wir festlegen, wonach wir suchen wollen
      Select Case tBrowseIn
      Case BF_STANDART
        bi.ulFlags = BIF_RETURNONLYFSDIRS
      Case BF_DESKTOP
        bi.pidlRoot = CSIDL_DESKTOP
        bi.ulFlags = BIF_RETURNONLYFSDIRS
      Case BF_PROGRAMS
        bi.pidlRoot = CSIDL_PROGRAMS
        bi.ulFlags = BIF_RETURNONLYFSDIRS
      Case BF_CONTROLS
        bi.pidlRoot = CSIDL_CONTROLS
        bi.ulFlags = BIF_BROWSEFORPRINTER
      Case BF_PRINTERS
        bi.pidlRoot = CSIDL_PRINTERS
        bi.ulFlags = BIF_BROWSEFORPRINTER
      Case BF_PERSONAL
        bi.pidlRoot = CSIDL_PERSONAL
        bi.ulFlags = BIF_RETURNONLYFSDIRS
      Case BF_FAVORITES
        bi.pidlRoot = CSIDL_FAVORITES
        bi.ulFlags = BIF_RETURNONLYFSDIRS
      Case BF_STARTUP
        bi.pidlRoot = CSIDL_STARTUP
        bi.ulFlags = BIF_RETURNONLYFSDIRS
      Case BF_RECENT
        bi.pidlRoot = CSIDL_RECENT
        bi.ulFlags = BIF_RETURNONLYFSDIRS
      Case BF_SENDTO
        bi.pidlRoot = CSIDL_SENDTO
        bi.ulFlags = BIF_RETURNONLYFSDIRS
      Case BF_BITBUCKET
        bi.pidlRoot = CSIDL_BITBUCKET
        bi.ulFlags = BIF_RETURNONLYFSDIRS
      Case BF_STARTMENU
        bi.pidlRoot = CSIDL_STARTMENU
        bi.ulFlags = BIF_RETURNONLYFSDIRS
      Case BF_DESKTOPDIRECTORY
        bi.pidlRoot = CSIDL_DESKTOPDIRECTORY
        bi.ulFlags = BIF_RETURNONLYFSDIRS
      Case BF_DRIVES
        bi.pidlRoot = CSIDL_DRIVES
        bi.ulFlags = BIF_RETURNONLYFSDIRS
      Case BF_NETWORK
        bi.pidlRoot = CSIDL_NETWORK
        bi.ulFlags = BIF_RETURNONLYFSDIRS
      Case BF_NETHOOD
        bi.pidlRoot = CSIDL_NETHOOD
        bi.ulFlags = BIF_RETURNONLYFSDIRS
      Case BF_FONTS
        bi.pidlRoot = CSIDL_FONTS
        bi.ulFlags = BIF_BROWSEFORPRINTER
      Case BF_TEMPLATES
        bi.pidlRoot = CSIDL_TEMPLATES
        bi.ulFlags = BIF_RETURNONLYFSDIRS
      End Select
 
      'Jetzt holen wir uns den Pfad, falls dies möglich ist
      pidl& = SHBrowseForFolder(bi)
      path$ = Space$(512)
      rtn& = SHGetPathFromIDList(ByVal pidl&, ByVal path$)
 
      'Und zum Schluss analysieren wir noch die Rückgabe
      If rtn& Then
      pos% = InStr(path$, Chr$(0))
      tFolderName = Left(path$, pos - 1)
      Else
        If CancelError = True Then
        Err.Raise Number:=CLSCD_ERRNUMUSRCANCEL, Description:=CLSCD_ERRDESUSRCANCEL
        End If
      Exit Function
      End If
 
End Function
 

 
 
'============================'
'Eigenschaften unserer Klasse'
'============================'
 
Public Property Get HwndOwner() As Long
 
   HwndOwner = tHwndOwner
 
End Property
 

 
Public Property Let HwndOwner(ByVal vNewValue As Long)
 
   tHwndOwner = vNewValue
 
End Property
 

 
Public Property Get Text() As String
 
   Text = tText
 
End Property
 

 
Public Property Let Text(ByVal vNewValue As String)
 
   tText = vNewValue
 
End Property
 

 
Public Property Get FolderName() As String
 
   FolderName = tFolderName
 
End Property
 

 
Public Property Get CancelError() As Boolean
 
   CancelError = tCancelError
 
End Property
 

 
Public Property Let CancelError(ByVal vNewValue As Boolean)

 
   tCancelError = vNewValue
 
End Property
 

 
Public Property Get BrowseIn() As BrowseFolders
 
   BrowseIn = tBrowseIn
 
End Property
 

 
Public Property Let BrowseIn(ByVal vNewValue As BrowseFolders)
 
   tBrowseIn = vNewValue
 
End Property

Dlg_FileOpen

' VISUAL BASIC WORLD
' ===========================================
' Das große Portal zum Thema Visual Basic.
'
' Wenn Ihnen dieser Source Code gefallen hat,
' dann empfehlen Sie Visual Basic World bitte
' weiter und/oder setzen Sie einen Link auf:
'
' http://www.visualbasicworld.de/
'
' Vernetzen Sie sich mit uns:
'
' http://twitter.com/visualbasicwrld
'
' Autor: Thomas Geiger
 
'-------------------------------'
' Dlg_FileOpen - Version 1.00   '
' Written by Thomas Geiger      '
'-------------------------------'


'Unsere internen Variablen
Private tFilter As String
Private tDialogTitle As String
Private tCancelError As Boolean
Private tDefaultDirectory As String
Private tFlags As Long
Private tFileName As String
Private tFileTitle As String
Private tHwndOwner As Long
 
'Windows Api Deklarationen
Private Declare Function GetOpenFileNameA Lib _
                "comdlg32.dll" (pOpenfilename _
                As tOPENFILENAME) As Long
 
Private Declare Function CommDlgExtendedError _
                Lib "comdlg32.dll" () As Long
 
'Konstanten für die Dialogfelder
Private Const CLSCD_NOACTION = 0
Private Const CLSCD_SHOWOPEN = 1
Private Const CLSCD_SHOWSAVE = 2
Private Const CLSCD_USERCANCELED = 0
Private Const CLSCD_USERSELECTED = 1
Private Const CLSCD_MAXFILESIZE = 256
Private Const CLSCD_ERRNUMUSRCANCEL = 32755
Private Const CLSCD_ERRDESUSRCANCEL = "www.visualbasicworld.de - Version 1.00: Abbrechen wurde angeklickt"
Private Const CLSCD_ERRNUMUSRBUFFER = 32756
Private Const CLSCD_ERRDESUSRBUFFER = "www.visualbasicworld.de - Version 1.00: Puffer zu klein"
Private Const FNERR_BUFFERTOOSMALL = &H3003
Private Const FNERR_FILENAMECODES = &H3000
Private Const FNERR_INVALIDFILENAME = &H3002
Private Const FNERR_SUBCLASSFAILURE = &H3001
 
'Benutzerdefinierte Typen und Enum Typen
Private Type tOPENFILENAME
        lStructSize As Long
        HwndOwner As Long
        hInstance As Long
        lpstrFilter As String
        lpstrCustomFilter As String
        nMaxCustFilter As Long
        nFilterIndex As Long
        lpstrFile As String
        nMaxFile As Long
        lpstrFileTitle As String
        nMaxFileTitle As Long
        lpstrInitialDir As String
        lpstrTitle As String
        Flags As DlgFileFlags
        nFileOffset As Integer
        nFileExtension As Integer
        lpstrDefExt As String
        lCustData As Long
        lpfnHook As Long
        lpTemplateName As String
End Type
Private Enum DlgFileFlags
   OFN_ALLOWMULTISELECT = &H200
   OFN_CREATEPROMPT = &H2000 = &H80
   OFN_EXPLORER = &H80000
   OFN_EXTENSIONDIFFERENT = &H400
   OFN_FILEMUSTEXIST = &H1000
   OFN_HIDEREADONLY = &H4
   OFN_LONGNAMES = &H200000
   OFN_NOCHANGEDIR = &H8
   OFN_NODEREFERENCELINKS = &H100000
   OFN_NOLONGNAMES = &H40000
   OFN_NONETWORKBUTTON = &H20000
   OFN_NOREADONLYRETURN = &H8000
   OFN_NOTESTFILECREATE = &H10000
   OFN_NOVALIDATE = &H100
   OFN_OVERWRITEPROMPT = &H2
   OFN_PATHMUSTEXIST = &H800
   OFN_READONLY = &H1
   OFN_SHOWHELP = &H10
End Enum
 

 
Public Function ShowOpen()
 
'=========================================='
'Die Hauptfunktion, die den Dialog anzeigt.'
'=========================================='
 
   'Variablen deklarieren
   Dim OpenVar As tOPENFILENAME
   Dim ApiReturnValue As Long
   Dim lExtendedError As Long
 
      'Wir füllen die DialogStruktur
      OpenVar.lpstrTitle = tDialogTitle
      OpenVar.HwndOwner = tHwndOwner
        If tFilter <> "" Then
        OpenVar.lpstrFilter = sAPIFilter(tFilter)
        End If
      OpenVar.lpstrInitialDir = tDefaultDirectory
      OpenVar.Flags = tFlags
 
      'Wir erweitern die Werte der Struktur
      OpenVar.nMaxFileTitle = CLSCD_MAXFILESIZE
      OpenVar.nMaxFile = CLSCD_MAXFILESIZE
      OpenVar.lpstrFileTitle = Space(CLSCD_MAXFILESIZE - 1) & vbNullChar
      OpenVar.lpstrFile = Space(CLSCD_MAXFILESIZE - Len("") - 1) & vbNullChar
 
      'Größe der Struktur eintragen
      OpenVar.lStructSize = Len(OpenVar)
 
      'Jetzt können wir die Standartfehlerbehebung starten
      On Error GoTo UnknownError
 
      'Und nun kommt der entscheidende Moment... wir zeigen das Dialogfeld
      ApiReturnValue = GetOpenFileNameA(OpenVar)
 
      'Nachdem das Dialogfeld gezeigt wurde, können wir den Rückgabewert und die Fehlermeldungen analysieren
        If ApiReturnValue = CLSCD_USERSELECTED Then
        tFileName = sLeftOfNull(OpenVar.lpstrFile)
        tFileTitle = sLeftOfNull(OpenVar.lpstrFileTitle)
        Else
        lExtendedError = CommDlgExtendedError
          If lExtendedError = FNERR_BUFFERTOOSMALL Then
          On Error GoTo 0
          Err.Raise Number:=CLSCD_ERRNUMUSRBUFFER, Description:=CLSCD_ERRDESUSRBUFFER
          Exit Function
          Else
            If tCancelError = True Then
            On Error GoTo 0
            Err.Raise Number:=CLSCD_ERRNUMUSRCANCEL, Description:=CLSCD_ERRDESUSRCANCEL
            Exit Function
            End If
          End If
        End If
      Exit Function
 
UnknownError:
 
End Function
 

 
Private Function sAPIFilter(ByVal Filter As String) As String
 
'====================================='
'Private Funktionen, die wir brauchen.'
'====================================='
 
   Dim I As Long
   Dim C As String * 1
   Dim NullFilter As String
 
   For I = 1 To Len(Filter)
      C = Mid(Filter, I, 1)
      If C = "|" Then
         NullFilter = NullFilter & Chr(0)
         Else
         NullFilter = NullFilter & C
         End If
   Next I
   While Right(NullFilter, 2) <> Chr(0) & Chr(0)
      NullFilter = NullFilter & Chr(0)
   Wend
 
   sAPIFilter = NullFilter
 
End Function
 

 
Private Function sLeftOfNull(ByVal txt As String)
 
   Dim I As Long, P As Long
   Dim ntxt As String, k As String * 1
 
   P = InStr(txt, Chr(0) & Chr(0))
   If P > 0 Then
      For I = 1 To P - 1
         k = Mid(txt, I, 1)
         If k = Chr(0) Then ntxt = ntxt & " " Else ntxt = ntxt & k
      Next I
      Else
      ntxt = Left(txt, InStr(txt, Chr(0)) - 1)
      End If
 
   sLeftOfNull = ntxt
 
End Function
 

 
 
'============================='
'Eigenschaften unserer Klasse.'
'============================='
 
Public Property Get DialogTitle() As String
 
   DialogTitle = tDialogTitle
 
End Property
 

 
Public Property Let DialogTitle(ByVal vNewValue As String)
 
   tDialogTitle = vNewValue
 
End Property
 

 
Public Property Get Filter() As String
 
   Filter = tFilter
 
End Property
 

 
Public Property Let Filter(ByVal vNewValue As String)
 
   tFilter = vNewValue
 
End Property
 

 
Public Property Get CancelError() As Boolean
 
   CancelError = tCancelError
 
End Property
 

 
Public Property Let CancelError(ByVal vNewValue As Boolean)
 
   tCancelError = vNewValue
 
End Property
 

 
Public Property Get DefaultDirectory() As String
 
   DefaultDirectory = tDefaultDirectory
 
End Property
 

 
Public Property Let DefaultDirectory(ByVal vNewValue As String)
 
   tDefaultDirectory = vNewValue
 
End Property
 

 
Public Property Get Flags() As Long
 
   Flags = tFlags
 
End Property
 

 
Public Property Let Flags(ByVal vNewValue As Long)
 
   tFlags = vNewValue
 
End Property
 

 
Public Property Get HwndOwner() As Long
 
   HwndOwner = tHwndOwner
 
End Property
 

 
Public Property Let HwndOwner(ByVal vNewValue As Long)
 
   tHwndOwner = vNewValue
 
End Property
 

 
Public Property Get FileName() As String
 
   FileName = tFileName
 
End Property
 

 
Public Property Get FileTitle() As String
 
   FileTitle = tFileTitle
 
End Property

Dlg_FileSave

' VISUAL BASIC WORLD
' ===========================================
' Das große Portal zum Thema Visual Basic.
'
' Wenn Ihnen dieser Source Code gefallen hat,
' dann empfehlen Sie Visual Basic World bitte
' weiter und/oder setzen Sie einen Link auf:
'
' http://www.visualbasicworld.de/
'
' Vernetzen Sie sich mit uns:
'
' http://twitter.com/visualbasicwrld
'
' Autor: Thomas Geiger
 
'-------------------------------'
' Dlg_FileSave - Version 1.00   '
' Written by Thomas Geiger      '
'-------------------------------'


'Unsere internen Variablen
Private tFilter As String
Private tDialogTitle As String
Private tCancelError As Boolean
Private tDefaultDirectory As String
Private tFlags As Long
Private tFileName As String
Private tFileTitle As String
Private tHwndOwner As Long
 
'Windows Api Deklarationen
Private Declare Function GetSaveFileNameA Lib _
                "comdlg32.dll" (pOpenfilename _
                As tOPENFILENAME) As Long
 
Private Declare Function CommDlgExtendedError _
                Lib "comdlg32.dll" () As Long
 
'Konstanten für die Dialogfelder
Private Const CLSCD_NOACTION = 0
Private Const CLSCD_SHOWOPEN = 1
Private Const CLSCD_SHOWSAVE = 2
Private Const CLSCD_USERCANCELED = 0
Private Const CLSCD_USERSELECTED = 1
Private Const CLSCD_MAXFILESIZE = 256
Private Const CLSCD_ERRNUMUSRCANCEL = 32755
Private Const CLSCD_ERRDESUSRCANCEL = "www.visualbasicworld.de - Version 1.00: Abbrechen wurde angeklickt"
Private Const CLSCD_ERRNUMUSRBUFFER = 32756
Private Const CLSCD_ERRDESUSRBUFFER = "www.visualbasicworld.de - Version 1.00: Puffer zu klein"
Private Const FNERR_BUFFERTOOSMALL = &H3003
Private Const FNERR_FILENAMECODES = &H3000
Private Const FNERR_INVALIDFILENAME = &H3002
Private Const FNERR_SUBCLASSFAILURE = &H3001
 
'Benutzerdefinierte Typen und Enum Typen
Private Type tOPENFILENAME
        lStructSize As Long
        HwndOwner As Long
        hInstance As Long
        lpstrFilter As String
        lpstrCustomFilter As String
        nMaxCustFilter As Long
        nFilterIndex As Long
        lpstrFile As String
        nMaxFile As Long
        lpstrFileTitle As String
        nMaxFileTitle As Long
        lpstrInitialDir As String
        lpstrTitle As String
        Flags As DlgFileFlags
        nFileOffset As Integer
        nFileExtension As Integer
        lpstrDefExt As String
        lCustData As Long
        lpfnHook As Long
        lpTemplateName As String
End Type
Private Enum DlgFileFlags
   OFN_ALLOWMULTISELECT = &H200
   OFN_CREATEPROMPT = &H2000 = &H80
   OFN_EXPLORER = &H80000
   OFN_EXTENSIONDIFFERENT = &H400
   OFN_FILEMUSTEXIST = &H1000
   OFN_HIDEREADONLY = &H4
   OFN_LONGNAMES = &H200000
   OFN_NOCHANGEDIR = &H8
   OFN_NODEREFERENCELINKS = &H100000
   OFN_NOLONGNAMES = &H40000
   OFN_NONETWORKBUTTON = &H20000
   OFN_NOREADONLYRETURN = &H8000
   OFN_NOTESTFILECREATE = &H10000
   OFN_NOVALIDATE = &H100
   OFN_OVERWRITEPROMPT = &H2
   OFN_PATHMUSTEXIST = &H800
   OFN_READONLY = &H1
   OFN_SHOWHELP = &H10
End Enum
 

 
Public Function ShowSave()
 
'=========================================='
'Die Hauptfunktion, die den Dialog anzeigt.'
'=========================================='
 
   'Variablen deklarieren
   Dim OpenVar As tOPENFILENAME
   Dim ApiReturnValue As Long
   Dim lExtendedError As Long
 
      'Wir füllen die DialogStruktur
      OpenVar.lpstrTitle = tDialogTitle
      OpenVar.HwndOwner = tHwndOwner
        If tFilter <> "" Then
        OpenVar.lpstrFilter = sAPIFilter(tFilter)
        End If
      OpenVar.lpstrInitialDir = tDefaultDirectory
      OpenVar.Flags = tFlags
      OpenVar.lpstrDefExt = ".X"
 
      'Wir erweitern die Werte der Struktur
      OpenVar.nMaxFileTitle = CLSCD_MAXFILESIZE
      OpenVar.nMaxFile = CLSCD_MAXFILESIZE
      OpenVar.lpstrFileTitle = Space(CLSCD_MAXFILESIZE - 1) & vbNullChar
      OpenVar.lpstrFile = Space(CLSCD_MAXFILESIZE - Len("") - 1) & vbNullChar
 
      'Größe der Struktur eintragen
      OpenVar.lStructSize = Len(OpenVar)
 
      'Jetzt können wir die Standartfehlerbehebung starten
      On Error GoTo UnknownError
 
      'Und nun kommt der entscheidende Moment... wir zeigen das Dialogfeld
      ApiReturnValue = GetSaveFileNameA(OpenVar)
 
      'Nachdem das Dialogfeld gezeigt wurde, können wir den Rückgabewert und die Fehlermeldungen analysieren
        If ApiReturnValue = CLSCD_USERSELECTED Then
        tFileName = sLeftOfNull(OpenVar.lpstrFile)
        tFileTitle = sLeftOfNull(OpenVar.lpstrFileTitle)
        Else
        lExtendedError = CommDlgExtendedError
          If lExtendedError = FNERR_BUFFERTOOSMALL Then
          On Error GoTo 0
          Err.Raise Number:=CLSCD_ERRNUMUSRBUFFER, Description:=CLSCD_ERRDESUSRBUFFER
          Exit Function
          Else
            If tCancelError = True Then
            On Error GoTo 0
            Err.Raise Number:=CLSCD_ERRNUMUSRCANCEL, Description:=CLSCD_ERRDESUSRCANCEL
            Exit Function
            End If
          End If
        End If
      Exit Function
 
UnknownError:
 
End Function
 

 
Private Function sAPIFilter(ByVal Filter As String) As String
 
'====================================='
'Private Funktionen, die wir brauchen.'
'====================================='
 
   Dim I As Long
   Dim C As String * 1
   Dim NullFilter As String
 
   For I = 1 To Len(Filter)
      C = Mid(Filter, I, 1)
      If C = "|" Then
         NullFilter = NullFilter & Chr(0)
         Else
         NullFilter = NullFilter & C
         End If
   Next I
 
   While Right(NullFilter, 2) <> Chr(0) & Chr(0)
      NullFilter = NullFilter & Chr(0)
   Wend
 
      sAPIFilter = NullFilter
 
End Function
 

 
Private Function sLeftOfNull(ByVal txt As String)
 
   Dim I As Long, P As Long
   Dim ntxt As String, k As String * 1
 
   P = InStr(txt, Chr(0) & Chr(0))
   If P > 0 Then
      For I = 1 To P - 1
         k = Mid(txt, I, 1)
         If k = Chr(0) Then ntxt = ntxt & " " Else ntxt = ntxt & k
      Next I
      Else
      ntxt = Left(txt, InStr(txt, Chr(0)) - 1)
      End If
   sLeftOfNull = ntxt
 
End Function
 

 
 
'============================'
'Eigenschaften unserer Klasse'
'============================'
 
Public Property Get DialogTitle() As String
 
   DialogTitle = tDialogTitle
 
End Property
 

 
Public Property Let DialogTitle(ByVal vNewValue As String)
 
   tDialogTitle = vNewValue
 
End Property
 

 
Public Property Get Filter() As String
 
   Filter = tFilter
 
End Property
 

 
Public Property Let Filter(ByVal vNewValue As String)
 
   tFilter = vNewValue
 
End Property
 

 
Public Property Get CancelError() As Boolean
 
   CancelError = tCancelError
 
End Property
 

 
Public Property Let CancelError(ByVal vNewValue As Boolean)
 
   tCancelError = vNewValue
 
End Property
 

 
Public Property Get DefaultDirectory() As String
 
   DefaultDirectory = tDefaultDirectory
 
End Property
 

 
Public Property Let DefaultDirectory(ByVal vNewValue As String)
 
   tDefaultDirectory = vNewValue
 
End Property
 

 
Public Property Get Flags() As Long
 
   Flags = tFlags
 
End Property
 

 
Public Property Let Flags(ByVal vNewValue As Long)
 
   tFlags = vNewValue
 
End Property
 

 
Public Property Get HwndOwner() As Long
 
   HwndOwner = tHwndOwner
 
End Property
 

 
Public Property Let HwndOwner(ByVal vNewValue As Long)
 
   tHwndOwner = vNewValue
 
End Property
 

 
Public Property Get FileName() As String
 
   FileName = tFileName
 
End Property
 

 
Public Property Get FileTitle() As String
 
   FileTitle = tFileTitle
 
End Property