AW: mehrdeutiger NAme
27.07.2011 13:25:51
volker
Hallo nochmals,
ich möchte Euch nicht mit meinem Code zumüllen aber leider komm ich selbst nicht weiter.
Ich hab nun mal alles was bei mir im "basmain" drin steht.
Was kann ich noch machen?
Besten Dank Euch allen Gruss volker
ption Explicit
Option Private Module
Private Type InfoT
hwnd As Long
Root As Long
DisplayName As Long
Title As Long
Flags As Long
FName As Long
lParam As Long
Image As Long
End Type
Public 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 SHBrowseForFolder Lib "shell32" (lpbi As InfoT) As Long
Private Declare
Function CoTaskMemFree Lib "ole32" (ByVal hMem As Long) As Long
Private Declare
Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpStr1 As String, ByVal lpStr2 As _
String) As Long
Private Declare
Function SHGetPathFromIDList Lib "shell32" (ByVal pList As Long, ByVal lpBuffer As String) As _
Long
Private Declare
Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassname As String, ByVal _
lpWindowName As String) As Long
Declare
Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare
Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Sub DirAuswahl()
Dim sMsg As String, sPath As String
sMsg = "Wählen Sie bitte einen Ordner aus:"
sPath = getdirectory(sMsg)
If sPath "" Then MsgBox sPath
Range("D1") = sPath
End Sub
Function getdirectory(Optional msg) As String
Dim bInfo As BROWSEINFO
Dim Path As String
Dim r As Long, x As Long, pos As Integer
bInfo.pidlRoot = 0&
If IsMissing(msg) Then
bInfo.lpszTitle = "Wählen Sie bitte einen Ordner aus."
Else
bInfo.lpszTitle = msg
End If
bInfo.ulFlags = &H1
x = SHBrowseForFolder(bInfo)
Path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal Path)
If r Then
pos = InStr(Path, Chr$(0))
getdirectory = Left(Path, pos - 1)
Else
getdirectory = ""
End If
End Function