Path et commondialog

Un petit module que j'ai récupéré sur internet permet de calculer le nom UNC d'un fichier

Ce fichier doit être sur un repertoire partagé, sinon çà ne marche pas.

Ajoute ce module à votre projet, puis dans votre programme vous pouvez utiliser
Code:
MonUncFileName=GetUncName(FileName)
Le code est assez complexe, procède par enumeration des ressources réseau du PC.
Je l'ai légérement retouché pour qu'il retourne le nom du fichier de départ si aucun chemin reseau n'est trouvé.
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
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
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
' *********************************************************************
'  Copyright ©1999 Karl E. Peterson, All Rights Reserved
'  http://www.mvps.org/vb
' *********************************************************************
'  You are free to use this code within your own applications, but you
'  are expressly forbidden from selling or otherwise distributing this
'  source code without prior written consent.
' *********************************************************************
Option Explicit
 
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
 
Private Type OSVERSIONINFO
   dwOSVersionInfoSize As Long
   dwMajorVersion As Long
   dwMinorVersion As Long
   dwBuildNumber As Long
   dwPlatformId As Long
   szCSDVersion As String * 128
End Type
 
Private Const VER_PLATFORM_WIN32s = 0
Private Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Const VER_PLATFORM_WIN32_NT = 2
 
Private Declare Function WNetGetUniversalName Lib "mpr" Alias "WNetGetUniversalNameA" (ByVal lpLocalPath As String, ByVal dwInfoLevel As Long, lpBuffer As Any, lpBufferSize As Long) As Long
Private Declare Function WNetGetConnection Lib "mpr" Alias "WNetGetConnectionA" (ByVal lpLocalName As String, lpRemoteName As Any, lpnLength As Long) As Long
Private Declare Function NetShareEnum Lib "netapi32" (ByVal lpServerName As Long, ByVal dwLevel As Long, lpBuffer As Any, ByVal dwPrefMaxLen As Long, EntriesRead As Long, TotalEntries As Long, hResume As Long) As Long
Private Declare Function NetShareEnum95 Lib "svrapi" Alias "NetShareEnum" (ByVal lpServerName As String, ByVal dwLevel As Long, lpBuffer As Any, ByVal cbBuffer As Long, EntriesRead As Long, TotalEntries As Long) As Long
Private Declare Function NetApiBufferFree Lib "netapi32" (ByVal lpBuffer As Long) As Long
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
 
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pTo As Any, uFrom As Any, ByVal lSize As Long)
Private Declare Function lstrlenA Lib "kernel32" (ByVal PointerToString As Long) As Long
Private Declare Function lstrlenW Lib "kernel32" (ByVal PointerToString As Long) As Long
 
Private Const UNIVERSAL_NAME_INFO_LEVEL = &H1
Private Const REMOTE_NAME_INFO_LEVEL = &H2
 
Private Type UNIVERSAL_NAME_INFO
   lpUniversalName As Long
End Type
 
Private Type REMOTE_NAME_INFO
   lpUniversalName As Long
   lpConnectionName As Long
   lpRemainingPath As Long
End Type
 
Private Const MAX_PREFERRED_LENGTH As Long = -1
Private Const MAX_PATH = 260
 
Private Const NO_ERROR = 0
Private Const ERROR_ACCESS_DENIED = 5&
 
Private Const ERROR_BAD_DEVICE = 1200&
Private Const ERROR_NOT_CONNECTED = 2250&
Private Const ERROR_MORE_DATA = 234
Private Const ERROR_CONNECTION_UNAVAIL = 1201&
Private Const ERROR_NO_NETWORK = 1222&
Private Const ERROR_EXTENDED_ERROR = 1208&
Private Const ERROR_NO_NET_OR_BAD_PATH = 1203&
 
Private Const STYPE_DISKTREE = 0      ' /* disk share */
Private Const STYPE_PRINTQ = 1        ' /* printer share */
Private Const STYPE_DEVICE = 2
Private Const STYPE_IPC = 3
Private Const STYPE_SPECIAL = &H80000000
 
Public Type SHARE_INFO_2
   Netname As String
   ShareType As Long
   Remark As String
   Permissions As Long
   MaxUsers As Long
   CurrentUsers As Long
   Path As String
   Password As String
End Type
 
Private Const LM20_NNLEN = 12         ' // LM 2.0 Net name length
Private Const SHPWLEN = 8             ' // Share password length (bytes)
 
Private Type SHARE_INFO_50            'struct _share_info_50 {
   Netname(0 To LM20_NNLEN) As Byte   '   char            shi50_netname[LM20_NNLEN+1];
   ShareType As Byte                  '   unsigned char   shi50_type;
   Flags As Integer                   '   unsigned short  shi50_flags;
   lpRemark As Long                   '   char FAR *      shi50_remark;
   lpPath As Long                     '   char FAR *      shi50_path;
   PasswordRW(0 To SHPWLEN) As Byte   '   char            shi50_rw_password[SHPWLEN+1];
   PasswordRO(0 To SHPWLEN) As Byte   '   char            shi50_ro_password[SHPWLEN+1];
End Type                              '};
 
Public uncNeedAdminPrivs As Boolean
 
Public Function GetUncName(ByVal FileSpec As String) As String
   Dim Buffer() As Byte
   Dim nRet As Long
   Dim BufferLen As Long
   Dim rni As REMOTE_NAME_INFO
   Dim Shi() As SHARE_INFO_2
   Dim i As Long
   GetUncName = FileSpec
   ' make sure we actually have what looks like a drive-based spec
   On Error Resume Next
   If Asc(UCase$(Left$(FileSpec, 1))) < Asc("A") Then
      Exit Function
   ElseIf Asc(UCase$(Left$(FileSpec, 1))) > Asc("Z") Then
      Exit Function
   ElseIf Mid$(FileSpec, 2, 1) <> ":" Then
      Exit Function
   End If
   If Err.Number Then Exit Function
   On Error GoTo 0
 
   If IsWin95 Then
      ' ***************************************************************
      ' ** Important note: Q131416 states that WNetGetUniversalName  **
      ' **                 always fails under Win95.  :-(            **
      ' ***************************************************************
      ReDim Buffer(1 To MAX_PATH) As Byte
      nRet = WNetGetConnection(Left$(FileSpec, 2), Buffer(1), UBound(Buffer))
      If nRet = NO_ERROR Then
         ' Success! Obtained the universal name for the share
         GetUncName = TrimNull(StrConv(Buffer, vbUnicode)) & Mid$(FileSpec, 3)
         Exit Function
      End If
   Else
      ' in NT/98, call it once to get required size of structure
      nRet = WNetGetUniversalName(FileSpec, REMOTE_NAME_INFO_LEVEL, vbNullString, BufferLen)
   End If
 
   Select Case nRet
      Case ERROR_MORE_DATA
         ' resize buffer and call again
         ReDim Buffer(0 To BufferLen - 1) As Byte
         nRet = WNetGetUniversalName(FileSpec, REMOTE_NAME_INFO_LEVEL, Buffer(0), BufferLen)
         ' extract UNC name from buffer
         If nRet = NO_ERROR Then
            ' retrieve pointers to each of the returned strings
            rni.lpUniversalName = PointerToDWord(VarPtr(Buffer(0)))
            rni.lpConnectionName = PointerToDWord(VarPtr(Buffer(4)))
            rni.lpRemainingPath = PointerToDWord(VarPtr(Buffer(8)))
            ' extract and return lpUniversalName
            GetUncName = PointerToStringA(rni.lpUniversalName)
            ' show lpConnectionName and lpRemainingPath just for kicks?
            ' Debug.Print PointerToStringA(rni.lpConnectionName)
            ' Debug.Print PointerToStringA(rni.lpRemainingPath)
         End If
      Case ERROR_NOT_CONNECTED
         ' get list of local shares
         nRet = EnumShares(Shi)
         If nRet > 0 Then
            ' loop through shares, looking for a potential match
            ' ambiguous: any path can be on more than one share
            For i = 0 To nRet - 1
               If Shi(i).ShareType = STYPE_DISKTREE Then
                  If Left(UCase(FileSpec), Len(Shi(i).Path) + 1) = UCase(Shi(i).Path) & "\" Then
                  'If InStr(1, FileSpec, shi(i).Path, vbTextCompare) = 1 Then
                     ' This element starts with the same path so we
                     ' have to accept first match. Note that if the
                     ' share is a folder (not the root) the filespec
                     ' starts one character further in the buffer.
                     GetUncName = "\\" & CurrentMachineName & _
                                  "\" & Shi(i).Netname & _
                                  Mid(FileSpec, Len(Shi(i).Path) + _
                                  Abs(Len(Shi(i).Path) > 3))
                     Exit For
                  End If
               End If
            Next i
         End If
      Case Else
         ' bad path or network down
         GetUncName = FileSpec
   End Select
End Function
 
Public Function EnumShares(Shi() As SHARE_INFO_2, Optional ByVal Server As String = "") As Long
   Dim nRet As Long
   ' delegate to OS-appropriate routine
   If IsWinNT() Then
      nRet = EnumSharesNT(Shi(), Server)
      uncNeedAdminPrivs = (nRet < 0)
   Else
      nRet = EnumShares9x(Shi(), Server)
   End If
   EnumShares = nRet
End Function
 
Private Function EnumSharesNT(Shi() As SHARE_INFO_2, Optional ByVal Server As String = "") As Long
   Dim Level As Long
   Dim lpBuffer As Long
   Dim EntriesRead As Long
   Dim TotalEntries As Long
   Dim hResume As Long
   Dim Offset As Long
   Dim nRet As Long
   Dim i As Long
 
   ' convert Server to null pointer if none requested.
   ' this has the effect of asking for the local machine.
   If Len(Server) = 0 Then Server = vbNullString
 
   ' ask for all available shares; try level 2 first
   Level = 2
   nRet = NetShareEnum(StrPtr(Server), Level, lpBuffer, MAX_PREFERRED_LENGTH, EntriesRead, TotalEntries, hResume)
 
   If nRet = ERROR_ACCESS_DENIED Then
      ' bummer -- need admin privs for level 2, drop to level 1
      Level = 1
      nRet = NetShareEnum(StrPtr(Server), Level, lpBuffer, MAX_PREFERRED_LENGTH, EntriesRead, TotalEntries, hResume)
   End If
 
   If nRet = NO_ERROR Then
      ' make sure there are shares to decipher
      If EntriesRead > 0 Then
         ' prepare UDT buffer to hold all share info
         ReDim Shi(0 To EntriesRead - 1)
         ' loop through API buffer, extracting each element
         For i = 0 To EntriesRead - 1
            With Shi(i)
               .Netname = PointerToStringW(PointerToDWord(lpBuffer + Offset))
               .ShareType = PointerToDWord(lpBuffer + Offset + 4)
               .Remark = PointerToStringW(PointerToDWord(lpBuffer + Offset + 8))
               If Level = 2 Then
                  .Permissions = PointerToDWord(lpBuffer + Offset + 12)
                  .MaxUsers = PointerToDWord(lpBuffer + Offset + 16)
                  .CurrentUsers = PointerToDWord(lpBuffer + Offset + 20)
                  .Path = PointerToStringW(PointerToDWord(lpBuffer + Offset + 24))
                  .Password = PointerToStringW(PointerToDWord(lpBuffer + Offset + 28))
                  Offset = Offset + Len(Shi(i))
               Else
                  Offset = Offset + 12  ' Len(SHARE_INFO_1)
               End If
            End With
         Next i
      End If
 
      ' return number of entries found
      If Level = 1 Then
         ' negative if we don't have admin privs
         EnumSharesNT = -EntriesRead
      ElseIf Level = 2 Then
         EnumSharesNT = EntriesRead
      End If
   End If
 
   ' clean up
   If lpBuffer Then
      Call NetApiBufferFree(lpBuffer)
   End If
End Function
 
Private Function EnumShares9x(Shi() As SHARE_INFO_2, Optional ByVal Server As String = "") As Long
   Dim Buffer() As Byte
   Dim EntriesRead As Long
   Dim TotalEntries As Long
   Dim Offset As Long
   Dim shi95 As SHARE_INFO_50
   Dim nRet As Long
   Dim i As Long
   Const BufferSize = &H4000
 
   ' convert Server to null pointer if none requested.
   ' this has the effect of asking for the local machine.
   If Len(Server) = 0 Then Server = vbNullString
 
   ' ask for all available shares, using really large buffer
   ReDim Buffer(0 To BufferSize - 1) As Byte
   nRet = NetShareEnum95(Server, 50, Buffer(0), BufferSize, EntriesRead, TotalEntries)
 
   If nRet = NO_ERROR Then
      ' make sure there are shares to decipher
      If EntriesRead > 0 Then
         ' prepare UDT buffer to hold all share info
         ReDim Shi(0 To EntriesRead - 1)
         ' loop through API buffer, extracting each element
         For i = 0 To EntriesRead - 1
            With Shi(i)
               Call CopyMemory(shi95, Buffer(Offset), Len(shi95))
               .Netname = TrimNull(StrConv(shi95.Netname, vbUnicode))
               .ShareType = shi95.ShareType
               .Path = PointerToStringA(shi95.lpPath)
               .Remark = PointerToStringA(shi95.lpRemark)
               If shi95.PasswordRW(0) = 0 Then
                  .Password = TrimNull(StrConv(shi95.PasswordRO, vbUnicode))
               Else
                  .Password = TrimNull(StrConv(shi95.PasswordRW, vbUnicode))
               End If
 
               Offset = Offset + Len(shi95)
            End With
         Next i
 
         ' return number of entries found
         EnumShares9x = EntriesRead
      End If
   End If
End Function
 
Private Function GetConnection95(ByVal LocalName As String) As String
   Dim nRet As Long
   Dim Buffer As String
 
   ' Allocate buffer, and call
   Buffer = Space(MAX_PATH)
   nRet = WNetGetConnection(LocalName, ByVal Buffer, Len(Buffer))
   GetConnection95 = TrimNull(Buffer)
End Function
 
Public Function IsWinNT() As Boolean
   Static os As OSVERSIONINFO
   Static bRet As Boolean
   ' just do this once, for optimization
   If os.dwPlatformId = 0 Then
      os.dwOSVersionInfoSize = Len(os)
      Call GetVersionEx(os)
      bRet = (os.dwPlatformId = VER_PLATFORM_WIN32_NT)
   End If
   IsWinNT = bRet
End Function
 
Public Function IsWin95() As Boolean
   Static os As OSVERSIONINFO
   Static bRet As Boolean
   ' just do this once, for optimization
   If os.dwPlatformId = 0 Then
      os.dwOSVersionInfoSize = Len(os)
      Call GetVersionEx(os)
      bRet = (os.dwMinorVersion < 10) And _
             (os.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS)
   End If
   IsWin95 = bRet
End Function
 
Private Function CurrentMachineName() As String
   Dim Buffer As String
   Dim nLen As Long
   Const CNLEN = 15          ' Maximum computer name length
 
   Buffer = Space(CNLEN + 1)
   nLen = Len(Buffer)
   If GetComputerName(Buffer, nLen) Then
      CurrentMachineName = Left(Buffer, nLen)
   End If
End Function
 
Private Function PointerToDWord(ByVal lpDWord As Long) As Long
   Call CopyMemory(PointerToDWord, ByVal lpDWord, 4)
End Function
 
Private Function PointerToStringA(lpStringA As Long) As String
   Dim Buffer() As Byte
   Dim nLen As Long
 
   If lpStringA Then
      nLen = lstrlenA(ByVal lpStringA)
      If nLen Then
         ReDim Buffer(0 To (nLen - 1)) As Byte
         CopyMemory Buffer(0), ByVal lpStringA, nLen
         PointerToStringA = StrConv(Buffer, vbUnicode)
      End If
   End If
End Function
 
Private Function PointerToStringW(ByVal lpStringW As Long) As String
   Dim Buffer() As Byte
   Dim nLen As Long
 
   If lpStringW Then
      nLen = lstrlenW(lpStringW) * 2
      If nLen Then
         ReDim Buffer(0 To (nLen - 1)) As Byte
         CopyMemory Buffer(0), ByVal lpStringW, nLen
         PointerToStringW = Buffer
      End If
   End If
End Function
 
Private Function TrimNull(ByVal StrIn As String) As String
   Dim nul As Long
   '
   ' Truncate input string at first null.
   ' If no nulls, perform ordinary Trim.
   '
   nul = InStr(StrIn, vbNullChar)
   Select Case nul
      Case Is > 1
         TrimNull = Left(StrIn, nul - 1)
      Case 1
         TrimNull = ""
      Case 0
         TrimNull = Trim(StrIn)
   End Select
End Function
 
Public Function GetDrvName(UncName As String) As String
  Dim MachineName As String
  Dim nRet As Long
  Dim i As Integer
  Dim Shi() As SHARE_INFO_2
  'Renvoie le nom local du fichier passé en notaition UNC
  'Ceci ne marche que si le fichier est local
  GetDrvName = UncName  'par defaut
 
  MachineName = "\\" & CurrentMachineName & "\"
  If Left(UncName, Len(MachineName)) <> MachineName Then
    Exit Function
  End If
  nRet = EnumShares(Shi)
  If nRet > 0 Then
    For i = 0 To nRet - 1
       With Shi(i)
          If Shi(i).ShareType = STYPE_DISKTREE Then
             If Left(UncName, Len(MachineName & Shi(i).Netname)) = MachineName & Shi(i).Netname Then
                GetDrvName = Shi(i).Path & Mid(UncName, Len(MachineName & Shi(i).Netname) + 1)
                Exit For
             End If
          End If
       End With
    Next i
  End If
End Function