01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98 |
|
Option Explicit
Private Declare PtrSafe Function MoveWindow Lib "user32.dll" ( _
ByVal hwnd As LongLong, ByVal x As Long, _
ByVal y As Long, ByVal nWidth As Long, _
ByVal nHeight As Long, ByVal bRepaint As Long) As LongLong
Private Declare PtrSafe Function GetSystemMetrics Lib "user32.dll" ( _
ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetWindowRect Lib "user32.dll" ( _
ByVal hwnd As LongLong, ByRef lpRect As RECT) As Long
Private Declare PtrSafe Function CoTaskMemFree Lib "ole32" ( _
ByVal hMem As LongLong) As LongLong
Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32" ( _
ByVal pList As LongLong, ByVal lpBuffer As String) As LongLong
Private Declare PtrSafe Function SendMessageA Lib "user32.dll" ( _
ByVal hwnd As LongLong, ByVal Msg As Long, _
wParam As LongLong, lParam As Any) As LongLong
Private Declare PtrSafe Function SHBrowseForFolderA Lib "Shell32.dll" ( _
lpBrowseInfo As InfoT) As LongLong
Private Type InfoT
hwnd As LongLong
Root As LongLong
DisplayName As String
Title As String
Flags As Long
FName As LongLong
lParam As LongLong
Image As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private s_BrowseInitDir As String
Private Function BrowseCallback( _
ByVal hwnd As LongLong, ByVal uMsg As Long, _
ByVal wParam As LongLong, ByVal lParam As LongLong) As Long
If uMsg = &H1 Then
Call SendMessageA(hwnd, &H466, ByVal 1&, ByVal s_BrowseInitDir)
Call CenterDialog(hwnd)
End If
BrowseCallback = 0
End Function
Private Function FuncCallback(ByVal nParam As LongLong) As LongLong
FuncCallback = nParam
End Function
Private Sub CenterDialog(ByVal hwnd As LongLong)
Dim WinRect As RECT, ScrWidth As Long, ScrHeight As Long
Dim DlgWidth As Integer, DlgHeight As Integer
GetWindowRect hwnd, WinRect
DlgWidth = WinRect.Right - WinRect.Left
DlgHeight = WinRect.Bottom - WinRect.Top
ScrWidth = GetSystemMetrics(&H10)
ScrHeight = GetSystemMetrics(&H11)
MoveWindow hwnd, (ScrWidth - DlgWidth) / 2, _
(ScrHeight - DlgHeight) / 2, DlgWidth, DlgHeight, 1
End Sub
Public Function fncGetFolder( _
Optional ByVal sMsg As String = "Bitte wählen Sie ein Verzeichnis", _
Optional ByVal sPath As String = "C:\") As String
Dim xl As InfoT, IDList As LongLong, RVal As LongLong, FolderName As String
If sPath Like "*.???" Or sPath Like "*.????" Then
sPath = Left$(sPath, InStrRev(sPath, "\"))
End If
If Dir(sPath, vbDirectory) = "" Then
sPath = ThisWorkbook.Path
End If
s_BrowseInitDir = sPath
With xl
.hwnd = Application.hwnd
.Title = sMsg ' lstrcat(sMsg, "")
.Flags = &H1
.FName = FuncCallback(AddressOf BrowseCallback)
End With
IDList = SHBrowseForFolderA(xl)
If IDList <> 0 Then
FolderName = Space(256)
RVal = SHGetPathFromIDList(IDList, FolderName)
CoTaskMemFree (IDList)
FolderName = Trim$(FolderName)
FolderName = Left$(FolderName, Len(FolderName) - 1)
End If
fncGetFolder = FolderName
End Function
|