Ce petit modules permet de simplifier la création de raccourci et d'obtenir facillement les
répertoirs spéciaux (bureau,menu démarrer,...)
Pratique pour une installation
Source / Exemple :
'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
Conclusion :
Si il y a un problème laissez un commentaire.
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.