Ordnerauswahl 64-Bit

Option Explicit
Option Compare Text
'API - Dateiauswahl-Dialog--------------------------------------------------------
Const OFN_READONLY           As Long = &H1
Const OFN_EXPLORER           As Long = &H80000
Const OFN_LONGNAMES          As Long = &H200000
Const OFN_CREATEPROMPT       As Long = &H2000
Const OFN_NODEREFERENCELINKS As Long = &H100000
Const OFN_OVERWRITEPROMPT    As Long = &H2
Const OFN_HIDEREADONLY       As Long = &H4
Const OFS_FILE_OPEN_FLAGS    As Long = OFN_EXPLORER _
Or OFN_LONGNAMES _
Or OFN_CREATEPROMPT _
Or OFN_NODEREFERENCELINKS
Const OFS_FILE_SAVE_FLAGS    As Long = OFN_EXPLORER _
Or OFN_LONGNAMES _
Or OFN_OVERWRITEPROMPT _
Or OFN_HIDEREADONLY
Type OPENFILENAME
nStructSize     As Long
hwndOwner       As Long
hInstance       As Long
sfilter         As String
sCustomFilter   As String
nCustFilterSize As Long
nFilterIndex    As Long
sFile           As String
nFileSize       As Long
sFileTitle      As String
nTitleSize      As Long
sInitDir        As String
sDlgTitle       As String
Flags           As Long
nFileOffset     As Integer
nFileExt        As Integer
sDefFileExt     As String
nCustData       As Long
fnHook          As Long
sTemplateName   As String
End Type
#If Win64 Then
Declare PtrSafe Function GetActiveWindow Lib "user32.dll" () As Long
Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" ( _
pOpenfilename As OPENFILENAME) As Long
Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" ( _
pOpenfilename As OPENFILENAME) As Long
Declare PtrSafe Function GetShortPathName Lib "kernel32.dll" Alias "GetShortPathNameA" ( _
ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
Declare PtrSafe Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" (ByVal  _
lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters As Long) As Long
Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA"  _
(ByVal pidl As Long, ByVal pszPath As String) As Long
'Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" ( _
lpBrowseInfo As BROWSEINFO) As Long
Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" ( _
lpBrowseInfo As BROWSEINFO) As LongPtr
Private Type BROWSEINFO
hOwner As LongPtr
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpFn As LongPtr
lParam As LongPtr
iImage As Long
End Type
#Else
Declare Function GetActiveWindow Lib "user32.dll" () As Long
Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename  _
As OPENFILENAME) As Long
Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename  _
As OPENFILENAME) As Long
Declare Function GetShortPathName Lib "kernel32.dll" Alias "GetShortPathNameA" (ByVal  _
lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" (ByVal  _
lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters As Long) 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
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
#End If
Function GetDirectory(Optional msg As String) As String
Dim bInfo As BROWSEINFO
Dim Path As String
Dim r As Long, X As Long, pos As Integer
10        bInfo.pidlRoot = 0&
20        If IsMissing(msg) Then
30            bInfo.lpszTitle = "Wählen Sie bitte einen Ordner aus."
40        Else
50            bInfo.lpszTitle = msg
60        End If
70        bInfo.ulFlags = &H1
80        X = SHBrowseForFolder(bInfo)
90        Path = Space$(512)
100       r = SHGetPathFromIDList(ByVal X, ByVal Path)
110       If r Then
120           pos = InStr(Path, Chr$(0))
130           GetDirectory = Left(Path, pos - 1)
140       Else
150           GetDirectory = ""
160       End If
End Function
Sub test123()
Dim sFilepath As String
sFilepath = GetDirectory
MsgBox (sFilepath)
End Sub
Danke Euch schonmal
VG
Steffen Schmerler