Création d'un lien hypertexte en relatifRésolu

Question

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

cs_Willi · Accepted Answer

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

cs_Willi · Answer

Salut,
Avec cette source tu devrait pouvoir faire quelque chose.
http://www.vbfrance.com/codes/CREATION-CHEMINS-RELATIFS_36755.aspx

cs_rikoo83 · Answer

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???

cs_Willi · Answer

Ce code donn&#233; pr&#233;c&#233;demment est en .net, la conversion vba n'est pas tr&#232;s compliqu&#233;.
Mais voici un autre exemplehttp://www.freevbcode.com/ShowCode.asp?ID=6137

cs_rikoo83 · Answer

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 !!! ;)

cs_Willi · Answer

Peux tu donner une partie de ton code qui liste et cr&#233;er les liens ? il sera ainsi plus facile de te montrer comment greffer cette m&#233;thode dans ton code

cs_rikoo83 · Answer

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

cs_rikoo83 · Answer

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 !

Création d'un lien hypertexte en relatif

8 réponses

Discussions similaires