ThisWorkbook.FollowHyperlink "C:\Dossier\MonFichier.doc#NomDuSignet", , True

 
Dim objLink As Hyperlink

Set objLink = ActiveSheet.Hyperlinks.Add(Range("F2"), "d:\user\tuto.xls")
With objLink
    .SubAddress = "A1:C10"
    .Follow NewWindow:=True
End With

 
objLink.Address = "d:\jmarc.xls"
objLink.Range.Value = "d:\jmarc.xls"

Sub Test()
    DeclencheLien Range("A1")
End Sub


Sub DeclencheLien(Cellule As Range)
'Vérifie si la cellule contient un lien
If Cellule.Hyperlinks.Count = 0 Then
    MsgBox "il n'y a pas de lien hypertexte dans la cellule " & Cellule.Address
    Else
    'Déclenche le lien
    Cellule.Hyperlinks(1).Follow NewWindow:=True
End If
End Sub

Sub ExtractionLiensHypertextes()
    Dim Cell As Range
    Dim Ligne As Integer
    
    'Récupère le numéro de la dernière ligne non vide
    Ligne = Columns(1).SpecialCells(xlCellTypeLastCell).Row
    
    'Boucle sur les cellules de la colonne A
    For Each Cell In Range("A1:A" & Ligne)
        If Cell.Hyperlinks.Count > 0 Then _
            Cell.Offset(0, 1) = Cell.Hyperlinks(1).Address
    Next Cell
End Sub

Sub imprimerPageActiveEt_Liensclasseurs()
Dim Lien As Hyperlink
Dim I As Byte

Application.ScreenUpdating = False
'Imprime la feuille active
ActiveSheet.PrintOut

'Boucle sur les liens de la feuille active
For Each Lien In ActiveSheet.Hyperlinks
    'Vérifie si le lien correspond à un classeur
    If Right(Range(Lien.Range.Address).Hyperlinks(1).Address, 4) = ".xls" Then
        'Déclenche le lien pour ouvrir le classeur
        Range(Lien.Range.Address).Hyperlinks(1).Follow NewWindow:=False
        
        'Imprime le classeur
        ActiveWorkbook.PrintOut
        
        'Referme le classeur
        ActiveWorkbook.Close
    End If
Next

Application.ScreenUpdating = True
End Sub

Sub CreationLienMail()
    With ActiveSheet
    .Range("A1") = "La description"
    .Hyperlinks.Add .Range("A1"), Address:="mailto:mimi@mail.fr"
    End With
End Sub

Sub Test()
    'Vérifie si le lien hypertexte contenu dans la cellule A1
    'correspond à un fichier existant sur le PC.
    'Renvoie Vrai ou Faux.
    MsgBox VerifHyperlink(Range("A1"))
End Sub


Function VerifHyperlink(Cellule As Range) As Boolean
    Dim Cible As String
    
    'Vérifie si la cellule contient un lien hypertexte
    If Cellule.Hyperlinks.Count = 0 Then
        VerifHyperlink = False
        Exit Function
    End If
    
    'Extrait l'adresse du lien
    Cible = Cellule.Hyperlinks(1).Address
    
    'Vérifie si le fichier existe.
    '(Ne fonctionne pas pour les liens web).
    If Dir(Cible) <> "" And Cible <> "" Then
        VerifHyperlink = True
        Else
        VerifHyperlink = False
    End If
End Function

 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim Ch As Chart
    
    If Not Intersect(Target, Range("A1")) Is Nothing Then
       On Error Resume Next
       Set Ch = Charts(Target.Value)
       On Error GoTo 0
       
       'Active le feuille graphique si elle existe.
       If Not Ch Is Nothing Then Charts(Target.Value).Activate
    End If
End Sub