title image


Smiley Re: Auswahl eines Pfads durch VBA
Füge folgenden Code in ein Modul:



Option Explicit



' Benötigte API-Deklarationen

Private Type BrowseInfo

hWndOwner As Long

pIDLRoot As Long

pszDisplayName As Long

lpszTitle As Long

ulFlags As Long

lpfnCallback As Long

lParam As Long

iImage As Long

End Type



Private Const MAX_PATH = 260

Private Const BIF_RETURNONLYFSDIRS = &H1

Private Const BFFM_SETSELECTION = &H466

Private Const BFFM_INITIALIZED = 1



Private Declare Sub CoTaskMemFree Lib "ole32.dll" _

(ByVal hMem As Long)



Private Declare Function lstrcat Lib "kernel32" Alias _

"lstrcatA" (ByVal lpString1 As String, _

ByVal lpString2 As String) As Long



Private Declare Function GetActiveWindow Lib "user32" () As Long



Private Declare Function SHGetPathFromIDList Lib "shell32" ( _

ByVal pidList As Long, _

ByVal lpBuffer As String) As Long



Private Declare Function SHBrowseForFolder Lib "shell32" ( _

lpbi 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 m_BrowseInitDir As String

' Ordnerauswahl-Dialog mit optionaler

' Angabe eines Startverzeichnisses

Public Function BrowseForFolder(ByVal sPrompt As String, _

Optional ByVal sInitDir As String) As String



Dim nPos As Long

Dim nIDList As Long

Dim sPath As String

Dim oInfo As BrowseInfo



m_BrowseInitDir = sInitDir



' Datenstruktur füllen

With oInfo

.hWndOwner = GetActiveWindow()

.lpszTitle = lstrcat(sPrompt, "")

.ulFlags = BIF_RETURNONLYFSDIRS

If sInitDir "" Then

' Callback-Funktionsadresse

.lpfnCallback = FuncCallback(AddressOf BrowseCallback)

End If

End With



' Dialog anzeigen und auswerten

nIDList = SHBrowseForFolder(oInfo)

If nIDList Then

sPath = String$(MAX_PATH, 0)

Call SHGetPathFromIDList(nIDList, sPath)

Call CoTaskMemFree(nIDList)

nPos = InStr(sPath, vbNullChar)

If nPos Then sPath = Left$(sPath, nPos - 1)

End If



BrowseForFolder = sPath

End Function

Private Function BrowseCallback(ByVal hWnd As Long, _

ByVal uMsg As Long, _

ByVal wParam As Long, _

ByVal lParam As Long) As Long



Select Case uMsg

Case BFFM_INITIALIZED

' Start-Ordner

Call SendMessage(hWnd, BFFM_SETSELECTION, ByVal 1&, _

ByVal m_BrowseInitDir)

End Select

BrowseCallback = 0

End Function

' Hilfsfunktion für AddressOf

Private Function FuncCallback(ByVal nParam As Long) As Long

FuncCallback = nParam

End Function





Aufruf:

Private Sub Ordner_Click()

Dim Pfad As String

Pfad = BrowseForFolder("Bitte Ordner wählen")

MsgBox Pfad

End Sub



geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: