Function PathFromHyperLink(ByVal AdresseLien As String, Optional ByVal UNCPath As Boolean = False) As String 'Renvoi le chemin complet du lien hypertext qui pointe sur un fichier Dim objet_fso As Object PathFromHyperLink = vbNullString 'si le fichier existe If Not Dir(AdresseLien) = vbNullString Then Set objet_fso = CreateObject("Scripting.FileSystemObject") PathFromHyperLink = objet_fso.GetAbsolutePathName(AdresseLien) If UNCPath = True Then PathFromHyperLink = GetUNCPath(Replace$(PathFromHyperLink, Dir(PathFromHyperLink), vbNullString)) Set objet_fso = Nothing End If End Function Function GetUNCPath(ByVal MyPath As String) As String ' recuperation du Chemin UNC d'un lecteur reseau Dim Drive_fso As Object, fso As Object If MyPath = vbNullString Then Exit Function Set fso = CreateObject("Scripting.FileSystemObject") On Error Resume Next Set Drive_fso = fso.GetDrive(fso.GetDriveName(MyPath)) If Not Err = 0 Then GetUNCPath = vbNullString ElseIf Not Drive_fso.ShareName = vbNullString And Not LCase$(fso.GetFile(MyPath).Path) = LCase$(MyPath) Then GetUNCPath = Drive_fso.ShareName & Right$(MyPath, Len(MyPath) - 2) Else GetUNCPath = MyPath End If On Error GoTo 0 Set Drive_fso = Nothing Set fso = Nothing End Function Sub demo() Dim Chemin As String, Macellule As Range Set Macellule = Range("A1") If Macellule.Hyperlinks.Count > 0 Then Chemin = PathFromHyperLink(Macellule.Hyperlinks(1).Address, True) End If If Not Chemin = vbNullString Then MsgBox Chemin End If End Sub
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.