CRÉE UN RACCOURCI ET OBTENIR LES REPÉRTOIRE SPÉCIAUX DE WINDOWS

'Petit modules qui simpifie la creation de raccourci et l'obtention des rep spéciaux
'par Pierre Fersing pierre.fersing@wandoo.fr le 12/07/02

Function GetSpecialFolder(FolderName) ' si on met as string ca marche pas ??????
'donne le chemin d'un répertoir spécial à partire de son nom ou de son ID

'Liste de repértoire spéciaux:
'Nom               : ID

'AllUsersDesktop   :0
'AllUsersStartMenu :1
'AllUsersPrograms  :2
'AllUsersStartup   :3
'Desktop           :4 10    Si qqun c'est pourquoi il y a deux ID pour desktop
'AppData           :5
'PrintHood         :6
'Templates         :7
'Fonts             :8
'NetHood           :9
'StartMenu         :11
'SendTo            :12
'Récent            :13
'Startup           :14
'Favorites         :15
'MyDocuments       :16
'Programs          :17

'Merci à Fbrt pour cette liste
'Normalement il n'y en a pas plus car un nombre plus petit que 0 ou plus grande que 17
'ca fait planté

Dim WSHShell As Object
Set WSHShell = CreateObject("WScript.Shell")
GetSpecialFolder = WSHShell.SpecialFolders(FolderName)
End Function

Sub MakeShortCut(ShortcutName As String, Target As String, Optional WorkingDirectory As 

String, Optional WindowsStyle As Integer = 4, Optional IconName As String, Optional 

IconIndex As Integer = 0)
'Fonction qui Crée un raccourci
'ShortcutName : Nom complet du raccourcie (ex: c:\windows\bureau\link.lnk)
'Target       : La cible du raccourcie (ex: c:\dev\asm\nasm\nasmide.exe)
'WorkingDirectory: Répertoire d'exécution, par defaut le répertoire contenant l'exécutable 

(ex: c:\dev\asm\src)
'WindowsStyle : Comment est affiché le programme: normal,reduit,agrandi... Par defaut: 

normal (comme pour shell en VB ex:4 = normal)
'IconName     : Chemin d'acces de l'icone, par default l'icone de l'exécutable cible (si 

non aucun) ( ex: c:\dev\asm.ico)
'IconIndex    : L'index de l'icone dans le fichier

'Merci à VBfrance pour les forum sur lequel j'ai trouvé ce que je cherchais
'et à Oliver68 qui a posté le message dont j'avais besoin sur le forum

'si il n'y a le .lnk à la fin on l'ajoute
If Right(ShortcutName, 4) <> ".lnk" Then ShortcutName = ShortcutName & ".lnk"

'If IsMissing(WorkingDirectory) Then  ca ne marche pas! Et je sais pas pourquoi. Si qqun 

sait, qu'il me le fasse savoir
If WorkingDirectory = "" Then
    'Valeur par defaut pour le repértoire de travail: le répertoire de l'exécutable
    Dim i As Integer, j As Integer
    i = 1
    Do
        j = i + 1
        i = InStr(j, Target, "\") ' on cherche un \
    Loop Until i = 0                    ' jusqu'a ce qu'il n'y en ait plus
    'j est la valeur de la position après du dernier \
    'on prend tout ce qu'il y a avant le dernier \ et on en ajoute un à la fin
    WorkingDirectory = Mid(Target, 1, j - 2) & "\"
End If

If IconName = "" Then
    'Si un n'y a pas d'icone, on prend l'icone de l'exécutable cible ou rien
    IconName = Target
End If

Dim WSHShell 'Pour Crée le raccourci et pour optenir les répertoir Spéciaux
Dim Shortcut 'notre raccourcie


Set WSHShell = CreateObject("WScript.Shell") ' on crée un objet Shell

' Création d'un objet raccourci
Set Shortcut = WSHShell.CreateShortcut(ShortcutName)
' Paramétrage du raccourci
'ExpandEnvironmentStrings permet de mettre des chose comme %windir%
Shortcut.TargetPath = WSHShell.ExpandEnvironmentStrings(Target)
Shortcut.WorkingDirectory = WSHShell.ExpandEnvironmentStrings(WorkingDirectory)
Shortcut.WindowStyle = WindowsStyle
Shortcut.IconLocation = WSHShell.ExpandEnvironmentStrings(IconName & " , " & IconIndex)

Shortcut.Save
End Sub