Création raccourci ?

Option Explicit

Sub CreerRaccourci()
'myDearFriend!  -  www.mdf-xlpages.com
Dim Raccourci As Object
    With ActiveWorkbook
        'Vérifie l'existence d'un chemin pour le classeur
        If .Name <> .FullName Then
            'Défini le raccourci
            With CreateObject("WScript.Shell")
                Set Raccourci = .CreateShortcut(.SpecialFolders("Desktop") _
                    & "\" & ActiveWorkbook.Name & ".lnk")
            End With
            With Raccourci
                'Affecte l'icône (chemin à adapter)
                .iconlocation = "c:\DF2Sociétés\DF2Sociétes.ico"
                'Crée le raccourci sur le bureau Windows
                .TargetPath = ActiveWorkbook.FullName ' le chemin est identifié
                .Save
            End With
        Else
            MsgBox "Sauvegardez déjà le classeur sur le DD et recommencez..."
        End If
    End With
End Sub