Verzeichnisauswahldialog für Access 97 [Archiv]

Günther Kramer

28.12.2002, 10:29

<img src="images/codearchiv/verzeichnisauswahldialog.gif" border=0> Mit dieser Funktion stellen Sie einen Auswahldialog zur Verfügung, mit dessen Hilfe der Anwender ein gewünschtes Verzeichnis auswählen kann. Der Verzeichnispfad wird als String an die Funktion zurückgegeben. Die besonderheit bei diesem Beispiel ist, dass man hier auch ein Startverzeichnis angeben kann. Erstellen Sie ein neues Modul und fügen Sie nachfolgenden Code ein:

<div><link href="http://www.ms-office-forum.net/forum/externals/codeconv.css" rel="stylesheet"><pre>Option Compare Database
Option Explicit
 
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
 
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
"SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long
 
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
"SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
As Long
 
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal Msg As Long, wParam As Any, lParam As Any) _
As Long
 
Private Const BIF_RETURNONLYFSDIRS = &H1
Private Const BFFM_SETSELECTION = &H466
Private Const BFFM_INITIALIZED = 1
 
Global StartDir As String
 
Public Function VerzeichnisSuchen(szDialogTitle As String, _
StartVerzeichnis As String) As String
 
Dim X As Long
Dim bi As BROWSEINFO
Dim dwIList As Long
Dim szPath As String
Dim wPos As Integer
 
StartDir = StartVerzeichnis
 
With bi
.hOwner = hWndAccessApp
.lpszTitle = szDialogTitle
.ulFlags = BIF_RETURNONLYFSDIRS
.lpfn = DummyFunc(AddrOf("BrowseCallbackProc"))
End With
 
dwIList = SHBrowseForFolder(bi)
szPath = Space$(512)
X = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)
 
If X Then
wPos = InStr(szPath, Chr(0))
VerzeichnisSuchen = Left$(szPath, wPos - 1)
Else
VerzeichnisSuchen = ""
End If
End Function
Public Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, _
ByVal lParam As Long, ByVal lpData As Long) As Long
 
Dim pathstring As String
Dim retval As Long
 
Select Case uMsg
Case BFFM_INITIALIZED
pathstring = StartDir '"C:\Temp"
retval = SendMessage(hWnd, BFFM_SETSELECTION, _
ByVal CLng(1), ByVal pathstring)
End Select
 
BrowseCallbackProc = 0
 
End Function
Public Function DummyFunc(ByVal param As Long) As Long
 
DummyFunc = param
 
End Function
</pre></div>
Da Access 97 die Funktion AddressOf nicht kennt, müssen Sie nur für die Access 97-Version ein zweites Modul erstellen. Kopieren Sie die folgenden Codezeilen in das neue Modul.

<div><link href="http://www.ms-office-forum.net/forum/externals/codeconv.css" rel="stylesheet"><pre>Option Compare Database
Option Explicit
 
Private Declare Function GetCurrentVbaProject Lib "vba332.dll" Alias _
"EbGetExecutingProj" (hProject As Long) As Long
 
Private Declare Function GetFuncID Lib "vba332.dll" Alias "TipGetFunctionId" _
(ByVal hProject As Long, ByVal strFunctionName As String, ByRef _
strFunctionId As String) As Long
 
Private Declare Function GetAddr Lib "vba332.dll" Alias _
"TipGetLpfnOfFunctionId" (ByVal hProject As Long, ByVal strFunctionId As _
String, ByRef lpfn As Long) As Long
 
Public Function AddrOf(strFuncName As String) As Long
Dim hProject As Long
Dim lngResult As Long
Dim strID As String
Dim lpfn As Long
Dim strFuncNameUnicode As String
 
Const NO_ERROR = 0
 
' The function name must be in Unicode, so convert it.
strFuncNameUnicode = StrConv(strFuncName, vbUnicode)
 
' Get the current VBA project
' The results of GetCurrentVBAProject seemed inconsistent, in our tests,
' so now we just check the project handle when the function returns.
Call GetCurrentVbaProject(hProject)
 
' Make sure we got a project handle... we always should, but you never know!
If hProject <> 0 Then
 ' Get the VBA function ID (whatever that is!)
lngResult = GetFuncID(hProject, strFuncNameUnicode, strID)
 
 ' We have to check this because we GPF if we try to get a function pointer
 ' of a non-existent function.
If lngResult = NO_ERROR Then
 ' Get the function pointer.
lngResult = GetAddr(hProject, strID, lpfn)
 
If lngResult = NO_ERROR Then
AddrOf = lpfn
End If
End If
End If
 
End Function</pre></div>

Um den Dialog aufzurufen und das Ergebnis einem Feld innerhalb des Formulars zurückzugeben erstellen Sie bitte eine Schaltfläche mit dem Namen Verzeichnisauswahl. Der im Beispiel verwendete Namen für das Feld, in welches der Verzeichnispfad zurückgeschrieben wird, lautet Verzeichnis. Beide Namen (Schaltfläche & Feld) können Sie natürlich anders benennen.

<div><link href="http://www.ms-office-forum.net/forum/externals/codeconv.css" rel="stylesheet"><pre>Private Sub Verzeichnisauswahl_Click()
 
Dim strVerzeichnisName As String
 
If IsNull(Me!Verzeichnis) Then
Me!Verzeichnis = ""
End If
 
strVerzeichnisName = VerzeichnisSuchen _
("Wählen Sie bitte das Verzeichnis aus!", Me!Verzeichnis)
 
If ((Not IsNull(strVerzeichnisName)) And (strVerzeichnisName <> "")) Then
Me!Verzeichnis = strVerzeichnisName
End If
 
End Sub</pre></div>

Sascha Trowitzsch

29.07.2003, 13:02

Alternativen gibt es auch unter http://www.ms-office-forum.net/forum/showthread.php?s=&threadid=95650

ibens

02.11.2005, 08:31

Hallo !!!

Wie kann ich dann Pfad des ausgewählten Ordners in eine Tabele speichern???

Gruss
ibens

TommyK

03.11.2005, 04:35

Hallo ibens,

das musst Du mal genauer erläutern was wo wie machen willst.

hanspeterludwig

08.03.2013, 14:15

Hallo Miteinander,

bin gerade dabei dieses Modul in eine Anwendung zu einzubinden.

Leider bekomme ich diese Meldung "Sub oder Function nicht definiert".

Es wird die Zeile:
.lpfn = DummyFunc(AddrOf("BrowseCallbackProc"))

markiert. Was habe ich falsch gemacht? Arbeite mit der Version 2003 ...

Danke für die Hilfe ...

Marsu65

11.03.2013, 21:53

Hallo,
ersetze die Zeile
.lpfn = DummyFunc(AddrOf("BrowseCallbackProc"))
durch .lpfn = DummyFunc(AddressOf BrowseCallbackProc)

PS: Schau dir mal die Bsp. aus Saschas Link an.
Vor allem den von ihm gezeigten 12-Zeiler finde ich besser.

MaggieMay

27.04.2016, 16:46

Hallo miteinander,

ich hoffe, hier schaut nochmal jemand rein, ich hätte nämlich zum Beitrag von Günther die folgende Frage...
Was bewirkt dieser Befehl:

.lpfn = DummyFunc(AddrOf("BrowseCallbackProc"))

Ich bekomme nämlich in der folgenden Zeile:
Call GetCurrentVbaProject(hProject)einen Fehler bzgl. vba332.dll, welche nicht gefunden wird (und auch nicht vorhanden ist).

Wenn ich nun einfach .lpfn auf 0 setze, scheint alles zu funktionieren.
Was also bewirkt der Aufruf von "DummyFunc" bzw. was macht die "BrowseCallbackProc"?
Ich muss gestehen, das ganze Konstrukt ist mir unklar.

Wenn die o.g. Lösung nicht mehr zeitgemäß ist, so würde ich mich über einen Hinweis auf einen alternativen Verzeichnisauswahldialog mit Vorgabe eines Startordners und frei wählbarem Titel freuen.

uwek

28.04.2016, 16:20

Hallo Maggie,

Dieser hier (http://www.vbarchiv.net/tipps/tipp_1089-browseforfolder-mit-extra-funktionen.html) sollte deine Erwartungen erfüllen.

MaggieMay

28.04.2016, 16:56

Hallo Uwe,

vielen Dank für den Link, aber ich hatte ehrlich gesagt auf eine "schlankere" Lösung gehofft. Werden die ganzen API-Deklarationen tatsächlich alle benötigt? :eek:
Ich bin nämlich dabei, eine Anwendung für Office 64 Bit zum Laufen zu bringen und bei der Umschreibung des Codes bin ich ziemlich am Schwimmen, es läuft mehr oder weniger auf Try & Error hinaus, was echt mühsam und zeitaufwändig ist.

Außerdem ist da ja auch wieder die CallBack-Funktion mit drin, kannst du mir erklären wozu genau die gut ist?

Ich hatte auch schon diesen Tipp ausprobiert:
PS: Schau dir mal die Bsp. aus Saschas Link an.
Vor allem den von ihm gezeigten 12-Zeiler finde ich besser.der bei der 32 Bit Version prima klappt, mit 64 Bit aber einen Datentypenfehler bringt. Das ist wieder die Krux, dass nirgendwo richtig dokumentiert zu sein scheint, was genau anzupassen ist. :(

uwek

28.04.2016, 17:03

Schau mal hie (http://www.ms-office-forum.net/forum/showthread.php?t=263854)r im Forum

MaggieMay

28.04.2016, 17:23

Vielen lieben Dank, das sollte wohl auch mir helfen!

Die dort verlinkte Seite kannte ich sogar schon, hatte nur nicht bemerkt, dass ein Teil genau dieses Beispiels dort zur Demonstration der bedingten Kompilierung verwendet wurde.

JPA

29.04.2016, 09:14

Mir gefällt das Dialog-Fenster sehr gut, leider kann es nicht vergrößert werden, daher verwende ich lieber diese Lösung:

Public Function GetFilename(Action As Long, SelectedItems() As String, Optional dlgTitle As String, Optional OpenButtonTitle As String _
, Optional IniFile As String, Optional IniDir As String _
, Optional Filter As String = "", Optional FilterIndex As Long, Optional View As Long, Optional FileMustExist As Boolean = True) As Boolean
DoCmd.Hourglass False
Select Case Action
Case 2 'Mehrfachauswahl
Action = 8
Case 3 'Ordnerauswahl
Action = 32
Case Else 'Einzelauswahl (nur eine Datei)
Action = 4
End Select
If View >= 0 Then Action = Action + 64 Else View = 0
WizHook.Key = 51488399
If WizHook.GetFilename(0, "", dlgTitle, OpenButtonTitle, IniFile, IniDir, Filter, FilterIndex, View, Action, FileMustExist) = 0 Then
SelectedItems = Split(IniFile, vbTab)
GetFilename = True
End If
End Function

Und es ist eine Lösung für beides (Datei und Ordner pickup).

Gruß
JPA