Récupérer le chemin d'accés d'un fichier

[massol joel]

Bonjour,

Depuis plusieurs jours je cherchais un code permettant de récupérer le chemin d'accés d'un fichier avec l'ouverture de l'exploreur windows, voici une solution qui fonctionne sans aucun control ActiveX, sans ajouter aucune bibliothèque particulière et avec ACCESS 97 :

Dans un module vous collez le code suivant :

Code :

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
'***************** Code Start **************
'Ce code fut originalement écrit par Ken Getz
'Il ne doit être ni altéré, ni distribué
'sauf comme partie intégrée à une application.
'Vous êtes libre d'utiliser ce code
'à la condition de laisser cette note, sans modification.
 
 
' Code courtesy of:
' Ken Getz and Paul Litwin
' Waite Group Press, 1996
 
Type tagOPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
strFilter As String
strCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
strFile As String
nMaxFile As Long
strFileTitle As String
nMaxFileTitle As Long
strInitialDir As String
strTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
strDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
 
Declare Function aht_apiGetOpenFileName Lib "comdlg32.dll" _
    Alias "GetOpenFileNameA" (OFN As tagOPENFILENAME) As Boolean
Declare Function aht_apiGetSaveFileName Lib "comdlg32.dll" _
    Alias "GetSaveFileNameA" (OFN As tagOPENFILENAME) As Boolean
Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long
 
Global Const ahtOFN_READONLY = &H1
Global Const ahtOFN_OVERWRITEPROMPT = &H2
Global Const ahtOFN_HIDEREADONLY = &H4
Global Const ahtOFN_NOCHANGEDIR = &H8
Global Const ahtOFN_SHOWHELP = &H10
' You won't use these.
'Global Const ahtOFN_ENABLEHOOK = &H20
'Global Const ahtOFN_ENABLETEMPLATE = &H40
'Global Const ahtOFN_ENABLETEMPLATEHANDLE = &H80
Global Const ahtOFN_NOVALIDATE = &H100
Global Const ahtOFN_ALLOWMULTISELECT = &H200
Global Const ahtOFN_EXTENSIONDIFFERENT = &H400
Global Const ahtOFN_PATHMUSTEXIST = &H800
Global Const ahtOFN_FILEMUSTEXIST = &H1000
Global Const ahtOFN_CREATEPROMPT = &H2000
Global Const ahtOFN_SHAREAWARE = &H4000
Global Const ahtOFN_NOREADONLYRETURN = &H8000
Global Const ahtOFN_NOTESTFILECREATE = &H10000
Global Const ahtOFN_NONETWORKBUTTON = &H20000
Global Const ahtOFN_NOLONGNAMES = &H40000
' New for Windows 95
Global Const ahtOFN_EXPLORER = &H80000
Global Const ahtOFN_NODEREFERENCELINKS = &H100000
Global Const ahtOFN_LONGNAMES = &H200000
 
Function TestIt()
    Dim strFilter As String
    Dim lngFlags As Long
    strFilter = ahtAddFilterItem(strFilter, "Access Files (*.mda, *.mdb)", _
                    "*.MDA;*.MDB")
    strFilter = ahtAddFilterItem(strFilter, "dBASE Files (*.dbf)", "*.DBF")
    strFilter = ahtAddFilterItem(strFilter, "Text Files (*.txt)", "*.TXT")
    strFilter = ahtAddFilterItem(strFilter, "All Files (*.*)", "*.*")
    MsgBox "You selected: " & ahtCommonFileOpenSave(InitialDir:="C:\", _
        Filter:=strFilter, FilterIndex:=3, Flags:=lngFlags, _
        DialogTitle:="Hello! Open Me!")
    ' On a fourni les options dans lngFlags,
    ' la fonction y place donc les options en sortie.
    Debug.Print Hex(lngFlags)
End Function
 
Function GetOpenFile(Optional varDirectory As Variant, _
    Optional varTitleForDialog As Variant) As Variant
' Un exemple pour obtenir une base de données Access.
Dim strFilter As String
Dim lngFlags As Long
Dim varFileName As Variant
' On désire que le fichier existe déjà,
' on ne veut pas changer de répertoire, en sortie
' et on n'affiche pas la mention "lecture seule"
' qui ne fait qu'embrouiller les gens
    lngFlags = ahtOFN_FILEMUSTEXIST Or _
                ahtOFN_HIDEREADONLY Or ahtOFN_NOCHANGEDIR
    If IsMissing(varDirectory) Then
        varDirectory = ""
    End If
    If IsMissing(varTitleForDialog) Then
        varTitleForDialog = ""
    End If
 
    ' Définir les filtres et utiliser "c"
    ' Copier cette ligne pour ajouter
    ' d'autres filtres.
    strFilter = ahtAddFilterItem(strFilter, _
                "Access (*.mdb)", "*.MDB;*.MDA")
    ' Et maintenant, obtenir le nom du fichier.
    varFileName = ahtCommonFileOpenSave( _
                    OpenFile:=True, _
                    InitialDir:=varDirectory, _
                    Filter:=strFilter, _
                    Flags:=lngFlags, _
                    DialogTitle:=varTitleForDialog)
 
    If Not IsNull(varFileName) Then
        varFileName = TrimNull(varFileName)
    End If
    GetOpenFile = varFileName
End Function
 
Function ahtCommonFileOpenSave( _
            Optional ByRef Flags As Variant, _
            Optional ByVal InitialDir As Variant, _
            Optional ByVal Filter As Variant, _
            Optional ByVal FilterIndex As Variant, _
            Optional ByVal DefaultExt As Variant, _
            Optional ByVal FileName As Variant, _
            Optional ByVal DialogTitle As Variant, _
            Optional ByVal hwnd As Variant, _
            Optional ByVal OpenFile As Variant) As Variant
 
'Point d'entrée pour le contrôle commun
' "file open/save dialog". Les paramètres sont
' listés par après, et sont tous optionels.
'
' *In:
' Flags: un ou plusieurs constantes de ahtOFN_* constants, unie par des OR
' InitialDir: le répertoire présenté à l'usager
' Filter: une série de filtres pour les fichiers; utiliser
' AddFilterItem. Voir l'exemple.
' FilterIndex: Index, base 1, fournissant le filtre par défaut
' (1, si non spécifié)
' DefaultExt: Extension à utiliser si l'usager n'en entre pas.
' Seulement pour les sauvegardes.
' FileName: Valeur par défaut pour le nom du fichier.
' DialogTitle: Titre dans la barre titre du formulaire.
' hWnd: handle Win32 du parent de ce dialogue
' OpenFile: Booléen(True=Open File/False=Save As)
' *Out:
' Return Value: Soit Null, soit le nom choisi
Dim OFN As tagOPENFILENAME
Dim strFileName As String
Dim strFileTitle As String
Dim fResult As Boolean
    ' Fournir le caption (étiquette) du titre.
    If IsMissing(InitialDir) Then InitialDir = CurDir
    If IsMissing(Filter) Then Filter = ""
    If IsMissing(FilterIndex) Then FilterIndex = 1
    If IsMissing(Flags) Then Flags = 0&
    If IsMissing(DefaultExt) Then DefaultExt = ""
    If IsMissing(FileName) Then FileName = ""
    If IsMissing(DialogTitle) Then DialogTitle = ""
    If IsMissing(hwnd) Then hwnd = Application.hWndAccessApp
    If IsMissing(OpenFile) Then OpenFile = True
    ' Créer une chaîne pour recevoir le résultat.
    strFileName = Left(FileName & String(256, 0), 256)
    strFileTitle = String(256, 0)
    ' Initialiser la structure avant d'appeler la fonction
    With OFN
        .lStructSize = Len(OFN)
        .hwndOwner = hwnd
        .strFilter = Filter
        .nFilterIndex = FilterIndex
        .strFile = strFileName
        .nMaxFile = Len(strFileName)
        .strFileTitle = strFileTitle
        .nMaxFileTitle = Len(strFileTitle)
        .strTitle = DialogTitle
        .Flags = Flags
        .strDefExt = DefaultExt
        .strInitialDir = InitialDir
        ' On ne pense pas que quelqu'un veut vraiment utiliser
        ' ces options.
        .hInstance = 0
        .strCustomFilter = ""
        .nMaxCustFilter = 0
        .lpfnHook = 0
        ' Pour NT 4.0
        .strCustomFilter = String(255, 0)
        .nMaxCustFilter = 255
    End With
 
    ' Transmettre la structure de données au
    ' Windows API qui, à son tour, affichera
    ' le formulaire "Open/Save As".
    If OpenFile Then
        fResult = aht_apiGetOpenFileName(OFN)
    Else
        fResult = aht_apiGetSaveFileName(OFN)
    End If
 
    ' La fonction retourne le nom dans le membre strFileTitle
    ' de la structure. Il nous faut écrire du code pour
    ' retrouver ce qui nous intéresse.
    If fResult Then
        ' Vous pouvez vérifier les membres de la structure
        ' pour obtenir plus d'information sur le fichier choisi.
        ' Dans cet exemple, si vous avez fourni un argument pour
        ' les options, on vous retourne les indicateurs (flags) dans
        ' cette même variable.
        If Not IsMissing(Flags) Then Flags = OFN.Flags
        ahtCommonFileOpenSave = TrimNull(OFN.strFile)
    Else
        ahtCommonFileOpenSave = vbNullString
    End If
End Function
 
Function ahtAddFilterItem(strFilter As String, _
    strDescription As String, Optional varItem As Variant) As String
' Ajoute un nouvel ensemble de données formant un nouveau filtre.
' Par exemple, aux filtres existants, ajouter une description,
' (tel "Databases"), un caractère null, la grille passe-partout
' (tel "*.mdb;*.mda") et un dernier caractère null.
 
    If IsMissing(varItem) Then varItem = "*.*"
    ahtAddFilterItem = strFilter & _
                strDescription & vbNullChar & _
                varItem & vbNullChar
End Function
 
Private Function TrimNull(ByVal strItem As String) As String
Dim intPos As Integer
    intPos = InStr(strItem, vbNullChar)
    If intPos > 0 Then
        TrimNull = Left(strItem, intPos - 1)
    Else
        TrimNull = strItem
    End If
End Function
'************** Code End *****************

Puis dans le formulaire où vous avez besoin de l'explorateur vous lancez la fonction par le code suivant (içi dans un bouton parcourir, je demande à l'utilisateur de choisir une photo) :

Code :

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
Me.imgPhoto.Visible = True
Me.dispo.Visible = False
Dim photoactuelle As String
If Len(Me.photo) > 0 Then
photoactuelle = Me.photo
Else
Me.photo = "H:\Photos gmao\aucune.jpg"
photoactuelle = Me.photo
 
End If
On Error GoTo Err_Commande645_Click
Dim strFilter As String
Dim strInputFileName As String
Dim strLink As String
 'récupération du chemin physique de la photo
'  par la boite de dialogue
 
strFilter = ahtAddFilterItem(strFilter, "Photos (*.jpg)", "*.jpg")
strInputFileName = ahtCommonFileOpenSave(Filter:=strFilter, OpenFile:=True, DialogTitle:="Sélection d'une photo :", Flags:=ahtOFN_HIDEREADONLY)
strLink = strInputFileName
 
 
' si la boite renvoie une adresse non nulle
If Len(strLink) > 0 Then
    ' tentative d'affichage de la photo
 
    Me.imgPhoto.Picture = strLink
    Me.photo = strLink
End If

Ce code fonctionne parfaitement et je remercie les auteurs qui l'ont mis à disposition de tous...

En espèrant que cela vous aidera si avez le même problème que moi.

Amicalement

ps : je sais que sur le site un tutoriel propose une solution similaire, mais cette solution n'a pas fonctionné dans ma base de donnée sous ACCESS97

[cafeine]

Hello Joël,

Désole mais, c'est une blague ? plusieurs jours de recherche ?

http://access.developpez.com/faq/?re...ouvrir+fichier

Du coup, c'est inutile de récupérer le code de l'ilustrissime Ken Getz, non ?

[massol joel]

J'ai consulté bien entendu en premier la FAQ et j'ai trouvé effectivement cette solution, mais elle ne fonctionne pas dans ma base de donnée sous ACCESS 97 malgré plusieurs tentative ACCESS affiche toujours un message d'erreur "variable non définie" etc... et je suis trop mauvais pour arriver à débugger ce code...

Le but n'était pas de dénigrer les excellents tutoriels de ce site mais juste de donner une solution alternative aux personnes qui auraient rencontrées le même soucis que moi...

Je sais qu'utiliser ACCESS 97 en 2006 est très dépassé et qu' ACCESS 2007 intègre ce type de fonction maintenant mais la base de donnée que j'utilise a été développé sous ACCESS 97 et pour des raisons techniques il ne nous a pas été encore possible de migrer (base en réseau sur des pc avec licence ACCESS 97)...

Je profite de cette réponse pour vous remercier pour le totalitée de vos contributions et de celles de tous les programmeurs du site, grâce à vous tous j'ai beaucoup progressé et je vous dit mille merci.

Amicalement

Joel MASSOL