Ein beliebiges Verzeichnis öffnen |
|
Mit den integrierten Dialog-Fenstern (Dialogs(...) lassen sich bequem Dateien einlesen und daraus der Dateiname und der Pfad ermitteln. Soll hingegen nur ein Verzeichnis(name) ermittelt oder ausgewählt werden, ist der Weg über die Dateiauswahl nicht die eleganteste. 1 Sub Ordnerauswahl() 2 Dim Verzeichnis As String 3 Verzeichnis2 = GetFolderInternal(Verzeichnis, Verzeichnis) 4 End Sub Und in ein extra Modul: 1 Option Explicit 2 Private Type BROWSEINFO 3 hWndOwner As Long 4 pidlRoot As Long 5 pszDisplayName As String 6 lpszTitle As String 7 ulFlags As Long 8 lpFn As Long 9 lParam As String 10 iImage As Long 11 End Type 12 Private Declare Function SHBrowseForFolder Lib "shell32.dll" _ Alias "SHBrowseForFolderA" (ByRef lpbi As BROWSEINFO) As Long 13 Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _ Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _ ByVal pszPath As String) As Long 14 Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long) 15 Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _ (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _ ByVal lParam As Long) As Long 16 Private Const WM_USER As Long = &H400 17 Private Const BIF_RETURNONLYFSDIRS As Long = 1 18 Private Const BFFM_INITIALIZED As Long = 1 19 Private Const BFFM_SETSELECTION As Long = (WM_USER + 102) 20 Private Const MAX_PATH As Long = 260 21 Public Function GetFolderInternal(ByVal Caption As String, _ ByVal Default As String) As String 22 Dim BI As BROWSEINFO 23 Dim ListIdx As Long 24 Dim Path As String 25 With BI 26 .lpszTitle = Caption 27 .ulFlags = BIF_RETURNONLYFSDIRS 28 .lpFn = MakeFktnPtr(AddressOf BrowseCallbackProc) 29 .lParam = Default 30 End With 31 Path = String$(MAX_PATH + 1, vbNullChar) 32 ListIdx = SHBrowseForFolder(BI) 33 If SHGetPathFromIDList(ListIdx, Path) Then 34 GetFolderInternal = Left$(Path, InStr(Path, vbNullChar) - 1) 35 End If 36 CoTaskMemFree ListIdx 37 End Function 38 Private Function BrowseCallbackProc(ByVal hWnd As Long, _ ByVal Msg As Long, _ ByVal lParam As Long, _ ByVal lpData As Long) As Long 39 On Error Resume Next 40 If Msg = BFFM_INITIALIZED Then 41 SendMessage hWnd, BFFM_SETSELECTION, 1&, lpData 42 End If 43 End Function 44 Private Function MakeFktnPtr(ByVal FktnPtr As Long) As Long 45 MakeFktnPtr = FktnPtr 46 End Function Der Dateidownload steht z.Z. leider nicht zur Verfügung. |
Besucher: 0 online | 0 heute | 0 diesen Monat | 2202302 insgesamt | Seitenaufrufe: 54 | Letzte Änderung: 24.06.2006 | © 2001-18 Christian Freßdorf | ||||
Mode ist eine Form der Häßlichkeit, die so unerträglich ist, daß wir sie alle sechs Monate ändern müssen. Oscar Wilde, 1854-1900, irischer Schriftsteller |
powered by phpCMS and PAX |