Comment obtenir un chemin d'acces absolu

**SSJconsult** · 31/05/2010, 13h37

Bonjour,

J'ai un client chez qui j'installe une application avec une base de donnees frontale et plusieurs dorsales.
Ces bases de donnees sont sur des disques reseau.
Certains utilisateurs utilisent des chemins d'acces differents des autres (en realite, chaque utilisateur peut "mapper" les disques reseau un peu comme il le desire).
Je dois pouvoir verifier l'endroit ou se trouve la base frontale activee par l'utilisateur afin de m'assurer que les bases dorsales sont correctes (j'ai plusieurs versions : Developpement, Test, Production).

La fonction

Code :

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

CurrentDb.Name

me permet d'obtenir le "chemin suivi" par l'utilisateur mais ne me donne pas l'adresse reelle (absolue) de la base frontale.
Est-il possible de retrouver cette adresse absolue d'une maniere ou d'une autre ?

D'avance merci

**Tofalu** · 31/05/2010, 13h54

Salut,

Avec la référence Scripting, on peut avoir ceci :

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
Sub test()
Dim OFso As Scripting.FileSystemObject
Dim Ofl As Scripting.File
Dim strChemin As String
Set OFso = New Scripting.FileSystemObject
 
Set Ofl = OFso.GetFile(CurrentDb.Name)
 
With Ofl
  strChemin = Replace(.Path, .Drive.DriveLetter & ":", .Drive.ShareName)
End With
MsgBox strChemin
End Sub

Est ce que ça peut correspondre à ton besoin ?

**Tofalu** · 31/05/2010, 14h03

Plus complet pour les mappages locaux :

Un module de classe nommé CprgNetShareGetInfo contenant

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
Option Compare Database
 
'This example was submitted by Lee Carpenter
'
'It needs a class module and a form, with a label (m_lblStatus) on the form
 
'In the class module (CprgNetShareGetInfo)
 
Option Explicit
 
'local variable(s) to hold property value(s)
Private mvarstrServer As Variant 'local copy
Private mvarstrNetName As Variant 'local copy
Private mvarnType As Long 'local copy
Private mvarstrRemark As Variant 'local copy
Private mvarnCurrent_uses As Long 'local copy
Private mvarnMax_uses As Long 'local copy
Private mvarstrPath As Variant 'local copy
Private mvarnLastError As Long 'local copy
Private mvarstrLastError As Variant 'local copy
Private mvarNET_API_STATUS As Long 'local copy
 
'local variable(s) to hold internal value(s)
 
' Private constants, types and  declares to call
'
 
Const STYPE_DISKTREE            As Long = 0
Const STYPE_PRINTQ              As Long = 1
Const STYPE_DEVICE              As Long = 2
Const STYPE_IPC                 As Long = 3
Const STYPE_SPECIAL             As Long = &H80000000&
 
Const ERROR_SUCCESS             As Long = 0&
Const NERR_Success              As Long = 0&
Const ERROR_ACCESS_DENIED       As Long = 5&
Const ERROR_INVALID_LEVEL       As Long = 124&
Const ERROR_INVALID_PARAMETER   As Long = 87&
Const ERROR_MORE_DATA           As Long = 234&
Const ERROR_NOT_ENOUGH_MEMORY   As Long = 8&
Const ERROR_INVALID_NAME        As Long = 123&
 
Const NERR_BASE                 As Long = 2100&
Const NERR_NetNameNotFound      As Long = (NERR_BASE + 210)
 
 
Private Type SHARE_INFO_502
  shi502_netname      As Long   ' LPWSTR    shi502_netname;
  shi502_type         As Long   ' DWORD     shi502_type;
  shi502_remark       As Long   ' LPWSTR    shi502_remark;
  shi502_permissions  As Long   ' DWORD     shi502_permissions;
  shi502_max_uses     As Long   ' DWORD     shi502_max_uses;
  shi502_current_uses As Long   ' DWORD     shi502_current_uses;
  shi502_path         As Long   ' LPWSTR    shi502_path;
  shi502_passwd       As Long   ' LPWSTR    shi502_passwd;
  shi502_reserved     As Long   ' DWORD     shi502_reserved;
  shi502_security_descriptor As Long ' PSECURITY_DESCRIPTOR  shi502_security_descriptor;
End Type
 
'NET_API_STATUS NET_API_FUNCTION
'NetShareGetInfo (
'    IN  LPTSTR  servername,
'    IN  LPTSTR  netname,
'    IN  DWORD   level,
'    OUT LPBYTE * bufptr
'    );
Private Declare Function NetShareGetInfo Lib "Netapi32.dll" _
  ( _
    strServerName As Any, _
    strNetName As Any, _
    ByVal nLevel As Long, _
    pBuffer As Long _
  ) As Long
 
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
( _
  Destination As Any, _
  ByVal Source As Any, _
  ByVal Length As Long _
)
 
Private Declare Function NetApiBufferFree Lib "Netapi32.dll" _
( _
  ByVal lpBuffer As Long _
) As Long
 
Private Declare Sub lstrcpyW Lib "kernel32" _
( _
  dest As Any, _
  ByVal src As Any _
)
 
Private Declare Function lstrlenW Lib "kernel32" _
( _
  ByVal lpszString As Any _
) As Long
 
Public Property Get NET_API_STATUS() As Long
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.NET_API_STATUS
    NET_API_STATUS = mvarNET_API_STATUS
End Property
 
Public Property Get strLastError() As Variant
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.strLastError
    If IsObject(mvarstrLastError) Then
        Set strLastError = mvarstrLastError
    Else
        strLastError = mvarstrLastError
    End If
End Property
 
Public Property Get nLastError() As Long
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.nLastError
    nLastError = mvarnLastError
End Property
 
Public Property Get strPath() As Variant
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.strPath
    If IsObject(mvarstrPath) Then
        Set strPath = mvarstrPath
    Else
        strPath = mvarstrPath
    End If
End Property
 
Public Property Get nMax_uses() As Long
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.nMax_uses
  nMax_uses = mvarnMax_uses
End Property
 
Public Property Get nCurrent_uses() As Long
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.nCurrent_uses
  nCurrent_uses = mvarnCurrent_uses
End Property
 
Public Property Get strRemark() As Variant
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.strRemark
    If IsObject(mvarstrRemark) Then
        Set strRemark = mvarstrRemark
    Else
        strRemark = mvarstrRemark
    End If
End Property
 
Public Property Get nType() As Long
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.nType
  nType = mvarnType
End Property
 
Public Property Get strType() As Variant
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.strType
  Select Case mvarnType
    Case STYPE_DISKTREE
      strType = "Disk Drive"
    Case STYPE_PRINTQ
      strType = "Print Queue"
    Case STYPE_DEVICE
      strType = "Communication device"
    Case STYPE_IPC
      strType = "Interprocess communication (IPC)"
    Case STYPE_SPECIAL
      strType = "Special share"
    Case Else
      strType = "Error: Unknown"
  End Select
End Property
 
Public Property Get strNetName() As Variant
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.strNetName
    If IsObject(mvarstrNetName) Then
        Set strNetName = mvarstrNetName
    Else
        strNetName = mvarstrNetName
    End If
End Property
 
Public Property Get strServer() As Variant
'used when retrieving value of a property, on the right side of an assignment.
'Syntax: Debug.Print X.strServer
    If IsObject(mvarstrServer) Then
        Set strServer = mvarstrServer
    Else
        strServer = mvarstrServer
    End If
End Property
Public Sub Initialize()
 
  ' Reset the everything
  '
  mvarnLastError = 0
  mvarstrLastError = ""
  mvarstrServer = ""
  mvarstrNetName = ""
  mvarnType = 0
  mvarstrRemark = ""
  mvarnCurrent_uses = 0
  mvarnMax_uses = 0
  mvarstrPath = ""
 
End Sub
Public Sub GetInfo(strShareName As Variant)
  Dim pNetName()  As Byte
  Dim pServer()   As Byte
  Dim ptmpBuffer  As Long
  Dim tmpBuffer   As SHARE_INFO_502
  Dim strNetName  As String
  Dim x As Integer
 
  Call Initialize
 
  ' copy the network share name without leading spaces.
  '
  strNetName = LTrim(strShareName)
 
  ' check for leading server in the name.
  '
  If Left(strNetName, 2) = "\\" Then
 
    ' find the end of the server in the name
    '
    x = InStr(3, strNetName, "\")
 
    ' only a server in the name
    '
    If x = 0 Then
      mvarnLastError = ERROR_INVALID_NAME
      mvarstrLastError = "Need share name not server name."
      Exit Sub
    Else
      mvarstrServer = Left(strNetName, x - 1)
      strNetName = Mid(strNetName, x + 1)
    End If
  End If
 
  ' strip off any remaining leading \
  '
  If Left(strNetName, 1) = "\" Then
    strNetName = Mid(strNetName, 2)
  End If
 
  ' Find the end of the share name.
  '
  x = InStr(strNetName, "\")
  If x > 0 Then
    strNetName = Left(strNetName, x - 1)
  End If
 
  ' Check for drive letter
  '
  x = InStr(strNetName, ":")
  If x > 0 Then
    mvarnLastError = ERROR_INVALID_NAME
    mvarstrLastError = "Drive letter specified for share name."
    Exit Sub
  End If
 
  ' Convert the string to a UNI string, happens automatically.
  '
  pNetName = strNetName & vbNullChar
 
  If Len(mvarstrServer) > 0 Then
 
    ' format the server name
    '
    If Left(mvarstrServer, 2) = "\\" Then
      pServer = mvarstrServer & vbNullChar
    Else
      pServer = "\\" & mvarstrServer & vbNullChar
    End If
    ' Get the network infomation on the share.
    '
    mvarNET_API_STATUS = NetShareGetInfo _
    ( _
      pServer(0), _
      pNetName(0), _
      502, _
      ptmpBuffer _
    )
  Else
    ' Get the network infomation on the share.
    ' NOTE: the first parameter is the server name, by sending a
    '       null you are only looking at the current machine.
    '
    mvarNET_API_STATUS = NetShareGetInfo _
    ( _
      vbEmpty, _
      pNetName(0), _
      502, _
      ptmpBuffer _
    )
  End If
 
  ' Check for errors.
  '
  If mvarNET_API_STATUS <> NERR_Success Then
    Select Case mvarNET_API_STATUS
      Case ERROR_ACCESS_DENIED
        mvarstrLastError = "NetShareGetInfo: ERROR_ACCESS_DENIED"
      Case ERROR_INVALID_LEVEL
        mvarstrLastError = "NetShareGetInfo: ERROR_INVALID_LEVEL"
      Case ERROR_INVALID_PARAMETER
        mvarstrLastError = "NetShareGetInfo: ERROR_INVALID_PARAMETER"
      Case ERROR_MORE_DATA
        mvarstrLastError = "NetShareGetInfo: ERROR_MORE_DATA"
      Case ERROR_NOT_ENOUGH_MEMORY
        mvarstrLastError = "NetShareGetInfo: ERROR_NOT_ENOUGH_MEMORY"
      Case ERROR_INVALID_NAME
        mvarstrLastError = "NetShareGetInfo: ERROR_INVALID_NAME"
      Case NERR_NetNameNotFound
        mvarstrLastError = "NetShareGetInfo: NERR_NetNameNotFound"
      Case Else
        mvarstrLastError = "NetShareGetInfo: Unknown " & mvarNET_API_STATUS
    End Select
    mvarnLastError = mvarNET_API_STATUS
    Exit Sub
  End If
 
  ' Copy the return buffer to a type definition for processing.
  '
  Call CopyMemory(tmpBuffer, ptmpBuffer, LenB(tmpBuffer))
 
  ' save the return buffer information.
  '
  mvarstrNetName = UtoA(tmpBuffer.shi502_netname)
  mvarnType = tmpBuffer.shi502_type
  mvarstrRemark = UtoA(tmpBuffer.shi502_remark)
  mvarnCurrent_uses = tmpBuffer.shi502_current_uses
  mvarnMax_uses = tmpBuffer.shi502_max_uses
  mvarstrPath = UtoA(tmpBuffer.shi502_path)
 
  ' Free the buffer.
  '
  mvarNET_API_STATUS = NetApiBufferFree(ptmpBuffer)
 
  ' Check for errors.
  '
  If mvarNET_API_STATUS <> ERROR_SUCCESS Then
    mvarnLastError = mvarNET_API_STATUS
    mvarstrLastError = "NetApiBufferFree: Unknown"
    Exit Sub
  End If
End Sub
Private Function UtoA(pUNIstring As Long) As String
  Dim wrkByte()   As Byte
  Dim wrkStr      As String
 
  ' Get space for string each character is two bytes
  ' and a null terminator.
  '
  ReDim wrkByte(lstrlenW(pUNIstring) * 2 + 2)
 
  ' Copy the string to a byte array
  '
  Call lstrcpyW(wrkByte(0), pUNIstring)
 
  ' Covert the string from a UNI string to a ASCII string.
  ' this happens automatically when a byte array is copied
  ' to a string.
  '
  wrkStr = wrkByte
 
  ' return everything upto the the null terminator.
  '
  UtoA = Left(wrkStr, InStr(wrkStr, Chr(0)) - 1)
End Function

Et la fonction :

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
Function CheminDeMabase()
Dim OFso As Scripting.FileSystemObject
Dim Ofl As Scripting.File
Dim x As New CprgNetShareGetInfo
Dim strChemin As String
Dim strCheminPartage As String
Set OFso = New Scripting.FileSystemObject
 
Set Ofl = OFso.GetFile(CurrentDb.Name)
 
With Ofl
  strCheminPartage = .Drive.ShareName
  x.GetInfo strCheminPartage
  CheminDeMabase = Replace(.Path, .Drive.DriveLetter & ":", x.strPath)
End With
End Function

**Tofalu** · 31/05/2010, 14h08

Ou pour de l'unc : http://access.developpez.com/sources...=reseau#GetUNC

**SSJconsult** · 31/05/2010, 14h57

Merci beaucoup

Que de solutions possibles... a priori, je pense que je vais favoriser la troisieme car elle me semble mieux convenir a la situation du client.

Je vais tester des que possible et donnerai des nouvelles (bonnes, j'espere)

**SSJconsult** · 31/05/2010, 16h10

Je confirme que la solution 3 convient parfaitement.

Merci

Comment obtenir un chemin d'acces absolu

VBA Access

Discussions similaires

Partager

Partager