1
2
3
4
5
6
7
8
9
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
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
| Option Explicit
Private Const WM_USER = &H400
Private Const BIF_STATUSTEXT = &H4
Private Const BFFM_SELCHANGED = 2
Private Const BFFM_INITIALIZED = 1
Private Const BFFM_SETSTATUSTEXT = (WM_USER + 100)
Private Const BFFM_SETSELECTION = (WM_USER + 102)
Private Const BIF_RETURNONLYFSDIRS = &H1
Private Const BIF_BROWSEINCLUDEFILES = &H4000
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 Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal HWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32.dll" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
'Api's pour AddressOf 97
Private Declare Function GetCurrentVbaProject Lib "vba332.dll" Alias "EbGetExecutingProj" (hProject As Long) As Long
Private Declare Function GetFuncID Lib "vba332.dll" Alias "TipGetFunctionId" (ByVal hProject As Long, ByVal strFunctionName As String, ByRef strFunctionId As String) As Long
Private Declare Function GetAddr Lib "vba332.dll" Alias "TipGetLpfnOfFunctionId" (ByVal hProject As Long, ByVal strFunctionId As String, ByRef lpfunction As Long) As Long
Private sTargetFolder As String
Private Function GetAddressOfFunction(ByRef Address As Long) As Long
GetAddressOfFunction = Address
End Function
Private Function AddressOf97(strFuncName As String) As Long
Dim hProject As Long
Dim lngResult As Long
Dim strID As String
Dim lpfunction As Long
Dim strFuncNameUnicode As String
Const NO_ERROR = 0
' Conversion Unicode
strFuncNameUnicode = StrConv(strFuncName, vbUnicode)
' handle du projet VBA en cours
Call GetCurrentVbaProject(hProject)
' Espérant biensûr qu'il est > 0
If hProject <> 0 Then
' Obtention de l'ID de la fonction
lngResult = GetFuncID(hProject, strFuncNameUnicode, strID)
'Et on vérifie que lngResult <>0 à cause d'un GPF potentiel si la fonction concernée n'existe pas
If lngResult = NO_ERROR Then
' On obtient alors le pointeur
lngResult = GetAddr(hProject, strID, lpfunction)
If lngResult = NO_ERROR Then
AddressOf97 = lpfunction
End If
End If
End If
End Function
Public Function ShowDialogFolders(ByVal WelcomeTitle As String, ByVal DefaultFolder As String) As String
Dim lSHFolder As Long
Dim sBuffer As String
Dim tBROWSE_INFO As BrowseInfo
sTargetFolder = IIf(Len(DefaultFolder) > 0, DefaultFolder & vbNullChar, vbNullChar)
With tBROWSE_INFO
.lpszTitle = lstrcat(WelcomeTitle, vbNullString)
.lpfnCallback = GetAddressOfFunction(AddressOf97("BrowseCallbackProc"))
.ulFlags = BIF_STATUSTEXT + BIF_RETURNONLYFSDIRS
.hWndOwner = 0
End With
lSHFolder = SHBrowseForFolder(tBROWSE_INFO)
If (lSHFolder) Then
sBuffer = Space(260)
SHGetPathFromIDList lSHFolder, sBuffer
CoTaskMemFree lSHFolder
ShowDialogFolders = TrimNullChar(sBuffer)
Else
ShowDialogFolders = ""
End If
End Function
Private Function BrowseCallbackProc(ByVal HWnd As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long
Dim lSHFolder As Long
Dim lReturn As Long
Dim sBuffer As String
On Error Resume Next
Select Case uMsg
Case BFFM_INITIALIZED
SendMessage HWnd, BFFM_SETSELECTION, 1, sTargetFolder
Case BFFM_SELCHANGED
sBuffer = Space(260)
lReturn = SHGetPathFromIDList(lp, sBuffer)
If lReturn = 1 Then SendMessage HWnd, BFFM_SETSTATUSTEXT, 0, sBuffer
End Select
BrowseCallbackProc = 0
End Function
Function TrimNullChar(ByVal PathBuffer As String) As String
Dim nPos As Long
nPos = InStr(PathBuffer, vbNullChar)
TrimNullChar = IIf(nPos > 0, Left(PathBuffer, nPos - 1), PathBuffer)
End Function |
Récupérer sous access une liste de fichiers sélectionnés
Répondre avec citation
surtout avec les fonctionnalités qu'offre vb (drivelistbox, dirlistbox, filelistbox). Si quelqu'un sait comment faire ...
Partager