Attribute VB_Name = "Modul2"
Option Explicit



Const OFN_FILEMUSTEXIST = &H1000
Const OFN_PATHMUSTEXIST = &H800
Const OFN_HIDEREADONLY = &H4
Const OFN_READONLY = &H1
Const OFN_OVERWRITEPROMPT = &H2

'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
' Bugs/Wünsche/Vorschläge bitte an pries@cube.net
' Neuestte Demo unter: www.cube.net/~pries/public/comdlgdemo.zip
' Homepage Karsten Pries : http://www.cube.net/~pries
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'
' Wrapper für Win-API:
'   "GetOpenFileNameA"
'   "GetSaveFileNameA"
'
' Aufruf des CommonDialog von Windows zur Auswahl einer Datei (öffnen/speichern)
' ohne Verwendung des OCX
'
' ********************************************************************************
' Verwendung:
'
' Sub xx()
'  Dim fd As New FileDialog
'  Dim Dateiname as String

' kurze Version:
'    Dateiname = fd.ShowOpen           ' oder .ShowSave
'    if Dateiname = "" then exit sub   ' Abbruch durch Benutzer
'    .....
'
' ohne extra Variable:
'    fd.ShowOpen                         ' oder .ShowSave
'    if fd.FileName = "" then exit sub   ' Abbruch durch Benutzer
'    .....
'
' ausführlich:
'
'   With fd
'      .DialogTitle = "Mein Titel"
'      .DefaultExt = "TXT"             'Standard-Endung wenn vom Benutzer nix anderes angegeben
'      .InitDir = "d:\"
'      .Flags = OFN_FILEMUSTEXIST Or OFN_PATHMUSTEXIST Or OFN_READONLY
'      .Filter1Text = "Text-Dateien"
'      .Filter1Suffix = "*.txt"
'      .Filter2Text = "Ascii-Dateien"
'      .Filter2Suffix = "*.asc"
'      .Filter3Text = "Alle Dateien"
'      .Filter3Suffix = "*.*"
'      ... bis Filter5Text/Suffix ...
'
'      .ShowOpen                          ' oder .ShowSave
'   End With
' End Sub
'
'************************************************************************************
'
' Bemerkung: Die Property .Filter ist für die Abwärtskompatibilität und für Leute,
'            die wissen was sie tun. Alle anderen sollen FilterXText/Suffix benutzen.
'            Näheres im Code zu .Filter.
'************************************************************************************
'
' Karsten Pries (pries@informatik.tu-muenchen.de), 01.11.97



' interne Variablen, über Properties gesetzt:
Private strDialogTitle As String    ' Dialogtitel
Private strFilter As String         ' Filter kann man sowohl wie gehabt definieren als
                                    ' auch über die folgenden Paare Text/Suffix
Private lngFlags As Long            ' Flags
Private strDefaultExt As String     ' Standard-Endung
Private strInitDir As String        ' Start-Verzeichnis

                                    ' optionale Filterparameter, ersparen die Mühe des Zusammenbaus
Private strFilterText(5) As String  ' z.B. "Text-Dateien"
Private strFilterSuffix(5) As String ' z.B. "*.txt"


' interne Variablen, von Funktionen benutzt
Private strDateiName As String      ' zurückgegebener Dateiname
Private cnstNull As String * 1      ' NULL-String



Private Type TOpenFileName
    lStructSize As Long            ' Länge des Datentyps OPENFILENAME
    hwndOwner As Long              ' Fenster, unter dem Dialog erscheint
    hInstance As Long              ' nicht verwendet
    lpstrFilter As String          ' Zeichenkette von Anzeigenfiltern im Dialog
    lpstrCustomFilter As String    ' nicht verwendet
    nMaxCustFilter As Long         ' nicht verwendet
    nFilterIndex As Long           ' 1 zum Benutzen des ersten Filters, 2 zum zweiten usw.
    lpstrFile As String            ' String, der ausgewählte Datei bekommt
    nMaxFile As Long               ' Länge von lpstrFile
    lpstrFileTitle As String       ' Dateiname ohne Pfad (kann auch mit VBA ermittelt werden, also weglassen)
    nMaxFileTitle As Long          ' nicht verwendet
    lpstrInitialDir As String      ' Ordner, in dem Dialog sich zuerst befinden soll
    lpstrTitle As String           ' Titel des eigentlichen Dialogfensters
    flags As Long                  ' verschiedene Optionen, die durch Konstanten eingestellt werden
    nFileOffset As Integer         ' nicht verwendet
    nFileExtension As Integer      ' nicht verwendet
    lpstrDefExt As String          ' Erweiterung, die genommen wird, wenn keine eingegeben wurde
    lCustData As Long              ' nicht verwendet
    lpfnHook As Long               ' nicht verwendet
    lpTemplateName As Long         ' nicht verwendet
End Type


Private Declare Function APT_GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As TOpenFileName) As Long
Private Declare Function APT_GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As TOpenFileName) As Long


Private Function BuildFilter() As String
' bastelt bei Aufruf Open/Save aus den .FilterXText/Suffix und .Filter
' einen gültigen Filterstring

   Dim myFilter As String
   Dim I As Integer
   
   ' wenn .FilterXText/Suffix gesetzt dann String zusammenbauen
   For I = 1 To UBound(strFilterText)
      If strFilterText(I) <> "" And strFilterSuffix(I) <> "" Then
         myFilter = myFilter & strFilterText(I) & cnstNull & strFilterSuffix(I) & cnstNull
      End If
   Next
   
   If strFilter <> "" Then  ' .Filter wurde manuell gesetzt
      ' cut trailing nulls
      Do While right(strFilter, 1) = cnstNull
         strFilter = left(strFilter, Len(strFilter) - 1)
      Loop
      
      myFilter = strFilter & cnstNull & myFilter
   End If
   
   If myFilter = "" Then myFilter = "Alle Dateien" & cnstNull & "*.*"
   
   myFilter = myFilter & cnstNull & cnstNull
   
   BuildFilter = myFilter
   
End Function

Private Sub CheckFlags(Intention As String)

   ' wenn die Flags schon manuell gesetzt wurden: nix tun
   If lngFlags <> 0 Then Exit Sub
   
   ' sonst abhängig von Intention:
   Select Case Intention:
      Case "Open":
         lngFlags = OFN_FILEMUSTEXIST Or OFN_PATHMUSTEXIST Or OFN_READONLY
      Case "Save":
         lngFlags = OFN_PATHMUSTEXIST Or OFN_HIDEREADONLY Or OFN_OVERWRITEPROMPT
      Case Else:
         MsgBox "Unbekannte Intention: " & Intention, vbOKOnly + vbCritical, "CheckFlags"
   End Select
End Sub


Property Let DefaultExt(strAktDefaultExt As String)
   strDefaultExt = strAktDefaultExt & cnstNull
End Property


Property Let DialogTitle(TITLE As String)
   strDialogTitle = TITLE & cnstNull
End Property

Property Get FileName()
   FileName = strDateiName
End Property

Property Let Filter(aktFilter As String)
' wer dieses Property benutzt muß wissen was er tut, siehe für sichere Filterstrings
' die Properties FilterXText/FilterXSuffix
   
   ' Korrekte Filterstrings haben z.B. die Form
   ' "Alle Dateien" & cnstNull & "*.*" & cnstNull & cnstNull
   
   ' Korrekte Filter enden mit zweimal cnstnull
   If Len(aktFilter) >= 2 And right(aktFilter, 2) = cnstNull & cnstNull Then
      strFilter = aktFilter
   Else
      strFilter = aktFilter & cnstNull & cnstNull
   End If
   
End Property

Property Let Filter1Text(FilterText As String)
   strFilterText(1) = FilterText
End Property
Property Let Filter2Text(FilterText As String)
   strFilterText(2) = FilterText
End Property
Property Let Filter3Text(FilterText As String)
   strFilterText(3) = FilterText
End Property

Property Let Filter4Text(FilterText As String)
   strFilterText(4) = FilterText
End Property

Property Let Filter5Text(FilterText As String)
   strFilterText(5) = FilterText
End Property

Property Let Filter1Suffix(FilterSuffix As String)
   strFilterSuffix(1) = FilterSuffix
End Property

Property Let Filter2Suffix(FilterSuffix As String)
   strFilterSuffix(2) = FilterSuffix
End Property
Property Let Filter3Suffix(FilterSuffix As String)
   strFilterSuffix(3) = FilterSuffix
End Property
Property Let Filter4Suffix(FilterSuffix As String)
   strFilterSuffix(4) = FilterSuffix
End Property
Property Let Filter5Suffix(FilterSuffix As String)
   strFilterSuffix(5) = FilterSuffix
End Property

Property Let flags(lngAktFlags As Long)
   lngFlags = lngAktFlags
End Property

Property Let InitDir(strAktInitDir As String)
   strInitDir = strAktInitDir & cnstNull
End Property

Function ShowOpen() As String
On Error GoTo Error_ShowOpen

   Dim myFilter As String
   Dim OpenDlg As TOpenFileName
   
   myFilter = BuildFilter()
   'Call CheckFlags("Open")
   
   If strDialogTitle = "" Then
      strDialogTitle = "Datei öffnen" & cnstNull
   End If
   
   With OpenDlg
      .lStructSize = Len(OpenDlg)
     ' .hwndOwner = Application.hWndAccessApp
      .lpstrFilter = myFilter
      .nFilterIndex = 1
      .lpstrFile = strDateiName
      .nMaxFile = Len(strDateiName)
      .lpstrInitialDir = strInitDir
      .lpstrTitle = strDialogTitle
      .flags = lngFlags
      .lpstrDefExt = strDefaultExt
      
      If APT_GetOpenFileName(OpenDlg) <> 0 Then     ' Aufruf erfolgreich
         ' man kann beides machen:
         ' Datei = fd.ShowOpen ' oder fd.ShowOpen : Datei=fd.FileName
         strDateiName = left$(.lpstrFile, InStr(.lpstrFile, cnstNull) - 1) ' restliche NUL-Werte abschneiden
         ShowOpen = strDateiName
      Else
         strDateiName = ""
         ShowOpen = ""
      End If
   End With

Exit_ShowOpen:
   Exit Function
Error_ShowOpen:
   MsgBox Error$, , "Error_ShowOpennd Sub" + strDateiName
   Resume Exit_ShowOpen
End Function

Function ShowSave() As String
On Error GoTo Error_ShowSave

   Dim myFilter As String
   Dim OpenDlg As TOpenFileName
   
   myFilter = BuildFilter()
   Call CheckFlags("Save")
   
   If strDialogTitle = "" Then
      strDialogTitle = "Datei speichern unter" & cnstNull
   End If
   
   With OpenDlg
      .lStructSize = Len(OpenDlg)
      .hwndOwner = Application.hWndAccessApp
      .lpstrFilter = myFilter
      .nFilterIndex = 1
      .lpstrFile = strDateiName
      .nMaxFile = Len(strDateiName)
      .lpstrInitialDir = strInitDir
      .lpstrTitle = strDialogTitle
      .flags = lngFlags
      .lpstrDefExt = strDefaultExt
      
      If APT_GetSaveFileName(OpenDlg) <> 0 Then     ' Aufruf erfolgreich
         ' man kann beides machen:
         ' Datei= fd.ShowSave oder fd.ShowSave; Datei=fd.FileName
         strDateiName = left$(.lpstrFile, InStr(.lpstrFile, cnstNull) - 1) ' restliche NUL-Werte abschneiden
         ShowSave = strDateiName
      Else
         strDateiName = ""
         ShowSave = ""
      End If
   End With

Exit_ShowSave:
   Exit Function
Error_ShowSave:
   MsgBox Error$, , "Error_ShowSavend Sub"
   Resume Exit_ShowSave
End Function

Private Sub Class_Initialize()
On Error GoTo Error_Class_Initialize
   
   ' Null-String initialisieren
   cnstNull = Chr$(0)
   
   ' der String sollte lang genug für einen Win-95 Pfad sein
   strDateiName = String$(512, 0)
   
   strDialogTitle = "" ' erstmal leer, wird in .ShowOpen/.ShowSave auf Default gesetzt
   strFilter = ""  ' erstmal leer, wird in BuildFilter() gebaut
   
   ' erstmal keine Default-Flags (wird in ShowOpen/ShowSave gesetzt)
   lngFlags = 0
   
   ' keine Default-Erweiterung
   strDefaultExt = cnstNull
   
   ' aktuelles Verzeichnis
   strInitDir = CurDir$ & cnstNull

Exit_Class_Initialize:
   Exit Sub
Error_Class_Initialize:
   MsgBox Error$, , "Error_Class_InitializeSub"
   Resume Exit_Class_Initialize
End Sub