[VBA]Liens hypertext plus valides après qq minutes

[TheLio]

Hello Tous,
Ci dessous, un code qui génère une table des matières d'un répertoire choisi avec création d' hyperlink...
Là, c'est bon, ça fonctionne pil poil
Mais quelques minutes après la création du fichier...
Une boîte de dialogue apparaît quand on veut suivre un lien...

L'adresse de ce site n'est pas valide. Verifiez l'adresse et réessayer

Est-ce que cela vient du fait que le fichier est sur un autre server (non-virtuel pour les amateurs;-)) que le répertoire analysé ???
That was my question dear...

Private Sub CommandButton1_Click()
[COLOR="SeaGreen"]'adaptée de:
'http://www.developpez.net/forums/showthread.php?t=342976
'Par LJA Pour ***
'Définir le chemin du répertoire en "C6"[/COLOR]
Dim a As Variant
a = MsgBox("Voulez vous créer la table des matières ?" & vbCrLf & "Ceci peut prendre quelques secondes" & vbCrLf & "Merci", vbYesNo + vbExclamation, "Initilisation de la recherche...")
If a = vbNo Then Exit Sub
Application.ScreenUpdating = False
Selection.AutoFilter Field:=1
    Range("B6").Value = "*"
Rows("9:65536").Select
    Selection.ClearContents
    Selection.FormatConditions.Delete
    Range("B6").Select
Dim Chemin As String
Dim i As Integer
Dim objFSO As Object, objFile As Object
Chemin = Range("C6") [COLOR="seagreen"]'C'est ICI que l'on choisi le chemin[/COLOR]
Set objFSO = CreateObject("Scripting.FileSystemObject")

With Application.FileSearch
    .NewSearch
    .FileType = msoFileTypeAllFiles
    .LookIn = Chemin
    .SearchSubFolders = True
    .Execute
    Cells(8, 1).Value = "N°"
    Cells(8, 2).Value = "Nom Dossier"
    Cells(8, 3).Value = "Nom fichier"
    Range("A8:D8").Font.Bold = True
    With .FoundFiles
        For i = 1 To .Count
            Cells(i + 8, 1) = i
            Worksheets(1).Hyperlinks.Add Cells(i + 8, 3), .Item(i)
            Cells(i + 8, 3).Hyperlinks(1).TextToDisplay = Dir(.Item(i))
        
            Set objFile = objFSO.GetFile(.Item(i))
            Cells(i + 8, 2) = Dir(objFSO.GetParentFolderName(objFile), vbDirectory)
        
        Next i
    End With
End With
 
Columns("C").AutoFit
   Selection.End(xlDown).Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.FormatConditions.Delete
    Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=SI($A14>0;MOD(LIGNE();2)=0)"
    Selection.FormatConditions(1).Font.ColorIndex = 1
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = 15
        .Pattern = xlGray25
    End With
    Selection.Font.Bold = True
    Range("C6").Select
Application.ScreenUpdating = True
MsgBox "Génération de table" & vbCrLf & "terminée." & vbCrLf & "Merci" & vbCrLf & "LJA", _
vbInformation, "Fin de recherche"
End Sub

A++
Lionel

 

[Compte Supprimé 979]

Re : [VBA]Liens hypertext plus valides après qq minutes

Salut TheLio,

Pour moi si je regarde ton code comme ça, le lien que tu mets est le nom du fichier, et tu affiches le répertoire dans lequel il se trouve.

Donc, lorsque tu cliques sur le lien, si ton répertoire actuelle n'est pas celui du fichier, tu as effectivement un message d'erreur !

A+

 

[TheLio]

Re : [VBA]Liens hypertext plus valides après qq minutes

Hello Bruno, le forum
et merci pour ta réponse.
Pour clarifier un peu plus, les liens fonctionnent très bien. C'est après quelques minutes que ça plante...
Re-Merci
A++
Lionel

 

[TheLio]

Re : [VBA]Liens hypertext plus valides après qq minutes

Lift me up
et salutations
Lio​