MàJ lien hypertexte vers un fichier déplacé

Syntaxerror · 19 Février 2009

Bonjour à tous !
Je voudrais créer une macro me permettant de mettre à jour les liens hypertextes de fichiers au cas où ils aient été déplacés . Voilà comment je vois la chose :

1/ récupérer le le lien hypertexte de la cellule active (facile !)
2/ en extraire le nom du fichier cible (aïe, là je bute déja)
3/ faire une recherche avec le nom du fichier (avec un Filesearch, ça devrait le faire)
4/ récupérer l'adresse du fichier (s'il est trouvé)
5/ modifier le lien hypertexte avec la nouvelle adresse (quand j'en serait là...)

Comme ça, ça parait simple mais je bute déja à la deuxième étape...

Merci de me lire et de m'aider éventuellement

Guest · 19 Février 2009

Re : MàJ lien hypertexte vers un fichier déplacé

Bonjour,

Pour retrouver l'adresse du lien hypertexte de la cellule active:

Code:

activecell.Hyperlinks(1).Address

Pour le nom du fichier

Code:

Dim t as variant
t=Split(ActiveCell.HyperLinks(1).Address,"\")
Fichier=t(Ubound(t))

A+

Syntaxerror · 19 Février 2009

Re : MàJ lien hypertexte vers un fichier déplacé

Merci Hasco !
Pour l'adresse du lien hypertexte j'avais bon, mais pour sortir le nom du fichier je m'en suis vu ! Sans toi j'y serai encore.J'aimerais quand même bien comprendre le split et Ubound, mais bon ça marche...
Enfin ça marche étrangement que si je remplace l'antislash (\) par un slash (/)....
J'ai pu donc enchainer directement sur le 3/. Ca avance !
Voilà ou j'en suis :

Code:

Sub RestorAdress()
Dim L As Hyperlink
Dim Filadress As String
Dim t As Variant


'Filadress = ActiveCell.Hyperlinks(1).Address

t = Split(ActiveCell.Hyperlinks(1).Address, "/")
Fichier = t(UBound(t))


With Application.FileSearch
        .LookIn = "G:\Mes documents"
        .Filename = Fichier
        .SearchSubFolders = True
        .FileType = msoFileTypeAllFiles
     If .Execute() > 0 Then
     
     MsgBox "Fichier trouvé !"
        
    Else
        MsgBox "Il n'ya aucun fichier dans ce dossier"
    End If
End With

La suite dans le prochain épisode....

Guest · 19 Février 2009

Re : MàJ lien hypertexte vers un fichier déplacé

Re,

Split eclate une chaine de caratère dans un tableau en fonction d'un séparateur

Ubound(Tableau) donne la dimmension du tableau

Si tu as chaine= "C:\Dossier\Sous-Dossier\Fichier.xls"
t=Split(chaine,"\") donnera:
t(0)="C:"
t(1)="Dossier"
t(2)="Sous-Dosser"
t(3)="Fichiers.xls"

Ubound(t) =3 ' le premier indice étant 0

A+

Syntaxerror · 19 Février 2009

MàJ lien hypertexte vers un fichier déplacé[résolu]

Ca c'est malin, comme astuce ! Mais ce soir en fouillant dans mes anciennes macro, je suis retombé sur Dir qui marche bien aussi. Je crois que je vais privilegier ce dernier à cause des / et\ que j'ai du mal à gérer. Donc voici un premier jet pondu à la lueur de la chandelle. Ca à l'air de marcher ...Sauf si quelqu'un me trouve un bug ;-)

Code:

Sub RestorAdress()
Dim L As Hyperlink
Dim Fichier, NouvellAdresse As String
Dim t As Variant


't = Split(ActiveCell.Hyperlinks(1).Address, "\")
'Fichier = t(UBound(t))

Fichier = Dir(ActiveCell.Hyperlinks(1).Address, vbNormal)

With Application.FileSearch
        .LookIn = "C:\Users"
        .Filename = Fichier
        .SearchSubFolders = True
        .FileType = msoFileTypeAllFiles
        .MatchTextExactly = True
     If .Execute() > 0 Then
     NouvellAdresse = Application.FileSearch.FoundFiles(1)
     
     Else: MsgBox "Le fichier n'est pas dans le dossier"
     
    End If
End With


ActiveCell.Hyperlinks(1).Address = NouvellAdresse
ActiveCell.Hyperlinks(1).TextToDisplay = NouvellAdresse


End Sub

Encore merci à Hasco pour son aide

Syntaxerror · 20 Février 2009

Re : MàJ lien hypertexte vers un fichier déplacé

hello @ tous !
Petit souci avec la fonction FileSearch : malgré MatchTextExactly = True, la recherche ne me donne pas toujours le bon fichier...
Quelqu'un sait-il d'où ça vient ? J'investigue de mon coté....

Guest · 20 Février 2009

Re : MàJ lien hypertexte vers un fichier déplacé

Bonjour,
J'utilise ma méthode avec split, parceque l'adresse du lien peut être sous forme : NomRep/Fichier.xxx si le fichier est dans un sous répertoire du répertoire actuel. Auquel cas dir("NomRep/Fichier") renvoie ""

En effet .Address peut être différent de .TextToDisplay

Code:

Function GetFichier(chemin, monfichier) As String
 'Retourne le premier fichier correspondant
  With Application.FileSearch
    .NewSearch
    .LookIn = chemin
    .SearchSubFolders = True
    .Filename = monfichier
   If .Execute() > 0 Then
      GetFichier = .FoundFiles(1)
   End If
   End With
End Function
 
Sub RestorAddress()
    Dim NomFichier As String, NouvelleAdresse As String
    NomFichier = GetNomFichier(ActiveCell.Hyperlinks(1).Address)

    If NomFichier <> "" Then

        NouvelleAdresse = GetFichier(C:\Users",NomFichier)
        ActiveCell.Hyperlinks(1).Delete
        ActiveSheet.Hyperlinks.Add Anchor:=ActiveCell, _
        Address:=NouvelleAdresse, TextToDisplay:=NouvelleAdresse

    Else

        MsgBox "L'adresse du lien de la cellule " & ActiveCell.Address & " est vide!", vbExclamation, "RestorAddress"

    End If
End Sub
 
Function GetNomFichier(CheminFichier As String)
    Dim Sep As String
    Dim t
    if cheminfichier="" then exit function

    Sep = "/"
    If InStr(1, CheminFichier, "\") > 0 Then Sep = "\"
    t = Split(CheminFichier, Sep)
    GetNomFichier = t(UBound(t))
End Function

A bientôt

Syntaxerror · 21 Février 2009

Re : MàJ lien hypertexte vers un fichier déplacé

C'est bien fichu ! En tous les cas comme ça c'est un peu plus clair. Vue que ça marche bien, j'ai rajouté quelques lignes de code pour traiter plusieurs lien hypertexte dans un même classeur.

Code:

Function GetFichier(chemin, monfichier) As String
 'Retourne le premier fichier correspondant
  With Application.FileSearch
    .NewSearch
    .LookIn = chemin
    .SearchSubFolders = True
    .Filename = monfichier
    .MatchTextExactly = True
   If .Execute() > 0 Then
      GetFichier = .FoundFiles(1)
   End If
   End With
End Function
 
Sub RestorAddressBatch()
    Dim NomFichier As String, NouvelleAdresse As String
    [color=red]Dim c As Range
    
    For Each c In Range("a:a")[/color]
    
    [color=red]If c.Value <> "" Then [/color]NomFichier = GetNomFichier(c.Hyperlinks(1).Address)

    If NomFichier <> "" Then

        NouvelleAdresse = GetFichier("C:\Users", NomFichier)
        [color=red]c[/color].Hyperlinks(1).Delete
        ActiveSheet.Hyperlinks.Add Anchor:=[color=red]c[/color], _
        Address:=NouvelleAdresse
        

    Else

        MsgBox "L'adresse du lien de la cellule " & [color=red]c[/color].Address & " est vide!", vbExclamation, "RestorAddress"

    End If
    [color=red]Next c[/color]
End Sub
 
Function GetNomFichier(CheminFichier As String)
    Dim Sep As String
    Dim t
    If CheminFichier = "" Then Exit Function

    Sep = "/"
    If InStr(1, CheminFichier, "\") > 0 Then Sep = "\"
    t = Split(CheminFichier, Sep)
    GetNomFichier = t(UBound(t))
End Function

Ca fonctionne même si c'est pas très rapide et puis j'ai un petit message d'erreur une fois l'ensemble des liens hypertextes dans la colonne A traité. Mystère...

Syntaxerror · 21 Février 2009

Re : MàJ lien hypertexte vers un fichier déplacé

G résolu le problème en modifiant le code ci-dessus comme suit :

Code:

For Each c In Range("a:a")
    
    If c.Value <> "" Then
    NomFichier = GetNomFichier(c.Hyperlinks(1).Address)

    [color=green]If NomFichier <> "" Then[/color]

        NouvelleAdresse = GetFichier("C:\Users", NomFichier)
        c.Hyperlinks(1).Delete
        ActiveSheet.Hyperlinks.Add Anchor:=c, _
        Address:=NouvelleAdresse
        

    Else

        MsgBox "L'adresse du lien de la cellule " & c.Address & " est vide!", vbExclamation, "RestorAddress"

    End If
    [color=green]End If[/color]
    Next c

Bonne soirée !

MàJ lien hypertexte vers un fichier déplacé

Syntaxerror

XLDnaute Junior

Guest

Guest

Syntaxerror

XLDnaute Junior

Guest

Guest

Syntaxerror

XLDnaute Junior

Syntaxerror

XLDnaute Junior

Guest

Guest

Syntaxerror

XLDnaute Junior

Syntaxerror

XLDnaute Junior

Discussions similaires