Neulich hatte ich mit folgender Situation zu kämpfen: Vor mir lag eine recht komplexe VBA-Applikation, die in einer Microsoft Access RunTime-Umgebung laufen sollte. Das tat sie eigentlich auch, wie schon viele Dutzend Installationen zuvor. Doch dieses Mal stellte sie sich ausgesprochen widerborstig an, als es darum ging, in der Applikation einen FileOpen-Dialog anzuzeigen. Ich schaute mir die im Quellcode verwendeten Aufrufe an und stellte fest, dass per Deklaration auf ein Objekt innerhalb der MSACCESS.EXE verwiesen wurde:
Declare Function MSAU_OfficeGetFileName Lib "msaccess.exe" Alias "#56" (gfni As defiOfficeGetFileNameINFO, ByVal fOpen As Integer) As Long
Das erschien mir verdächtig, denn eigentlich ist der FileOpenDialog ein Objekt, welches in der COMDLG32.DLL enthalten ist, also eine native API-Funktion. Warum also der Verweis auf die MSACCESS.EXE? Hier vermutete ich das Problem, denn ganz sicher ist die MACCESS.EXE der RunTime-Version eine andere als die der Vollversion von Access, und möglicherweise funktionieren deswegen auch manche Aufrufe hier nicht oder anders. Tatsächlich förderte eine kurze Internet-Recherche den passenden Eintrag in der Microsoft Knowledgebase zutage:
http://support.microsoft.com/kb/510291/de
Eigentlich beschreibt der Artikel das Verhalten unter Office 2002, doch wie ich feststellen musste, reagierte meine Access 2003-RunTime-Version absolut identisch. Also beschloss ich, eine kleine Klasse zu schreiben, welche direkt auf das API-Objekt des FileOpenDialog zurückgreift und damit in jeder Windows-Umgebung zuverlässig funktionieren sollte – unabhängig von der Office-Installation. Der Quellcode des Klasse findet sich im Anschluss an diesen Text. Ich nutze in der Klasse nicht alle Möglichkeiten, welche die Windows-API hier bietet, aus, aber den speziellen Anwendungsfall eines Datei-Öffnen-Dialogs reichen die ausprogrammierten Eigenschaften und Methoden aus.
Eine Besonderheit ist noch zu erwähnen: Um die Kompatibilität zum restlichen Programm aufrecht zu erhalten, bekommt die Klasse die Filtereinstellungen für den Dialog in einem anderen Format, als die API es eigentlich erwartet. Die Formatierung wird dann in der Klasse an die API-Bedürfnisse angepasst. Das sollte man beachten, wenn man den Quellcode in eigene Applikationen übernimmt. Ansonsten sollte die Klasse in allen VBA-Applikationen ab Office 2002 funktionieren.
Und so sieht der Aufruf des FileOpen-Dialogs dann in einer Beispielprozedur aus:
Private Sub Example()
Dim sPath As String
Dim sFile As String
Dim oFilter As New Collection
Dim oDialog As New Sys_Class_FileOpen
On Error GoTo Mark_Error
' Filter definieren
oFilter.Add "Bilder(*.bmp,*.jpg,*.ico,*.tif,*.eps,*.gif,*.jpeg)"
oFilter.Add "Office(*.dot,*.doc,*.xls,*.ppt)"
oFilter.Add "Text(*.txt)"
oFilter.Add "Alle Dateien(*.*)"
' Filtereigenschaften definieren (MultiSelect)
oDialog.Filter = oFilter
oDialog.HideReadOnly = True
oDialog.AllowMultiSelect = True
oDialog.InitialDir = "C:\Temp"
' Dialog öffnen
If oDialog.Show(OFN_OpenFile) Then
For Each vFile In oDialog.FileTitles
sPath = oDialog.Path)
sFile = vFile
Next
End If ' Filtereigenschaften definieren (SingleSelect)
oDialog.AllowMultiSelect = False
' Dialog öffnen
If oDialog.Show(OFN_OpenFile) Then
If oDialog.FileTitles.Count > 0 Then
sPath = oDialog.Path)
sFile = oDialog.FileTitles(1))
End If
End If
Mark_Exit:
Set oFilter = Nothing
Set oDialog = Nothing
Exit Sub
Mark_Error:
MsgBox ("This->Example: " & Err.Description)
Resume Mark_Exit
End SubIn der Funktion wird zunächst ein FileOpen-Dialog mit aktivierter Mehrfachauswahl von Dateien geöffnet. Die ausgewählten Dateien können dann aus einer durch die Klasse bereitgestellten Collection ausgelesen werden. Direkt im Anschluss wird der gleiche Dialog mit aktivierter Einfachauswahl geöffnet.
Die Fehlerbehandlung der Prozedur ist nur rudimentär ausgeführt und sollte für den produktiven Einsatz noch etwas eleganter gestaltet werden.
Und hier folgt der Quellcode der dazugehörigen Klasse:
' Class: Sys_Class_FileOpen
Option Explicit
Option Compare Database
' private Variable
Private priv_lAttributes As Long
Private priv_lMaxFile As Long
Private priv_sTitle As String
Private priv_sInitialDir As String
Private priv_sPath As String
Private priv_sFilter As String
Private priv_sFilename As String
Private priv_sDefaultExtension As String
Private priv_bHideReadOnly As Boolean
Private priv_bReadOnly As Boolean
Private priv_bAllowMultiSelect As Boolean
Private priv_oFileTitles As New Collection
Private priv_oFiles As New Collection
Private priv_OFN As OPENFILENAME
' API-Deklarationen
Private Declare Function GetOpenFileName Lib "COMDLG32.DLL" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetSaveFileName Lib "COMDLG32.DLL" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Type OPENFILENAME
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 Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As Long
End Type
' Konstanten
Const OFN_ALLOWMULTISELECT As Long = &H200
Const OFN_CREATEPROMPT As Long = &H2000
Const OFN_EXPLORER As Long = &H80000
Const OFN_EXTENSIONDIFFERENT As Long = &H400
Const OFN_FILEMUSTEXIST As Long = &H1000
Const OFN_HIDEREADONLY As Long = &H4
Const OFN_LONGNAMES As Long = &H200000
Const OFN_NOCHANGEDIR As Long = &H8
Const OFN_NODEREFERENCELINKS As Long = &H100000
Const OFN_OVERWRITEPROMPT As Long = &H2
Const OFN_PATHMUSTEXIST As Long = &H800
Const OFN_READONLY As Long = &H1
Const MAX_PATH As Long = 255
Const MAX_BUFFER As Long = 50 * MAX_PATH
Public Enum OFN_DlgType
OFN_OpenFile = 1
OFN_SaveFile = 2
End Enum
Private priv_sNullString As String
' Fenstertitel
Public Property Get Title() As String
Title = priv_sTitle
End Property
Public Property Let Title(Value As String)
priv_sTitle = Value
End Property
' Checkbox ReadOnly anzeigen
Public Property Get HideReadOnly() As Boolean
HideReadOnly = priv_bHideReadOnly
End Property
Public Property Let HideReadOnly(Value As Boolean)
priv_bHideReadOnly = Value
If Value Then
priv_lAttributes = priv_lAttributes Or OFN_HIDEREADONLY
Else
priv_lAttributes = priv_lAttributes And OFN_HIDEREADONLY
End If
End Property
' Checkbox Readonly gesetzt
Public Property Get ReadOnly() As Boolean
ReadOnly = priv_bReadOnly
End Property
Public Property Let ReadOnly(Value As Boolean)
priv_bReadOnly = ReadOnly
If Value Then
priv_lAttributes = priv_lAttributes Or OFN_READONLY
' wenn ReadOnly gesetzt wird, muss die Checkbox angezeigt werden
HideReadOnly = False
Else
priv_lAttributes = priv_lAttributes And OFN_READONLY
End If
End Property
' Mehrfachauswahl erlauben
Public Property Get AllowMultiSelect() As Boolean
AllowMultiSelect = priv_bAllowMultiSelect
End Property
Public Property Let AllowMultiSelect(Value As Boolean)
priv_bAllowMultiSelect = Value
If Value Then
priv_lAttributes = priv_lAttributes Or OFN_ALLOWMULTISELECT
Else
priv_lAttributes = priv_lAttributes And OFN_ALLOWMULTISELECT
End If
End Property
' Initialer Pfad
Public Property Get InitialDir() As String
InitialDir = priv_sInitialDir
End Property
Public Property Let InitialDir(Value As String)
priv_sInitialDir = Value
End Property
' Standard-Dateierweiterung
Public Property Get DefaultExtension() As String
InitialDir = priv_sInitialDir
End Property
Public Property Let DefaultExtension(Value As String)
priv_sInitialDir = Value
End Property
' Filter
Public Property Get Filter() As Variant
Filter = priv_sFilter
End Property
Public Property Let Filter(Value As Variant)
Dim vItem As Variant
Dim sText As String
Dim sFilter As String
priv_sFilter = ""
If TypeName(Value) = "Collection" Then
For Each vItem In Value
If InStr(vItem, "(") And InStr(vItem, ")") Then
' spezielle Schreibweise des Filters
sText = Trim(Left(vItem, InStr(vItem, "(") - 1))
sFilter = Mid(vItem, InStr(vItem, "(") + 1)
sFilter = Trim(Left(sFilter, Len(sFilter) - 1))
sFilter = Replace(sFilter, ",", ";")
ElseIf InStr(vItem, "|") Then
' Pipe-Schreibweise
sText = Trim(Left(vItem, InStr(vItem, "|") - 1))
sFilter = Trim(Mid(vItem, InStr(vItem, "|") + 1))
If InStr(sFilter, ",") Then sFilter = Replace(sFilter, ",", ";")
End If
priv_sFilter = priv_sFilter & sText & vbNullChar & sFilter & vbNullChar
Next
priv_sFilter = priv_sFilter & vbNullChar
End If
End Property
' Rückgabewert Dateinamen (inklusive Pfad)
Public Property Get Files() As Collection
Set Files = priv_oFiles
End Property
' Rückgabewert Dateinamen (ohne Pfad)
Public Property Get FileTitles() As Collection
Set FileTitles = priv_oFileTitles
End Property
' Rückgabewert Pfadangabe
Public Property Get Path() As String
Path = priv_sPath
End Property
Private Sub Class_Initialize()
' Klasse initialisieren, Grundeinstellungen setzen
priv_lAttributes = priv_lAttributes Or OFN_EXPLORER Or OFN_LONGNAMES
priv_sNullString = Chr(0)
HideReadOnly = True
End Sub
Public Function Show(iType As OFN_DlgType) As Boolean
' Zeigt das Dialogfenster an
Dim lReturn As Long
Dim lEndOfString As Long
Dim lIndex As Long
Dim sReturnString As String
Dim sSingleFile As String
Dim vMultiFiles() As String
On Error GoTo Mark_Error
' Grundeinstellungen setzen
With priv_OFN
If priv_bAllowMultiSelect Then
.nMaxFile = MAX_BUFFER + 1
Else
.nMaxFile = MAX_PATH + 1
End If
.lStructSize = Len(priv_OFN)
.hwndOwner = GetActiveWindow
.nFilterIndex = 0
.lpstrFilter = priv_sFilter
.nMaxFileTitle = MAX_PATH + 1
.lpstrFile = String$(.nMaxFile - 1 - Len(.lpstrFile), 0)
.lpstrFileTitle = String$(.nMaxFileTitle - 1, 0)
.lpstrInitialDir = priv_sInitialDir
.lpstrTitle = priv_sTitle
.lpstrDefExt = priv_sDefaultExtension
.Flags = .Flags Or priv_lAttributes
End With
Select Case iType
Case OFN_OpenFile
lReturn = GetOpenFileName(priv_OFN)
Case OFN_SaveFile
lReturn = GetSaveFileName(priv_OFN)
End Select
If lReturn Then
lEndOfString = InStr(priv_OFN.lpstrFile & vbNullChar, String$(2, 0))
If lEndOfString Then
sReturnString = Left$(priv_OFN.lpstrFile, lEndOfString - 1)
sSingleFile = Left$(priv_OFN.lpstrFileTitle, InStr(priv_OFN.lpstrFileTitle, vbNullChar) - 1)
priv_sPath = Left$(sReturnString, priv_OFN.nFileOffset - 1)
If Len(sSingleFile) Then
' eine Datei wurde ausgewählt
priv_oFileTitles.Add Mid$(sReturnString, priv_OFN.nFileOffset + 1)
priv_oFiles.Add sReturnString
Else
' mehrere Dateien wurden ausgewählt
vMultiFiles = Split(sReturnString, vbNullChar)
If UBound(vMultiFiles) > LBound(vMultiFiles) Then
For lIndex = 1 To UBound(vMultiFiles)
priv_oFileTitles.Add vMultiFiles(lIndex)
If InStr(vMultiFiles(lIndex), "\") Then
' Verknüpfung ausgewählt
priv_oFiles.Add vMultiFiles(lIndex)
Else
' Datei ausgewählt
priv_oFiles.Add priv_sPath & "\" & vMultiFiles(lIndex)
End If
Next
' Variable.zurücksetzen
sReturnString = vbNullString
End If
End If
End If
Show = True
Else
Set priv_oFileTitles = Nothing
Set priv_oFiles = Nothing
priv_sPath = ""
Show = False
End If
Mark_Exit:
Exit Function
Mark_Error:
MsgBox ("This->Example: " & Err.Description)
Show = False
Resume Mark_Exit
End Function