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.

[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.