compatibilité 32 bits / 64 bits

**Fleur59** · 03/07/2019, 16h36

Bonjour à tous,
plusieurs pc utilisent la même base, différentes versions de Windows, MSOffice et- ce serait trop facile - certains en 64 bits....
voici le petit bout de code modifié pour essayer de coller à toutes les versions, mais sur 1 pc en 64 bits ac-2010, on arrive bien à ouvrir un invite de chemin pour afficher le contenu d'un fichier, mais lorsqu'on valide (dernière étape) la base bug, se ferme et crée une auto sauvegarde (avec d'autres PC ac-2010 32bits, aucun souci)
J'ai besoin de votre aide pour vérifier que le code ci-dessous est fonctionnel pour tous les utilisateurs et/ou si c'est ce pc 64bits qui aurait un souci avec son MSOffice installé.
Merci par avance de l'aide que vous m'apporterez.
Fleur59

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
Option Explicit 
 
 
#If Win64 Or VBA7 Then
 
Declare PtrSafe Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As LongPtr
 
Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As LongPtr, ByVal pszPath As String) As Boolean
 
Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" _
 
  Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
 
Public 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    ' Downlevel when using previous version of VBA7
 
Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize 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 GetFolder(Optional Msg) As String
 
Dim bInfo As BROWSEINFO
 
Dim Path As String
 
Dim r As Long, X As Long, pos As Integer
 
 
 
    'Définit le Bureau comme dossier racine
 
    bInfo.pidlRoot = 0&
 
 
 
    'Invite de la boite de dialogue
 
    If IsMissing(Msg) Then
 
        bInfo.lpszTitle = "Selectionnez un dossier."
 
    Else
 
        bInfo.lpszTitle = Msg
 
    End If
 
 
 
    'Type de renvoi : dossier
 
    bInfo.ulFlags = &H1
 
    'Type de renvoi : fichier
 
    'bInfo.ulFlags = &H4000
 
 
 
 
 
    'Affiche la boite de dialogue
 
    X = SHBrowseForFolder(bInfo)
 
 
 
    'Traite le résultat
 
    Path = Space$(512)
 
    r = SHGetPathFromIDList(ByVal X, ByVal Path)
 
    If r Then
 
        pos = InStr(Path, Chr$(0))
 
        GetFolder = Left(Path, pos - 1)
 
    Else
 
        GetFolder = ""
 
    End If
 
End Function
 
 
 
 
 
Function GetDirectory(Optional Msg) As String
 
Dim bInfo As BROWSEINFO
 
Dim Path As String
 
Dim r As Long, X As Long, pos As Integer
 
 
 
    'Définit le Bureau comme dossier racine
 
    bInfo.pidlRoot = 0&
 
 
 
    'Invite de la boite de dialogue
 
    If IsMissing(Msg) Then
 
        bInfo.lpszTitle = "Selectionnez un dossier."
 
    Else
 
        bInfo.lpszTitle = Msg
 
    End If
 
 
 
    'Type de renvoi : dossier
 
'    bInfo.ulFlags = &H1
 
    'Type de renvoi : fichier
 
    bInfo.ulFlags = &H4000
 
 
 
 
 
    'Affiche la boite de dialogue
 
    X = SHBrowseForFolder(bInfo)
 
 
 
    'Traite le résultat
 
    Path = Space$(512)
 
    r = SHGetPathFromIDList(ByVal X, ByVal Path)
 
    If r Then
 
        pos = InStr(Path, Chr$(0))
 
        GetDirectory = Left(Path, pos - 1)
 
    Else
 
        GetDirectory = ""
 
    End If
 
End Function
 
 
 
Function WinUser() As String
 
    Dim strLogin As String
 
    Dim lSize As Long
 
 
 
 
 
    lSize = 255
 
    strLogin = Space$(lSize)
 
 
 
 
 
    Call GetUserName(strLogin, lSize)
 
    If lSize - 1 > 0 Then
 
        WinUser = Left$(strLogin, lSize - 1)
 
    Else
 
        WinUser = "Aucun"
 
    End If
 
End Function

**marot_r** · 04/07/2019, 14h33

Bonjour.

À quoi servent SHGetPathFromIDList et SHBrowseForFolder ?

Il existe peut-être des fonctions de Access qui font la même chose.

Et je pense que tu peux remplacer

GetUserName par Environ$("UserName") qui est un fonction native de Access.
Elle va te donner l'identifiant de connexion utilisé par l'utilisateur.

A+

**Fleur59** · 05/07/2019, 15h03

Bonjour Marot_R
Je n'ai pas épluché, mais vu rapidement que SHBrowseForFolder permet d'extraire sur une liste tous les fichiers d'un dossier et
SHGetPathFromIDList permet de choisir 1 des ficher de cette liste pour être envoyé par mail si sélectionné.
Merci de ton esprit critique, il m'a déjà aidé par le passé
Fleur59

**Arkham46** · 05/07/2019, 22h41

Bonjour,

Je confirme, ça plante en 64bits.

SHBrowseForFolder devrait retourner un LongPtr en 64bits.

Du coup les variables X doivent être définies en LongPtr pour 64bits :

Code :

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

1
2
3
4
5
6
7
 
Dim r As Long, pos As Integer
#If Win64 Or VBA7 Then
X As LongPtr
#Else
X As Long
#End If

Pour plus de détail sur la cohabitation 32bits/64bits en VBA :
https://arkham46.developpez.com/arti...ice/vba64bits/

**Fleur59** · 06/07/2019, 08h14

Bonjour Arkham46
Merci, j'essaie dès cette semaine et vous tiens au courant
Fleur59

**Fleur59** · 15/07/2019, 10h44

Envoyé par Arkham46

Bonjour,

Je confirme, ça plante en 64bits.

SHBrowseForFolder devrait retourner un LongPtr en 64bits.

Du coup les variables X doivent être définies en LongPtr pour 64bits :

Code :

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

1
2
3
4
5
6
7
 
Dim r As Long, pos As Integer
#If Win64 Or VBA7 Then
X As LongPtr
#Else
X As Long
#End If

Pour plus de détail sur la cohabitation 32bits/64bits en VBA :
https://arkham46.developpez.com/arti...ice/vba64bits/

Bonjour à Tous
Petite modification mise en place sans succès!
Toujours fermeture intempestive de la base avec génération d'une copie de sauvegarde
Je suis toujours preneuse de vos idées
Merci d'avance pour votre aide
Fleur59

**Arkham46** · 15/07/2019, 22h22

Envoyé par Fleur59

Petite modification mise en place sans succès

Bonjoir,

Collez le code dernière version.
Sinon on doit deviner quelle petite modification a été mise en place et c'est un peu difficile.
Chez moi votre code crashe, et la modification que j'ai donnée fonctionne.

**Fleur59** · 18/07/2019, 12h35

Bonjour à tous
désolée, cela me semblait logique
en rouge ce qui a été modifié

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
Option Compare Database

Option Explicit
Public Tableur As Excel.Application
Public Classeur As Excel.Workbook
Public Feuille As Excel.Worksheet
#If Win64 Or VBA7 Then
Declare PtrSafe Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As LongPtr

Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As LongPtr, ByVal pszPath As String) As Boolean

Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" _
  Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Public 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    ' Downlevel when using previous version of VBA7
Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize 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 GetFolder(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim Path As String
 'Dim r As Long, X As Long, pos As Integer
Dim r As Long, pos As Integer
#If Win64 Or VBA7 Then
Dim X As LongPtr
#Else
Dim X As Long
#End If


    'Définit le Bureau comme dossier racine
    bInfo.pidlRoot = 0&

    'Invite de la boite de dialogue
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "Selectionnez un dossier."
    Else
        bInfo.lpszTitle = Msg
    End If

    'Type de renvoi : dossier
    bInfo.ulFlags = &H1
    'Type de renvoi : fichier
    'bInfo.ulFlags = &H4000


    'Affiche la boite de dialogue
    X = SHBrowseForFolder(bInfo)

    'Traite le résultat
    Path = Space$(512)
    r = SHGetPathFromIDList(ByVal X, ByVal Path)
    If r Then
        pos = InStr(Path, Chr$(0))
        GetFolder = Left(Path, pos - 1)
    Else
        GetFolder = ""
    End If
End Function


Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim Path As String
'Dim r As Long, X As Long, pos As Integer
  Dim r As Long, pos As Integer
#If Win64 Or VBA7 Then
Dim X As LongPtr
#Else
Dim X As Long
#End If


    'Définit le Bureau comme dossier racine
    bInfo.pidlRoot = 0&

    'Invite de la boite de dialogue
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "Selectionnez un dossier."
    Else
        bInfo.lpszTitle = Msg
    End If

    'Type de renvoi : dossier
'    bInfo.ulFlags = &H1
    'Type de renvoi : fichier
    bInfo.ulFlags = &H4000


    'Affiche la boite de dialogue
    X = SHBrowseForFolder(bInfo)

    'Traite le résultat
    Path = Space$(512)
    r = SHGetPathFromIDList(ByVal X, ByVal Path)
    If r Then
        pos = InStr(Path, Chr$(0))
        GetDirectory = Left(Path, pos - 1)
    Else
        GetDirectory = ""
    End If
End Function

Merci pour votre aide prochaine
Fleur59

**Fleur59** · 18/07/2019, 12h59

Bonjour
Je sais que ce code-ci fonctionne pour l'avoir testé sur une autre base, mais je n'arrive pas le retranscrire pour l'appliquer à la base actuelle (voilà ce qui se passe lorsqu'une base est construite avec des bouts de code piqués par-ci par-là par une autre personne qui n'est plus dans l'entreprise et que l'on est autodidacte non confirmé!!!)

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
Option Explicit
 
'Déclaration de l'API
#If VBA7 Then
Private Declare PtrSafe Sub PathStripPath Lib "shlwapi.dll" _
   Alias "PathStripPathA" (ByVal pszPath As String)
Private Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" _
   Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
#Else
Private Declare Sub PathStripPath Lib "shlwapi.dll" _
   Alias "PathStripPathA" (ByVal pszPath As String)
Private Declare Function GetOpenFileName Lib "comdlg32.dll" _
   Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
#End If
Private Type OPENFILENAME
        lStructSize As Long
#If VBA7 Then
        hwndOwner As LongPtr
        hInstance As LongPtr
#Else
        hwndOwner As Long
        hInstance As Long
#End If
        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
#If VBA7 Then
        lCustData As LongPtr
        lpfnHook As LongPtr
#Else
        lCustData As Long
        lpfnHook As Long
#End If
        lpTemplateName As String
'#if (_WIN32_WINNT >= 0x0500)
        'pvReserved As LongPtr
        'dwReserved As Long
        'FlagsEx As Long
'#endif // (_WIN32_WINNT >= 0x0500)
End Type
 
 
 'Constantes
Private Const OFN_HIDEREADONLY = &H4
 
#If VBA7 Then
Public Function OuvrirUnFichier(Handle As LongPtr, _
                                Titre As String, _
                                TypeRetour As Byte, _
                                Optional TitreFiltre As String, _
                                Optional TypeFichier As String, _
                                Optional RepParDefaut As String) As String
#Else
Public Function OuvrirUnFichier(Handle As Long, _
                                Titre As String, _
                                TypeRetour As Byte, _
                                Optional TitreFiltre As String, _
                                Optional TypeFichier As String, _
                                Optional RepParDefaut As String) As String
#End If
 
Dim StructFile As OPENFILENAME
Dim sFiltre As String
 
 'Construction du filtre en fonction des arguments spécifiés
If Len(TitreFiltre) > 0 And Len(TypeFichier) > 0 Then
  sFiltre = TitreFiltre & " (" & TypeFichier & ")" & Chr$(0) & "*." & TypeFichier & Chr$(0)
End If
sFiltre = sFiltre & "Tous (*.*)" & Chr$(0) & "*.*" & Chr$(0)
 
 'Configuration de la boîte de dialogue
  With StructFile
    .lStructSize = LenB(StructFile) 'Initialisation de la grosseur de la structure
    .hwndOwner = Handle 'Identification du handle de la fenêtre
    .lpstrFilter = sFiltre 'Application du filtre
    .lpstrFile = String$(254, vbNullChar) 'Initialisation du fichier '0' x 254
    .nMaxFile = 254 'Taille maximale du fichier
    .lpstrFileTitle = String$(254, vbNullChar) 'Initialisation du nom du fichier '0' x 254
    .nMaxFileTitle = 254  'Taille maximale du nom du fichier
    .lpstrTitle = Titre 'Titre de la boîte de dialogue
    .flags = OFN_HIDEREADONLY  'Option de la boite de dialogue
    If ((IsNull(RepParDefaut)) Or (RepParDefaut = "")) Then
        RepParDefaut = CurrentDb.Name
        PathStripPath (RepParDefaut)
        .lpstrInitialDir = Left(CurrentDb.Name, Len(CurrentDb.Name) - Len(Mid$(RepParDefaut, 1, _
InStr(1, RepParDefaut, vbNullChar) - 1)))
        Else: .lpstrInitialDir = RepParDefaut
    End If
  End With
 
If (GetOpenFileName(StructFile)) Then 'Si un fichier est sélectionné
    Select Case TypeRetour
      Case 1: OuvrirUnFichier = Trim$(Left(StructFile.lpstrFile, InStr(1, StructFile.lpstrFile, vbNullChar) - 1))
      Case 2: OuvrirUnFichier = Trim$(Left(StructFile.lpstrFileTitle, InStr(1, StructFile.lpstrFileTitle, vbNullChar) - 1))
    End Select
  End If
 
End Function

Un petit coup de pouce serait une ENORME aide pour moi

Merci
Fleur59

**Arkham46** · 19/07/2019, 09h15

Bonjour,

Envoyé par Arkham46

SHBrowseForFolder devrait retourner un LongPtr en 64bits.

Il faut modifier le retour de la fonction 64 bits

**Fleur59** · 19/07/2019, 10h52

Alléluia!!
Bonjour
Merci Arkham46
Il manquait bien le Ptr dans

Code :

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

1
2
Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" _
  Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As LongPtr

Tout marche impec
Merci de votre aide
Fleur59

**Arkham46** · 19/07/2019, 23h41

Super.

Mais je me suis contenté de corriger le code pour 64bits.
Les remarques de marot_r sont effectivement pertinentes.

compatibilité 32 bits / 64 bits [Toutes versions]

Access

Discussions similaires

Partager

Partager