Création d'un lien hypertexte en relatif [Résolu]

Messages postés
9
Date d'inscription
lundi 24 avril 2006
Dernière intervention
18 décembre 2006
- - Dernière réponse : cs_rikoo83
Messages postés
9
Date d'inscription
lundi 24 avril 2006
Dernière intervention
18 décembre 2006
- 24 avril 2006 à 17:01
Bonjour, je suis nouveau sur le forum, mais j'ai regardé dans les réponses déjà données, sans succès...
C'est pourquoi j'appel à l'aide.
En effet, j'ai créé ume macro qui me liste tous les fichiers situés dans un répertoire ainsi que dans ces sous répertoires. Ainsi je crais, mes liens hypertexte, mais ils sont en absolu et non en relatif. Le problème, c'est que je dois graver toutes ces informations. C'est pourquoi, j'aimerai savoir si il y a une solution possible afin de m'éviter de faire les modifications manuellements (car j'ai plus de 1000 liens...)
Par avance merci...

Rikoo
Afficher la suite 

8 réponses

Meilleure réponse
Messages postés
2382
Date d'inscription
jeudi 12 juillet 2001
Dernière intervention
15 décembre 2018
3
Merci
Sa doit ressembler à ca mais je n'ai pas pu tester.
Regarde ce que j'ai mis en gras "Dossier de départ" tu le remplaces par le dossier où se trouve ton fichier excel.

8<-------------------------------------------------
Private Declare Function PathRelativePathTo Lib "shlwapi.dll" Alias "PathRelativePathToA" (ByVal pszPath As String, ByVal pszFrom As String, ByVal dwAttrFrom As Long, ByVal pszTo As String, ByVal dwAttrTo As Long) As Long
Private Const MAX_PATH As Long = 260
Private Const FILE_ATTRIBUTE_DIRECTORY As Long = &H10
Private Const FILE_ATTRIBUTE_NORMAL As Long = &H80
'............
'............
'............Function Lister(nRow&, FolderName$, Optional Suffix$ "*.*", Optional SubDir As Boolean True)
Dim i As Long, x As Long, File As String, Folder As String, nbFolders() As String

Cells(nRow, 1) = FolderName
Cells(nRow, 1).Font.Bold = TrueIf Not Right(FolderName, 1) "" Then FolderName FolderName & ""
File = Dir(FolderName & Suffix)

Do While Len(File) > 0
With ActiveSheet
.Hyperlinks.Add Anchor:=Cells(i, 2), Address:=get_relative_path_to( Dossier de départ , FolderName & File), TextToDisplay: =File

ActiveSheet.Hyperlinks.Add Anchor:= Cells(nRow, 2), Address:= get_relative_path_to( Dossier de départ , FolderName & File)
'
End With
nRow = nRow + 1
File = Dir
Loop

If Not SubDir Then Exit Function
x = 0
Folder = Dir(FolderName, vbDirectory)

Do While Folder > ""
If Folder <> "." And Folder <> ".." ThenIf (GetAttr(FolderName & Folder) And vbDirectory) vbDirectory Then x x + 1
End If
Folder = Dir
Loop

ReDim nbFolders(x + 1)
i = 1
nbFolders(i) = Dir(FolderName, vbDirectory)
Do While nbFolders(i) > ""
If nbFolders(i) <> "." And nbFolders(i) <> ".." ThenIf (GetAttr(FolderName & nbFolders(i)) And vbDirectory) vbDirectory Then i i + 1
End If
nbFolders(i) = Dir
Loop
For i = 1 To UBound(nbFolders()) - 1
Call Lister(nRow, FolderName & nbFolders(i), Suffix)
Next
End Function

'-----------------------------------------------------------
' Creates a relative path from one file or folder to another.
'
' made by Alexander Triantafyllou [mailto:alextriantf@yahoo.gr alextriantf@yahoo.gr]
'
' usage relative_path=get_relative_path_to(root_path,file_path)
' get_relative_path_to("d:\a\b\c\d","d:\a\b\index.html") will return
' "..\..\index.html"
' use FILE_ATTRIBUTE_DIRECTORY if the path is a directory
' or FILE_ATTRIBUTE_NORMAL if the path is a file
'----------------------------------------------------------
Public Function get_relative_path_to(ByVal parent_path As String, ByVal child_path As String) As String


Dim out_str As String
Dim par_str As String
Dim child_str As String


out_str = String(MAX_PATH, 0)


par_str = parent_path + String(100, 0)
child_str = child_path + String(100, 0)


PathRelativePathTo out_str, par_str, FILE_ATTRIBUTE_DIRECTORY, child_str, FILE_ATTRIBUTE_NORMAL


get_relative_path_to = StripTerminator(out_str)
End Function


'Remove all trailing Chr$(0)'s
Function StripTerminator(sInput As String) As String
Dim ZeroPos As Long
ZeroPos = InStr(1, sInput, Chr$(0))
If ZeroPos > 0 Then
StripTerminator = Left$(sInput, ZeroPos - 1)
Else
StripTerminator = sInput
End If
End Function

Bon dév

Dire « Merci » 3

Quelques mots de remerciements seront grandement appréciés. Ajouter un commentaire

Codes Sources 98 internautes nous ont dit merci ce mois-ci

Messages postés
2382
Date d'inscription
jeudi 12 juillet 2001
Dernière intervention
15 décembre 2018
0
Merci
Salut,
Avec cette source tu devrait pouvoir faire quelque chose.
http://www.vbfrance.com/codes/CREATION-CHEMINS-RELATIFS_36755.aspx
Messages postés
9
Date d'inscription
lundi 24 avril 2006
Dernière intervention
18 décembre 2006
0
Merci
Re, j'avais déjà essayé cette source, mais je n'arrive pas à la faire fonctionner, peut est-ce à cause de ma version d'Excel (Excel 97, et je ne peux pas en changer ;) version du boulot :s ), il ne comprend pas les return et d'autres choses encore...
Sinon, n'existe-t-il pas un moyen de modifier les liens hypertextes déjà créés d'absolu en relatif???
Messages postés
2382
Date d'inscription
jeudi 12 juillet 2001
Dernière intervention
15 décembre 2018
0
Merci
Ce code donné précédemment est en .net, la conversion vba n'est pas très compliqué.
Mais voici un autre exemplehttp://www.freevbcode.com/ShowCode.asp?ID=6137
Messages postés
9
Date d'inscription
lundi 24 avril 2006
Dernière intervention
18 décembre 2006
0
Merci
Je viens d'aller voir l'autre code, mais je n'arrive pas à le lancer, il me demande de le lancer à partir d'une autre macro. Et je ne me souviens plus comment faire :s
A l'AIDE !!! ;)
Messages postés
2382
Date d'inscription
jeudi 12 juillet 2001
Dernière intervention
15 décembre 2018
0
Merci
Peux tu donner une partie de ton code qui liste et créer les liens ? il sera ainsi plus facile de te montrer comment greffer cette méthode dans ton code
Messages postés
9
Date d'inscription
lundi 24 avril 2006
Dernière intervention
18 décembre 2006
0
Merci
Private Sub CommandButton1_Click()
'Une méthode basique sans API pour lister les répertoires et
'sous-répertoires. Michel Pierron, MPFE 2002. Adaptation Flo Cabon sur une idée de "mrik"
'* nRow = Ligne de départ
'* FolderName = Chemin du répertoire à lister
'* Suffix = Filtre optionnel des types de fichiers
'* SubDir = True pour étendre la liste aux sous-répertoires
Dim LeMessage As String, mess As String, Lextension As String
'Dim Profondeur As VbMsgBoxResult
Dim nRow As Long

LeMessage = "Choisissez le dossier à analyser"
mess InputBox("entrez le nom du répertoire à explorer", "Chemin du répertoire")'LeRepertoire GetDirectory(LeMessage)

Lextension = InputBox("indiquez éventuellement une extension de fichier pour filtrer les fichiers", "Type de fichier", "*.*")
Profondeur = MsgBox("Voulez vous analyser aussi les sous-répertoires ?", vbYesNo, "Profondeur d'analyse")
nRow = InputBox("indiquez le N° de la première ligne pour le tableau de sortie", "Sortie des résultats", "1")
If Profondeur = vbYes Then
truc = Lister(nRow, mess, Lextension, True)
Else
truc = Lister(nRow, mess, Lextension, False)
End If
End Sub


Function Lister(nRow&, FolderName$, Optional Suffix$ "*.*", Optional SubDir As Boolean True)
Dim i As Long, x As Long, File As String, Folder As String, nbFolders() As String


Cells(nRow, 1) = FolderName
Cells(nRow, 1).Font.Bold = True
If Not Right(FolderName, 1) "" Then FolderName FolderName & ""
File = Dir(FolderName & Suffix)

Do While Len(File) > 0
With ActiveSheet
'.Hyperlinks.Add Anchor:=Cells(i, 2), Address:=FolderName & File, TextToDisplay:=File

ActiveSheet.Hyperlinks.Add Anchor:=Cells(nRow, 2), Address:= FolderName & File
'
End With
nRow = nRow + 1
File = Dir
Loop

If Not SubDir Then Exit Function
x = 0
Folder = Dir(FolderName, vbDirectory)

Do While Folder > ""
If Folder <> "." And Folder <> ".." Then
If (GetAttr(FolderName & Folder) And vbDirectory) vbDirectory Then x x + 1
End If
Folder = Dir
Loop

ReDim nbFolders(x + 1)
i = 1
nbFolders(i) = Dir(FolderName, vbDirectory)
Do While nbFolders(i) > ""
If nbFolders(i) <> "." And nbFolders(i) <> ".." Then
If (GetAttr(FolderName & nbFolders(i)) And vbDirectory) vbDirectory Then i i + 1
End If
nbFolders(i) = Dir
Loop
For i = 1 To UBound(nbFolders()) - 1
Call Lister(nRow, FolderName & nbFolders(i), Suffix)
Next
End Function
Messages postés
9
Date d'inscription
lundi 24 avril 2006
Dernière intervention
18 décembre 2006
0
Merci
C super, ça fonctionne...

Je te remercie encore.

P.S. : Pour ceux qui souhaite l'utiliser, n'oubliez pas de piquer la fonction de la commande boutton 1. ^^

A bientôt !

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.