Raccourci sur bureau

Version imprimable

1 pièce(s) jointe(s)

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

Code:

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.
Pièce jointe 648629
Donc il doit y avoir un loupé quelque part.
Merci

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

Citation:

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:

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:

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:

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

Salut Valtrase,
Merci pour la réponse.

Code:

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

03/01/2024, 20h57
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 ?
03/01/2024, 21h02
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.
03/01/2024, 21h31
Valtrase

Et donc tu endends quoi là :

Citation:

Cà installe le raccourci toujours pareil, sans extension.
03/01/2024, 21h34
frunch

1 pièce(s) jointe(s)

Comme çà, et quand on doubleclique dessus on a le message...
Pièce jointe 648696
03/01/2024, 21h52
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

1 pièce(s) jointe(s)

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. :mouarf:
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:

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
Pièce jointe 648710

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

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:

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:

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

Citation:

Envoyé par frunch

Salut Valtrase,
Merci pour la réponse.

Code:

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.

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 :lol:, à voir donc. :help: :toutcasse:

Code:

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

04/01/2024, 15h25
Valtrase
Re,
Hé bé y'a du boulot ...

Citation:

' c'est quoi WshShell ?

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

Citation:

' WScript.Shell 'c quoi le script ?

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

Citation:

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

Citation:

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

Citation:

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

Idem que le commentaire juste avant.

Citation:

' 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é.

Citation:

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

Citation:

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

Citation:

'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:

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. :roll:
05/01/2024, 07h56
frunch

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