Discussion :

[kika.93]

Bonjour à tous,
Je travaille sous Access 2003 en VBA et j'ai besoin dans un formulaire de mettre le chemin complet d'un fichier dans un textbox. J'ai donc un bouton à côté dont j'aimerai bien qu'il ouvre une fenetre explorateur. J'ai cherché mais j'ai trouvé soit des solutions à l'aide de CommonDiag (qui n'existe qu'en VB6 apparement) soit à l'aide de l'API du shell SHBrowseForFolder qui fonctionne en VBA mais qui renvoie seulement le chemin du répertoire et non le chemin complet.
Merci de votre aide : )

[jmfmarques]

si tu ne veux ou peux pas utiliser le contrôle CommonDialog, c'est à l'API GetOpenFileName qu'il te faut t'intéresser...

En recherchant sur ce terme et sur mon pseudo sur ce forum, tu devrais trouver un exemple assez récent

[kika.93]

Merci de ta réponse rapide en ce début d'aout ; ), je vais regarder ca de suite.
Ce n'est pas que je ne veux pas utiliser CommonDiag mais ce contrôle n'est pas présent dans ma version (Access 2003) ou alors il y a quelque chose à importer quelque part mais mystère.

[marot_r]

Ou, les commonDilaog n'ont de common que le nom.

Voici un bout de code qui fait cela. (il récupère seulement le chemin et pas le fichier mais tu ne devrais pas avoir de pb pour l'adapter, le gros du travail est dans la 1ere partie de code.

A+

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
 
Option Compare Database
Option Explicit
 
Private Const MAX_BUFFER_LENGTH = 256
 
'Function Declarations
Private Declare Function GetOpenFileName Lib "comdlg32.dll" _
    Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
 
Private Type OPENFILENAME
        lStructSize As Long
        hwndOwner As Long
        hInstance As Long
        lpstrFilter As String
        lpstrCustomFilter As String
        nMaxCustFilter As Long
        nFilterIndex As Long
        lpstrFile As String
        nMaxFile As Long
        lpstrFileTitle As String
        nMaxFileTitle As Long
        lpstrInitialDir As String
        lpstrTitle As String
        flags As Long
        nFileOffset As Integer
        nFileExtension As Integer
        lpstrDefExt As String
        lCustData As Long
        lpfnHook As Long
        lpTemplateName As String
End Type
 
'Valeur des différent flags
Private Const OFN_AllowMultiSelect = &H200
Private Const OFN_CreatePrompt = &H2000
Private Const OFN_EnableHook = &H20
Private Const OFN_EnableTemplate = &H40
Private Const OFN_EnableTemplateHandle = &H80
Private Const OFN_EXPLORER = &H80000
Private Const OFN_ExtensionDifferent = &H400
Private Const OFN_FileMustExist = &H1000
Private Const OFN_HideReadOnly = &H4
Private Const OFN_LongNames = &H200000
Private Const OFN_NoChangeDir = &H8
Private Const OFN_NoDeReferenceLinks = &H100000
Private Const OFN_NoLongNames = &H40000
Private Const OFN_NoNetWorkButton = &H20000
Private Const OFN_NoReadOnlyReturn = &H8000
Private Const OFN_NoTestFileCreate = &H10000
Private Const OFN_NoValiDate = &H100
Private Const OFN_OverWritePrompt = &H2
Private Const OFN_PathMustExist = &H800
Private Const OFN_ReadOnly = &H1
Private Const OFN_ShareAware = &H4000
Private Const OFN_ShareFallThrough = 2
Private Const OFN_ShareNoWarn = 1
Private Const OFN_ShareWarn = 0
Private Const OFN_ShowHelp = &H10
 
Public Const OFN_MULTI_SELECT As Boolean = True
Public Const OFN_UNIQUE_SELECT As Boolean = False
 
Private Sub Test_OpenFileEnhancedMultiFilter()
    Dim fileList As Collection
    Dim i As Integer
    Dim titresEtFiltres As Collection
    Dim titreEtFiltre As ClasseTitreEtFiltreFichier
 
    Set titresEtFiltres = New Collection
 
    Set titreEtFiltre = New ClasseTitreEtFiltreFichier
    Call titreEtFiltre.Fill("Images", "*.jpg;*.jpeg")
    titresEtFiltres.Add titreEtFiltre
 
    Set titreEtFiltre = New ClasseTitreEtFiltreFichier
    Call titreEtFiltre.Fill("Tous les fichiers", "*.*")
    titresEtFiltres.Add titreEtFiltre
 
    Set fileList = New Collection
 
    Set fileList = OpenFileEnhancedMultiFilter("Test", titresEtFiltres, "C:\Documents and Settings\All Users\Documents\Mes images\Échantillons d'images\", OFN_MULTI_SELECT)
 
    For i = 1 To fileList.Count
        Debug.Print fileList.Item(i)
    Next i
 
    Set fileList = Nothing
 
End Sub
 
 
'
'Le code provient de http://access.developpez.com/faq/?page=TATablesAndFields
' Je l'ai adapté à nos besoins.
' René MAROT 2005/08/16
'
 
Public Function OpenFileEnhancedMultiFilter(prmTitreFenetre As String, _
                                            prmTitreEtFiltreFichier As Collection, _
                                            prmDirInitial As String, _
                                            prmSelectionMultiple As Boolean) As Collection
 
Dim Dialogue As OPENFILENAME
Dim fileFilter As String
Dim openFile As String
Dim result As Collection
Dim valeurRetournee As Long
Dim tf As ClasseTitreEtFiltreFichier
 
fileFilter = ""
For Each tf In prmTitreEtFiltreFichier
    fileFilter = fileFilter & tf.Titre & Chr(0) & tf.filtre & Chr(0)
Next tf
 
If fileFilter <> "" Then
    fileFilter = fileFilter & Chr(0)
End If
 
With Dialogue
    .lStructSize = Len(Dialogue)
    .lpstrFilter = fileFilter
    .lpstrFile = Space(254)
    .nMaxFile = 255
    .lpstrFileTitle = Space(254)
    .nMaxFileTitle = 255
    .lpstrInitialDir = prmDirInitial
    .lpstrTitle = prmTitreFenetre
 
  If prmSelectionMultiple = False Then
    .flags = OFN_FileMustExist + _
             OFN_HideReadOnly + _
             OFN_PathMustExist
  Else
    .flags = OFN_FileMustExist + _
             OFN_HideReadOnly + _
             OFN_PathMustExist + _
             OFN_AllowMultiSelect + _
             OFN_LongNames + _
             OFN_EXPLORER
  End If
 
End With
 
valeurRetournee = GetOpenFileName(Dialogue)
 
Select Case valeurRetournee
    Case Is >= 1
        Set result = MultiSelectedFiles(Dialogue.lpstrFile)
 
    Case Else
        Set result = New Collection
 
End Select
 
Set OpenFileEnhancedMultiFilter = result
 
End Function
 
Private Sub test_OpenFileEnhanced()
    Dim fileList As Collection
    Dim i As Integer
 
    Set fileList = New Collection
 
    Set fileList = OpenFileEnhanced("Test", "Images", "*.jpg", "C:\Documents and Settings\All Users\Documents\Mes images\Échantillons d'images\", OFN_MULTI_SELECT)
 
    For i = 1 To fileList.Count
        Debug.Print fileList.Item(i)
    Next i
 
    Set fileList = Nothing
 
End Sub
 
'Le code provient de http://access.developpez.com/faq/?page=TATablesAndFields
' Je l'ai adapté à nos besoins.
' René MAROT 2005/08/16
'
 
Public Function OpenFileEnhanced(Optional prmTitreFenetre As String = "Ouvrir", _
                                 Optional prmTitreFiltreFichier As String = "Tous les fichiers", _
                                 Optional prmFiltreFichier As String = "*.*", _
                                 Optional prmDirInitial As String = "C:\", _
                                 Optional prmSelectionMultiple As Boolean = OFN_UNIQUE_SELECT _
                                 ) As Collection
 
Dim Dialogue As OPENFILENAME
Dim fileFilter As String
Dim openFile As String
Dim result As Collection
Dim valeuRetournee As Long
 
fileFilter = prmTitreFiltreFichier & Chr$(0) & prmFiltreFichier & Chr(0) & Chr(0)
 
With Dialogue
    .lStructSize = Len(Dialogue)
    .lpstrFilter = fileFilter
    .lpstrFile = Space(254)
    .nMaxFile = 255
    .lpstrFileTitle = Space(254)
    .nMaxFileTitle = 255
    .lpstrInitialDir = prmDirInitial
    .lpstrTitle = prmTitreFenetre
 
  If prmSelectionMultiple = False Then
    .flags = OFN_FileMustExist + _
             OFN_HideReadOnly + _
             OFN_PathMustExist
  Else
    .flags = OFN_FileMustExist + _
             OFN_HideReadOnly + _
             OFN_PathMustExist + _
             OFN_AllowMultiSelect + _
             OFN_LongNames + _
             OFN_EXPLORER
  End If
 
End With
 
valeuRetournee = GetOpenFileName(Dialogue)
 
Select Case valeuRetournee
    Case Is >= 1
        Set result = MultiSelectedFiles(Dialogue.lpstrFile)
 
    Case Else
        Set result = New Collection
 
End Select
 
Set OpenFileEnhanced = result
 
End Function
 
Private Function MultiSelectedFiles(ByVal prmListeFichiers As String) As Collection
 
Dim TabFile As Collection
Dim i As Integer
Dim result As Collection
 
Set result = New Collection
 
Set result = splitFile(prmListeFichiers, vbNullChar)
 
Set MultiSelectedFiles = result
 
End Function
 
'Découpe une chaine de caractère selon un caractère donné
Private Function splitFile(ByVal prmTexte As String, _
                           Optional prmDelimiteur As String, _
                           Optional prmRetournerMax As Long = -1, _
                           Optional prmCompare As Long = vbBinaryCompare _
                           ) As Collection
 
    Dim texte As String
    Dim result As Collection
    Dim premierItem As String
    Dim filePath As String
    Dim fileName As String
 
    Set result = New Collection
 
    texte = Trim(prmTexte)
 
    If prmDelimiteur = "" Then
           result.Add texte
        Else
            premierItem = ReadFileUntilAndMoveToNext(texte, prmDelimiteur, prmCompare)
 
            If premierItem = Trim(prmTexte) Then
                    'un seul fichier selectionné, tout vient d'un bloc
                    result.Add premierItem
                Else
                    'un chemin + un liste de fichiers
                    filePath = premierItem
 
                    Do
                        If prmRetournerMax <> -1 And result.Count >= prmRetournerMax Then
                           Exit Do
                        End If
 
                        fileName = ReadFileUntilAndMoveToNext(texte, prmDelimiteur)
                        If fileName <> "" Then
                            result.Add filePath & "\" & fileName
                        End If
 
                    Loop While texte <> ""
            End If
 
    End If
 
    Set splitFile = result
End Function
 
Private Function ReadFileUntilAndMoveToNext(ByRef prmListeFichiers As String, _
                                            prmDelimiteur As String, _
                                            Optional prmCompare As Long = vbBinaryCompare) _
                                            As String
 
    Dim nPos As Long
    nPos = InStr(1, prmListeFichiers, prmDelimiteur, prmCompare)
 
    If nPos > 0 Then
            ReadFileUntilAndMoveToNext = Left(prmListeFichiers, nPos - 1)
            prmListeFichiers = Mid(prmListeFichiers, nPos + Len(prmDelimiteur))
        Else
            ReadFileUntilAndMoveToNext = ""
            prmListeFichiers = ""
    End If
 
End Function
 
Public Function openFile(Title As String, Optional File_Type_Title As String, _
                        Optional File_Type_Extension As String, _
                        Optional InitDir As String) As String
'API reference is "GetOpenFileName" using comdlg32.dll
    If Not MODE_DEBUG Then
        On Error GoTo Error_OpenFile
    End If
 
    Dim MyPath As String
    Dim rc As Long
    Dim sFilters As String
    Dim pOpenfilename As OPENFILENAME
 
    sFilters = "All Files (*.*)" & Chr$(0) & _
              "*.*" & Chr$(0) & _
              "Microsoft Access (*.mdb)" & Chr$(0) & _
              "*.mdb" & Chr$(0) & _
              "Microsoft Excel (*.xls)" & Chr$(0) & _
              "*.xls" & Chr$(0) & _
              "Microsoft Word (*.doc)" & Chr$(0) & _
              "*.doc" & Chr$(0) & _
              "Rich Text Format (*.rtf)" & Chr$(0) & _
              "*.rtf" & Chr$(0) & _
              "Text Files (*.txt)" & Chr$(0) & _
              "*.txt" & Chr$(0)
 
    MyPath = CodeDb.Name
 
With pOpenfilename
    .hwndOwner = Application.hWndAccessApp
    .hInstance = 1
    .lpstrTitle = Title
 
    If InitDir = "" Then
      .lpstrInitialDir = MyPath
    Else
      .lpstrInitialDir = InitDir
    End If
 
    If File_Type_Title = "" Or File_Type_Extension = "" Then
      .lpstrFilter = sFilters
    Else
      .lpstrFilter = File_Type_Title & Chr$(0) & File_Type_Extension & Chr$(0)
    End If
 
    .nFilterIndex = 1
    .lpstrFile = String(MAX_BUFFER_LENGTH, 0)
    .nMaxFile = MAX_BUFFER_LENGTH - 1
    .lpstrFileTitle = .lpstrFile
    .nMaxFileTitle = MAX_BUFFER_LENGTH - 1
    .lStructSize = Len(pOpenfilename)
End With
 
rc = GetOpenFileName(pOpenfilename)
 
If rc Then
    'A file has been selected
    openFile = TrimNull(Left$(pOpenfilename.lpstrFile, pOpenfilename.nMaxFile))
Else
    'The cancel button has been pressed
    openFile = ""
End If
 
Exit_OpenFile:
    CodeDb.Close
    'Set dbs = Nothing
    Exit Function
 
Error_OpenFile:
    MsgBox Err.Description, 0, Err.Number
    Resume Exit_OpenFile:
End Function
 
 
 
Private Function TrimNull(ByVal strItem As String) As String
'This function is used to trim the null characters off the end
'of the file names returned by the OpenFile and SaveFile functions.
Dim intPos As Integer
    intPos = InStr(strItem, vbNullChar)
    If intPos > 0 Then
        TrimNull = Left(strItem, intPos - 1)
    Else
        TrimNull = strItem
    End If
End Function

dans un bouton

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
 
Private Sub cmdBrowse_Click()
    If Not MODE_DEBUG Then
        On Error GoTo Err_cmdBrowse_Click
    End If
 
    Dim thefile As String
 
    thefile = openFile("Base Liée", "All Files", "*.mdb", "C:\Documents and Settings\All Users\Bureau\")
    If Len(thefile) > 1 Then
        Me.CheminBaseLiee = LireChemin(thefile)
    End If
 
Exit_cmdBrowse_Click:
    Exit Sub
 
Err_cmdBrowse_Click:
    Call AfficherMessErrStandard(Err)
    Resume Exit_cmdBrowse_Click
End Sub

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
 
Public Function LireChemin(prmNomCompletFichier_or_ConnexionString As String) As String
    Dim result As String
    Dim c As String
 
    Dim nomCompletFichier As String
 
    If Left(prmNomCompletFichier_or_ConnexionString, Len(";DATABASE=")) = ";DATABASE=" Then
            nomCompletFichier = Mid(prmNomCompletFichier_or_ConnexionString, 11)
        Else
            nomCompletFichier = prmNomCompletFichier_or_ConnexionString
    End If
 
    Dim i As Integer
    For i = Len(nomCompletFichier) To 1 Step -1
        c = Mid(nomCompletFichier, i, 1)
        If c = "\" Then
            result = Left(nomCompletFichier, i)
            Exit For
        End If
    Next i
 
    LireChemin = result
End Function

[Dolphy35]

Salut,

Le code de la La F.A.Q Access renvoi également le chemin complet du fichier sélectionné.
Afficher la boîte de dialogue ouvrir afin de récupérer le nom et le chemin du fichier sélectionné