Discussion :

[frunch]

Bonjour à tous,
Meilleurs voeux pour cette année.
J'ai trouvé ce code pour avoir un raccourci bureau.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
Dim nom, f, WshShell, strDesktop, oShellLink, chemin
    nom = "Réparation gest piéces V multipostes"
    chemin = "C:\Users\fpair\OneDrive\Bureau\"  'ThisWorkbook.Path
        'f = Application.GetSaveAsFilename(nom, fileFilter:="Fichier (*.xlsm),.*xlsm")
        'ActiveWorkbook.SaveAs Filename:=f
    Set WshShell = CreateObject("WScript.Shell")
    'strDesktop = WshShell.SpecialFolders("Desktop") 'dossier sur le buro
    Set oShellLink = WshShell.CreateShortcut(chemin & "\" & nom & ".lnk") 'ici titre du raccourci**
    oShellLink.TargetPath = ThisWorkbook.Path & nom  'chemin de la cible 
    oShellLink.WindowStyle = 1
    oShellLink.Save
    MsgBox "Le raccourci a été créé et placé sur le bureau"

Cà fonctionne mais çà m'ouvre une fenêtre pour refaire le chemin de la cible, et mettre l'extension alors qu'il est indiqué dans la macro.

Donc il doit y avoir un loupé quelque part.
Merci

[Valtrase]

Salut,
La variable chemin comporte un slash en fin de chaine

Set oShellLink = WshShell.CreateShortcut(chemin & "\" & nom & ".lnk")'ici titre du raccourci**

Et là tu rajoute un slash donc le chemin n'est plus reconnu.
Utilise une fonction tu ne te posera plus de question

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
Public Function GetAppPath() As String
    Dim Path As String
    Path = ThisWorkbook.Path
    Path = Path & IIf(Right$(Path, 1) = "\", vbNullString, "\")
    GetAppPath = Path
End Function

et pour l'appel

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Set oShellLink = WshShell.CreateShortcut(GetAppPath & nom & ".lnk")

Avant de faire quoique ce soit il est toujours bon de contrôler la véracité du chemin avec un Dir par exemple

Edit :
Une fonction plus générique :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
Public Function AddBackslash(ByVal FolderPath As String) As String
    FolderPath = Trim(FolderPath)
    If Right$(FolderPath, 1) <> "\" Then FolderPath = FolderPath & "\"
    AddBackslash = FolderPath
End Function

[frunch]

Salut Valtrase,
Merci pour la réponse.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Sub raccBuro()
    Dim nom, f, WshShell, strDesktop, oShellLink, chemin
    '2 fois le fichier,téléch drive et pas de macros
    nom = "Réparation gest piéces V multipostes"
    chemin = "C:\Users\fpair\OneDrive\Bureau\"  'ThisWorkbook.Path
    Set WshShell = CreateObject("WScript.Shell")
    Set oShellLink = WshShell.CreateShortcut(chemin & nom & ".lnk")  'ici titre du raccourci**
    'Set oShellLink = WshShell.CreateShortcut(GetAppPath & nom & ".lnk")
    oShellLink.TargetPath = ThisWorkbook.Path & nom
    oShellLink.WindowStyle = 1
    oShellLink.Save
    If Dir(chemin & nom) = "" Then
        MsgBox "Aucun raccourci n'a été créé."
        MsgBox chemin & nom
    Else
        MsgBox "Le raccourci a été créé et placé sur le bureau."
    End If
End Sub

Cà installe le raccourci toujours pareil, sans extension.
et le test du chemin n'est pas bon
Cdt

[Valtrase]

Re,
Tu veux faire quoi au juste. Un raccourci, copier le fichier sur le bureau ou autre ...

ps Un raccourci Windows à une extension cachée. Pourquoi veux tu la changer ?

[frunch]

Le fichier est dans un dossier sur le disque dur.
Je veux faire un raccourci de ce fichier sur le bureau. Pas le copier, il ne doit pas être accessible par l'utilisateur.
Quand j'approche le curseur, il me met bien le dossier d'ou provient le fichier à l'origine.

[Valtrase]

Et donc tu endends quoi là :

Cà installe le raccourci toujours pareil, sans extension.

[frunch]

Comme çà, et quand on doubleclique dessus on a le message...

[Jean-Philippe André]

Bonjour,

je pense que tu ne maitrises pas ce que les propriétés d'un raccourci attendent en valeurs.

Le targetpath est le chemin du fichier sur lequel tu souhaites atterrir.

Un chemin de fichier comporte un répertoire, un nom et une extension.

Dans ton cas tu omets l'extension du fichier en ne passant que "Réparation gest piéces V multipostes"

Si ton fichier est un Excel, il aura besoin d'un xls/xlsx/xlsm selon...

Peux tu nous corriger le chemin exact de ton fichier et refaire un test

[frunch]

Bonjour,
Voilà ce que çà donne en rajoutant l'extension au nom.
Il installe bien le fichier sur le bureau, mais ne reconnait pas le chemin ou il l'a mis.
et sans extension, il met le dossier Réparations en entier sur le bureau.
Autre info, en testant le fichier forum, il reconnait le chemin, mais il faut toujours parcourir le chemin d'origine sur le raccourci.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Sub raccBuro()
    Dim nom, f, WshShell, strDesktop, oShellLink, chemin
    nom = "Réparation gest piéces V multipostes.xlsm" 'crée un dossier
    chemin = "C:\Users\fpair\OneDrive\Bureau\"
    Set WshShell = CreateObject("WScript.Shell")
    Set oShellLink = WshShell.CreateShortcut(chemin & nom & ".lnk")
    oShellLink.TargetPath = ThisWorkbook.Path & nom
    oShellLink.WindowStyle = 1
    oShellLink.save
    If Dir(ThisWorkbook.Path & nom) = "" Then MsgBox "chemin fichier origine ok" 'ok
    If Dir(chemin & nom) = "" Then 'chemin sans le fichier
        MsgBox "Aucun raccourci n'a été créé."
    Else
        MsgBox "Le raccourci a été créé et placé sur le bureau."
    End If
End Sub

Sinon, j'expliquerais qu'il faut parcourir, mais çà fait pas pro.
Merci

[Valtrase]

Re,
Déjà cela serait bien d'être un peu plus strict dans tes déclarations. Cela t'évitera des bourdes...
Comme si bien dit par Jean-Philippe il te faut :

• Le nom du raccourci
• Le dossier du raccourci.
• Le chemin vers lequel il doit pointé. Si tu veux le chemin du classeur qui lance la macro c'est ThisWorkbook.FullName.

Après ce n'est juste que de la mise en place.
Ci dessous une fonction avec deux paramètre

• ShortcutName : Nom du raccourci sans l'extension.
• ShortcutPath : Répertoire où doit être créé le raccourci, si omis créé sur le bureau .
• TargetFullName : Chemin complet de la cible, si omis ThisWorkbook est pris par défaut.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
Public Function createShortcut(Optional ByVal ShortcutName As String, Optional ByVal ShortcutPath As String, Optional ByVal TargetFullName As String) As Variant   
    On Error GoTo Catch
 
    Dim WshShell As Object
    Set WshShell = CreateObject("WScript.Shell")
 
    If ShortcutPath = vbNullString Then
        ShortcutPath = WshShell.SpecialFolders("Desktop")
        createShortcut = -1
    Else
        If Dir(ShortcutPath, vbDirectory) = vbNullString Then
            createShortcut = "Le chemin de destination du raccourci n'est pas un chemin valide"
            GoTo Catch
        Else
            createShortcut = -1
        End If
    End If
 
    If ShortcutName = vbNullString Then
        ShortcutName = "Réparation gest piéces V multipostes"
    Else
        If Right$(ShortcutName, 1) = "." Then ShortcutName = Left$(ShortcutName, Len(ShortcutName) - 1)
    End If
 
    If TargetFullName = vbNullString Then
        TargetFullName = ThisWorkbook.FullName
        createShortcut = -1
    Else
        If Dir(TargetFullName, vbNormal) = vbNullString Then
            createShortcut = "La cible du raccourci n'est pas une cible valide."
            GoTo Catch
        Else
            createShortcut = -1
        End If
    End If
 
    Dim MyShortcut As Object
    Set MyShortcut = WshShell.createShortcut(ShortcutPath & IIf(Right$(ShortcutPath, 1) = "\", vbNullString, "\") & ShortcutName & ".lnk")
    With MyShortcut
        .TargetPath = TargetFullName & "\\"
        .Save
    End With
 
Catch:
    If Err.Number > 0 Then
        createShortcut = Err.Description
    End If
 
    If Not WshShell Is Nothing Then Set WshShell = Nothing
    If Not MyShortcut Is Nothing Then Set MyShortcut = Nothing
End Function

Et pour le test :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Public Sub TestShortcut()    Dim Result As Variant
    ' // Ceci renverra une erreur
    'Result = createShortcut("D:\Utilisateurs\Valtrase\Desktop")
 
    ' // Ici création du raccourci sur le bureau pour ThisWorkBook
    Result = createShortcut
 
    Select Case Result
        Case Is = -1
            MsgBox "Le raccourci a été créé avec succès"
        Case Else
            MsgBox "Oupss... nous avons rencontré un problème en créant le raccourci : " & vbNewLine & Result
    End Select
End Sub

Edit:
Je change le nom de la fonction puisque l'on a la possibilité d'enregistrer ailleurs que sur le bureau

[Franc]

Salut Valtrase,
Merci pour la réponse.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Sub raccBuro()
    Dim nom, f, WshShell, strDesktop, oShellLink, chemin
    '2 fois le fichier,téléch drive et pas de macros
    nom = "Réparation gest piéces V multipostes"
    chemin = "C:\Users\fpair\OneDrive\Bureau\"  'ThisWorkbook.Path
    Set WshShell = CreateObject("WScript.Shell")
    Set oShellLink = WshShell.CreateShortcut(chemin & nom & ".lnk")  'ici titre du raccourci**
    'Set oShellLink = WshShell.CreateShortcut(GetAppPath & nom & ".lnk")
    oShellLink.TargetPath = ThisWorkbook.Path & nom
    oShellLink.WindowStyle = 1
    oShellLink.Save
    If Dir(chemin & nom) = "" Then
        MsgBox "Aucun raccourci n'a été créé."
        MsgBox chemin & nom
    Else
        MsgBox "Le raccourci a été créé et placé sur le bureau."
    End If
End Sub

Cà installe le raccourci toujours pareil, sans extension.
et le test du chemin n'est pas bon
Cdt

Salut, j'ai testé ta macro et elle fonctionne parfaitement. Simplement, nom doit désigner le fichier et pas le raccourci.
Donc oShellLink.TargetPath = ThisWorkbook.Path & "Classeur1.xlsm" par exemple.

[frunch]

Bonjour,
Merci pour vos réponses.
C'est bon pour Valtrase.
Il manque juste les commentaires, donc j'ai rajouté les miens avec quelques questions , à voir donc.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
Public Function createShortcutOnDesktop(Optional ByVal ShortcutName As String, Optional ByVal ShortcutPath As String, Optional ByVal TargetFullName As String) As Variant   
    On Error GoTo Catch 'plus bas ok
 
    Dim WshShell As Object ' c'est quoi WshShell ?
    Set WshShell = CreateObject("WScript.Shell") ' WScript.Shell  'c quoi le script ?
 
 's'il n'y a pas de chemin, alors SpecialFolders("Desktop") ' SpecialFolders ?
    If ShortcutPath = vbNullString Then
        ShortcutPath = WshShell.SpecialFolders("Desktop")
        createShortcutOnDesktop = -1 '-1 ? on fait koi là ?
    Else
'si le chemin du dossier n'existe pas, alors on le crée
        If Dir(ShortcutPath, vbDirectory) = vbNullString Then
            createShortcutOnDesktop = "Le chemin de destination du raccourci n'est pas un chemin valide" 
            GoTo Catch 
        Else
            createShortcutOnDesktop = -1
        End If
    End If
 'si le nom du raccourci n'existe pas, alors on le nomme.
    If ShortcutName = vbNullString Then
        ShortcutName = "Réparation gest piéces V multipostes"
    Else
 ' s'il y a un point à la fin du nom du raccourci, alors shortcutname = le nom avant le point
        If Right$(ShortcutName, 1) = "." Then ShortcutName = Left$(ShortcutName, Len(ShortcutName) - 1)
    End If
 'si le chemin complet n'existe pas, alors on prend celui de thisworkbook
    If TargetFullName = vbNullString Then
        TargetFullName = ThisWorkbook.FullName
        createShortcutOnDesktop = -1 
    Else
      'si le chemin complet n'existe pas, on annonce
        If Dir(TargetFullName, vbNormal) = vbNullString Then
            createShortcutOnDesktop = "La cible du raccourci n'est pas une cible valide."
            GoTo Catch 
        Else
            createShortcutOnDesktop = -1 
        End If
    End If
 
    Dim MyShortcut As Object
    'creation du raccourci. S'il y a un \ en 1er, on l'enlève, sinon on le met.
    Set MyShortcut = WshShell.createShortcut(ShortcutPath & IIf(Right$(ShortcutPath, 1) = "\", vbNullString, "\") & ShortcutName & ".lnk")
    With MyShortcut
     'rajout de \\ au chemin complet
        .TargetPath = TargetFullName & "\\"
        .Save
    End With
 
Catch:
    If Err.Number > 0 Then
        createShortcutOnDesktop = Err.Description ' késako ?
    End If
 'si wshshell existe alors on l'enléve
    If Not WshShell Is Nothing Then Set WshShell = Nothing
 'si le raccourci existe, on l'enleve
    If Not MyShortcut Is Nothing Then Set MyShortcut = Nothing
End Function

A plus

[Valtrase]

Re,
Hé bé y'a du boulot ...

' c'est quoi WshShell ?

C'est un objet j'aurais pu le nommer MaCommandeScript

' WScript.Shell 'c quoi le script ?

Modèle objet hôte de script Windows | Microsoft Learn

's'il n'y a pas de chemin, alors SpecialFolders("Desktop") ' SpecialFolders ?

C'est toi qui voulais mettre le raccourci sur le bureau, donc si pas de chemin définit on le colle sur le bureau.

'si le chemin du dossier n'existe pas, alors on le crée

Non, le chemin est passer en paramètre. Donc inutile de le recréer. c'est le code qui appelle la fonction qui doit créer le chemin.

'si le nom du raccourci n'existe pas, alors on le nomme.

Idem que le commentaire juste avant.

' s'il y a un point à la fin du nom du raccourci, alors shortcutname = le nom avant le point

Oui tout à fait ça. Cela peut être mieux géré.

'si le chemin complet n'existe pas, alors on prend celui de thisworkbook

Tous les paramètres de la fonction sont optionnels. Donc oui s'il nest pas stipuler en paramètre alors on prends le chemin du classeur.

'creation du raccourci. S'il y a un \ en 1er, on l'enlève, sinon on le met.

Pas en premier mais à la fin. Afin d'éviter un double slash qui renverrait une erreur sur la commande Dir.

'si wshshell existe alors on l'enléve

Un habitude que j'ai pris car si l'objet est à Nothing alors si tu fait Set WshShell = Nothing c'est l'erreur assuré.
Donc en fait on décharge la mémoire, Certains diront que ce n'est pas nécessaire mais je préfère, qui peut le plus peut le moins.


Un petit edit sur le code :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
With MyShortcut
    'rajout de \\ au chemin complet
    .TargetPath = TargetFullName
    .Save
EndWith

J'ai ajouter le & "\\" pour mes tests donc il faut le supprimer.

[frunch]

Ok merci Valtrase pour la solution, les explications et le lien, et merci aux autres contributeurs.
A bientôt surement