LNK Raccourcis - "Exécuter en tant qu'administrateur"

Invité · 06/08/2014, 12h07

Bonjour à tous!

Voici le problème :

dans C:\ProgramData\Microsoft\Windows\Start Menu\Programs, j'ai une série de raccourcis!
Lors du déclanchement, une fenêtre "d'avertissement de sécurité" apparaît :

Nom : _RunAsAdmin_1.jpg
Affichages : 1642
Taille : 42,8 Ko

Nom : _RunAsAdmin_1.jpg
Affichages : 1642
Taille : 42,8 Ko

En fait, il s'agit de cocher l'option "Exécuter en tant qu'administrateur" pour éliminer le message!

Venant au fait!
Le but est d'automatiser l'opération de tous les raccourcis contenu dans C:\ProgramData\Microsoft\Windows\Start Menu\Programs et les sous-dossiers.

J'ai deux fichiers :
01.vbs (scanne l'arborescence à la recherche de fichier type LNK)
02.vbs (coche la case "Exécuter en tant qu'administrateur)

Le problème est le suivant :
Tous les chemins et nom de fichier avec des espaces ne fonctionne pas!

j'ai trouvé cette information suivante pour le traitement avant l'envoie en argument

http://stackoverflow.com/questions/1...sing-arguments

c'est sur ce point que je séche...

voici les deux fichiers

--> 01.vbs

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
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
 
 
'strStartFolder = "C:\ProgramData\Microsoft\Windows\Start Menu\Programs"
strStartFolder = "C:\TMP"
 
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set wshShell = CreateObject("WScript.Shell")
 
intCounter = 2
 
' Création de l'objet Feuille Excel
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Set objWB = objExcel.Workbooks.Add
Set objSheet = objWB.Sheets(1)
 
' configuration des colonnes Excel
objSheet.Cells(1, 1).Value = "Chemin"
objSheet.Cells(1, 2).Value = "Nom Fichier"
 
' Configuration des largeurs des colonnes Excel
objSheet.Columns(1).ColumnWidth = 150
objSheet.Columns(2).ColumnWidth = 75
objSheet.Columns(3).ColumnWidth = 30
 
' Configuration de la feuille Excel
objSheet.Range("A1:B1").Font.Bold = True
objSheet.Range("A1:B1").Interior.ColorIndex = 1 'Black
objSheet.Range("A1:B1").Interior.Pattern = 1 'xlSolid
objSheet.Range("A1:B1").Font.ColorIndex = 44 'Gold
 
objSheet.Range("A2").Select
 
' Si sous-dossier existe alors communique la variable à la fonction ShowSubFolders
If objFSO.FolderExists(strStartFolder) Then
	ShowSubFolders objFSO.GetFolder(strStartFolder)			
End If
 
' Liste tout fichier LNK contenu dans l'arborescence du dossier racine contenu dans la variable "strStartFolder"
Sub ShowSubFolders(objFolder)
 
	For Each objFile In  objFolder.Files
		' Enumère tous les fichiers ShortCut LNK
		If InStr(1, ".lnk", Lcase(Right(objFile.Name,4))) <> 0 Then
		Wscript.Echo "Nom du Raccourci --> objfile.name : " & objfile.name
 
			' Chemin complet du raccourci
			LNKPath = objFolder.Path & "\"
			LNKFull = objFolder.Path & "\" & objFile.Name
			'Wscript.Echo "Chemin complet : " & LNKFull
 
 
			LNKName = objfile.name
			'Wscript.Echo "LNKName : " & LNKName
 
			objSheet.Cells(intCounter, 1).Value = LNKFull
			objSheet.Cells(intCounter, 2).Value = objFile.Name
			intCounter = intCounter + 1
 
			arglist = ""
			With WScript.Arguments
				For Each arg In .Named
					arglist = arglist & " /" & arg & ":" & qq(.Named(arg))
					Wscript.Echo "arglist : " & arglist
				Next
				For Each arg In .Unnamed
					arglist = arglist & " " qq(arg)
				Next
	End With
			CreateObject("WScript.Shell").Run "02.vbs " & Trim(LNKPath) & Trim(LNKname), 0, True
 
 
		End If
	Next
 
    For Each objSubfolder In objFolder.SubFolders
        ShowSubFolders objSubfolder
    Next
End Sub
 
Sub qq(str)
  qq = Chr(34) & str & Chr(34)
End Sub
 
' L'objet WSCript.Arguments permet de connaitre les éventuels arguments passées au script lors
'de son exécution. 
 
' Les balises Named et UnNamed, dont le rôle esr d'indiquer les paramètres attendus pour un script wsf,
'sont à utiliser au sein d'une balise RunTime, elle-même placée dans une balise Job
 
' http://books.google.fr/books?id=Iy8nLi_EDWoC&pg=PT215&lpg=PT215&dq=With+WScript.Arguments&source=bl&ots=AoWRl3x7xW&sig=azZLwDmMdrrjnZB1CiTgw6MLlKk&hl=fr&sa=X&ei=QtzhU8W-JPHP4QSHg4Ao&ved=0CDsQ6AEwAw#v=onepage&q=With%20WScript.Arguments&f=false

--> 02.vbs

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
59
60
61
62
63
64
65
66
67
68
69
 
 
Option Explicit
 
Dim oArgs, ret
 
Set oArgs = WScript.Arguments
If oArgs.Count > 0  Then
    ret = fSetRunAsOnLNK(oArgs(0))
    'MsgBox "Done, return = " & ret
Else
    MsgBox "No Args"
End If
 
Function fSetRunAsOnLNK(byVal sInputLNK)
    Wscript.Echo "Argument venant de 01.VBS -- sInputLNK  --> : " & vbCrLf & vbCrLf & sInputLNK
	Dim fso, wshShell, oFile, iSize, aInput(), ts, i, ExtractFileName, ExtractFolderName, MyNumber
 
		' Récupérer uniquement le Nom fichier et son extension
		If InStr(sInputLNK, "\") = 0 Or Right(sInputLNK, 1) = "\" Then
			ExtractFileName = ""
		End If
		ExtractFileName = Mid(sInputLNK, InStrRev(sInputLNK, "\") + 1)	
		'Wscript.Echo "ExtractFileName --> Uniquement Nom Fichier LNK  : " & vbCrLf & vbCrLf & ExtractFileName
 
		' Récupérer uniquement le Chemin d'accés du fichier
		If InStr(sInputLNK, "\") = 1 Or right(sInputLNK, 1) = "\" Then
			ExtractFolderName = ""
		End If
		ExtractFolderName = Left(sInputLNK, InStrRev(sInputLNK, "\"))
		'Wscript.Echo "ExtractFolderName --> Uniquement Chemin Absolu : " & vbCrLf & vbCrLf & ExtractFolderName
 
	Set fso = CreateObject("Scripting.FileSystemObject")
    Set wshShell = CreateObject("WScript.Shell")
 
    If Not fso.FileExists(ExtractFileName) Then fSetRunAsOnLNK = 114017 : Exit Function
    Set oFile = fso.GetFile(sInputLNK)
	'Wscript.Echo "oFile : " & oFile
    iSize = oFile.Size
	'Wscript.Echo "iSize : " & iSize
    ReDim aInput(iSize)
    Set ts = oFile.OpenAsTextStream()
 
    i = 0
    Do While Not ts.AtEndOfStream
        aInput(i) = ts.Read(1)
        i = i + 1
    Loop
    ts.Close
 
    If UBound(aInput) < 50 Then fSetRunAsOnLNK = 114038 : Exit Function
	' ASC = Retourne le code de caractère ANSI correspondant à la première lettre d'une chaîne
    If (Asc(aInput(21)) And 32) = 0 Then 
        aInput(21) = Chr(Asc(aInput(21)) + 32)
		MyNumber = Asc("aInput")
		'Wscript.Echo "ASC : " & MyNumber
	Else
        fSetRunAsOnLNK = 99 : Exit Function
    End If
 
    fso.CopyFile ExtractFileName, wshShell.ExpandEnvironmentStrings(ExtractFolderName & oFile.Name & "." & Hour(Now()) & "-" & Minute(Now()) & "-" & Second(Now()))
    On Error Resume Next
    Set ts = fso.CreateTextFile(ExtractFileName, True)
    If Err.Number <> 0 Then fSetRunAsOnLNK = Err.number : Exit Function
    ts.Write(Join(aInput, ""))
    If Err.Number <> 0 Then fSetRunAsOnLNK = Err.number : Exit Function
    ts.Close
    fSetRunAsOnLNK = 0
End Function

merci d'avance de votre aide et proposition

Invité · 06/08/2014, 15h39

Pour finir, j'ai mis les deux deux fichier en un seul est unique :

ce qui donne :

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
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
 
 
'strStartFolder = "C:\ProgramData\Microsoft\Windows\Start Menu\Programs"
strStartFolder = "C:\TMP"
 
Dim test1
 
 
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set wshShell = CreateObject("WScript.Shell")
 
intCounter = 2
 
' Création de l'objet Feuille Excel
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = true
Set objWB = objExcel.Workbooks.Add
Set objSheet = objWB.Sheets(1)
 
' configuration des colonnes Excel
objSheet.Cells(1, 1).Value = "Chemin"
objSheet.Cells(1, 2).Value = "Nom Fichier"
 
' Configuration des largeurs des colonnes Excel
objSheet.Columns(1).ColumnWidth = 100
objSheet.Columns(2).ColumnWidth = 55
objSheet.Columns(3).ColumnWidth = 30
 
' Configuration de la feuille Excel
objSheet.Range("A1:B1").Font.Bold = True
objSheet.Range("A1:B1").Interior.ColorIndex = 1 'Black
objSheet.Range("A1:B1").Interior.Pattern = 1 'xlSolid
objSheet.Range("A1:B1").Font.ColorIndex = 44 'Gold
 
objSheet.Range("A2").Select
 
' Scanne et si sous-dossier existe, alors communique la valeur variable à la fonction ShowSubFolders
If objFSO.FolderExists(strStartFolder) Then
	ShowSubFolders objFSO.GetFolder(strStartFolder)			
End If
 
' Liste tout fichier LNK contenu dans l'arborescence du dossier racine contenu dans la variable "strStartFolder"
Sub ShowSubFolders(objFolder)
 
	For Each objFile In  objFolder.Files
		' Enumère tous les fichiers ShortCut LNK
		If InStr(1, ".lnk", Lcase(Right(objFile.Name,4))) <> 0 Then
		'Wscript.Echo "objfile.name --> Nom du Raccourci LNK : " & objfile.name
 
			' Chemin complet du raccourci
			LNKPath = objFolder.Path & "\"
			LNKFull = objFolder.Path & "\" & objFile.Name
			'Wscript.Echo "Chemin complet : " & LNKFull
 
			LNKName = objfile.name
			'Wscript.Echo "LNKName : " & LNKName
 
			objSheet.Cells(intCounter, 1).Value = LNKFull
			objSheet.Cells(intCounter, 2).Value = objFile.Name
			intCounter = intCounter + 1
 
			fSetRunAsOnLNK(LNKFull)
			MsgBox "!OK! Option --> 'Exécuter en Tant qu'Administrateur' ACTIVEE "
		End If
	Next
 
    For Each objSubfolder In objFolder.SubFolders
        ShowSubFolders objSubfolder
    Next
End Sub
 
 
Function fSetRunAsOnLNK(byVal sInputLNK)
    Wscript.Echo "Argument transmit de [ShowSubFolders] -- sInputLNK  --> : " & vbCrLf & vbCrLf & sInputLNK
	Dim fso, wshShell, oFile, iSize, aInput(), ts, i, ExtractFileName, ExtractFolderName, MyNumber
 
		' Récupérer uniquement le Nom fichier et son extension
		If InStr(sInputLNK, "\") = 0 Or Right(sInputLNK, 1) = "\" Then
			ExtractFileName = ""
		End If
		ExtractFileName = Mid(sInputLNK, InStrRev(sInputLNK, "\") + 1)	
		'Wscript.Echo "ExtractFileName --> Uniquement Nom Fichier LNK  : " & vbCrLf & vbCrLf & ExtractFileName
 
		' Récupérer uniquement le Chemin d'accés du fichier
		If InStr(sInputLNK, "\") = 1 Or right(sInputLNK, 1) = "\" Then
			ExtractFolderName = ""
		End If
		ExtractFolderName = Left(sInputLNK, InStrRev(sInputLNK, "\"))
		'Wscript.Echo "ExtractFolderName --> Uniquement Chemin Absolu : " & vbCrLf & vbCrLf & ExtractFolderName
 
	Set fso = CreateObject("Scripting.FileSystemObject")
    Set wshShell = CreateObject("WScript.Shell")
 
    If Not fso.FileExists(ExtractFileName) Then fSetRunAsOnLNK = 114017 : Exit Function
    Set oFile = fso.GetFile(sInputLNK)
	Wscript.Echo "oFile : " & oFile
    iSize = oFile.Size
	Wscript.Echo "iSize : " & iSize
    ReDim aInput(iSize)
    Set ts = oFile.OpenAsTextStream()
 
    i = 0
    Do While Not ts.AtEndOfStream
        aInput(i) = ts.Read(1)
        i = i + 1
    Loop
    ts.Close
 
    If UBound(aInput) < 50 Then fSetRunAsOnLNK = 114038 : Exit Function
	' ASC = Retourne le code de caractère ANSI correspondant à la première lettre d'une chaîne
    If (Asc(aInput(21)) And 32) = 0 Then 
        aInput(21) = Chr(Asc(aInput(21)) + 32)
		MyNumber = Asc("aInput")
		Wscript.Echo "ASC : " & MyNumber
	Else
        fSetRunAsOnLNK = 99 : Exit Function
    End If
 
    'fso.CopyFile ExtractFileName, wshShell.ExpandEnvironmentStrings(ExtractFolderName & oFile.Name & "." & Hour(Now()) & "-" & Minute(Now()) & "-" & Second(Now()))
    On Error Resume Next
	' Coche l'option "Exécuter en tant qu'Adminstrateur"
    Set ts = fso.CreateTextFile(ExtractFileName, True)
    If Err.Number <> 0 Then fSetRunAsOnLNK = Err.number : Exit Function
    ts.Write(Join(aInput, ""))
    If Err.Number <> 0 Then fSetRunAsOnLNK = Err.number : Exit Function
    ts.Close
 
    fSetRunAsOnLNK = 0
End Function

Les raccourcis avec ou sans espace (dans le nom) se trouvant dans le même dossier que le vbs sont correctement traités.
Par contre, les raccourcis se trouvant dans un sous dossier ne sont pas traités!

je pense que cela vient de cette partie :

Code :

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

1
2
3
4
5
6
7
8
 
    If (Asc(aInput(21)) And 32) = 0 Then 
        aInput(21) = Chr(Asc(aInput(21)) + 32)
		MyNumber = Asc("aInput")
		Wscript.Echo "ASC : " & MyNumber
	Else
        fSetRunAsOnLNK = 99 : Exit Function
    End If

je pense qu'il s'agit des attributs de dossier et de fichier!

qu'elle serait la solution pour le traitement des LNK en sous-dossier

Merci d'avance de votre aide

**l_autodidacte** · 07/08/2014, 00h15

Apparemment, il s'agit d'une erreur dans l'ordre des arguments à la ligne 47 qui devrait être :
If InStr(1, Lcase(objFile.Name), ".lnk") > 0 Then en enlevant Right pour parcourir tout le chemin; ou bien
If Lcase(Right(objFile.Name,4))) =".lnk" Then;

A toi de choisir l'un des deux codes.

Invité · 07/08/2014, 15h02

Merci pour votre réponse!

cela ne change rien du fait que le chemin est bien enregistré dans la variable LNKFull dans SUB ShowSubFolders:
Puis bien retransmisse dans la SUB fSetRunAsOnLNK via l'arguments sInputLNK

Les vérification sont faites par les diverses echo de contrôle.

A mon humble avis de débutant, le prob doit venir de cette partie

Code :

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

1
2
3
4
5
6
7
 
' ASC = Retourne le code de caractère ANSI correspondant à la première lettre d'une chaîne
    			If (Asc(aInput(21)) And 32) = 0 Then 
        		aInput(21) = Chr(Asc(aInput(21)) + 32)
						MyNumber = Asc("aInput")
						'Wscript.Echo "ASC : " & MyNumber
					Else

Resumez :

Tous raccourcis dans le répertoire racine [TMP] (strStartFolder = "C:\TMP"), dont le nom soit avec ou sans espace sont bien traiter.
L'option "Exécuter en tant qu'adminstrateur" est activée!

Tous raccourcis se trouvant dans un sous-dossier avec ou sans espace [Dossier001] [Dossier 002], ne sont pas traité!

Le bout de code ce-dessus doit certainement attaquer le poids des dossiers selon leur position dans l'arborescnce!

je sais que l'attribut dossier est 16

merci d'avance pour votre aide...
toujours à la recherche d'info...

Invité · 10/08/2014, 15h38

Voici la solution lorsque :

1. Conception du menu Démarrer :

Nom : 1.jpg
Affichages : 1562
Taille : 103,8 Ko

Configuration du Menu Démarrer dans l'installation automatique AutoUnattend :

- désactiver les parties de Menu 1 - 2 - 4 – 5
- activer les parties de Menu 3 – 6

2. Configuration REG via VBS :

--> $OEM$\$1\LNKs\Install.VBS

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
 
Dim WshShell
Set WshShell = WScript.CreateObject("WScript.Shell")
 
 
'-----------------------------------------------------------
' Ajout du lien "Programmes" dans le Menu Déroulant
'-----------------------------------------------------------
 
WshShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\StartMenuFavorites", 1, "REG_DWORD"
 
WshShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\Favorites", "C:\ProgramData\Microsoft\Windows\Start Menu\Programs", "REG_SZ"
 
WshShell.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Favorites", "C:\ProgramData\Microsoft\Windows\Start Menu\Programs", "REG_EXPAND_SZ"
 
…
 
'------------------------------------------------------------
'                          Kill/Start process Explorer.ExE
'------------------------------------------------------------
strCheminFichier = strCheminDossierScript & "\ReStartExplorer.vbs"
WshShell.Run Chr(34) & strCheminFichier & Chr(34) , 0, True

3. Cocher l'option "Exécuter en tant qu'administrateur"

Les trois fichiers "Setup.vbs" et "RunAsAdmin.vbs" avec "ModRiskFileTypes.REG" permettent de supprimer la venue de la boite de dialogue "Fichier ouvert – Avertissement de sécurité".

Nom : 2.jpg
Affichages : 1385
Taille : 49,6 Ko

Nom : 2.jpg
Affichages : 1385
Taille : 49,6 Ko

Nom : 3.jpg
Affichages : 1519
Taille : 39,2 Ko

Nom : 4.jpg
Affichages : 1350
Taille : 26,5 Ko

Fichier : ModRiskFileTypes.REG

Pour ce faire, il faut commencer par donner l'autorisation d'utilisation de fichier VBS.

Code :

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

1
2
3
4
5
 
Windows Registry Editor Version 5.00
 
[HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Associations]
"ModRiskFileTypes"=".vbs"

Fichier : Setup.vbs

En effet, le fichier "Setup.vbs" référence tous les sous dossiers contenu dans " C:\ProgramData\Microsoft\Windows\Start Menu\Programs" contenant des fichiers raccourcis .LNK. Puis génère un fichier "RunAsAdmin.vbs" dans chacun d'eux.

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
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
 
' ========================================================================================================= '
'  Cette routine permet d'activer l'option avancée "Exécuter en tant qu'administrateur" de raccourcis LNK
'   Il répertorie l'arborescence d'un dossier racine cible  dans  "Chemin_LNK.txt", créer à la racine 
'   Il copie le fichier de traitement "RunAsAdmin.vbs" dans chaqu'un des sous-dossiers.
'  La nouvelle valeur du chemin du sous-dossier sera inscrite dans le fichier de traitement "RunAsAdmin.vbs"
'  Activation de l'option avancée "Exécuter en tant qu'administrateur" de raccourcis LNK via "RunAsAdmin.vbs"
'              Suppression de tous les fichiers RunAsAdmin.vbs + Chemin_VBS.txt + Chemin_LNK.txt
' ========================================================================================================= '
 
Const ForReading = 1
Const ForWriting = 2
Const ForAppending = 8
 
' Dossier racine de l'arborescence
' "C:\ProgramData\Microsoft\Windows\Start Menu\Programs"
strStartFolder = "C:\ProgramData\Microsoft\Windows\Start Menu\Programs"
' Chemin script pour la case "Exécuter en tant qu'administrateur"
RunAsAdmin = "C:\LNKtest\RunAsAdmin.vbs"
 
Set objFSO = CreateObject("Scripting.FileSystemObject")
 
'Creation du futur fichier contenant le chemin complet de chaque *.LNK
outListeLNK="C:\LNKs\Chemin_LNK.txt"
Set objFile = objFSO.CreateTextFile(outListeLNK,True)
objFile.Close
 
'Creation du futur fichier contenant le chemin complet de chaque *.VBS
outListeVBS="C:\LNKs\Chemin_VBS.txt"
Set objFile = objFSO.CreateTextFile(outListeVBS,True)
objFile.Close
 
' Si sous-dossier existe alors communique la variable à la fonction ShowSubFolders
If objFSO.FolderExists(strStartFolder) Then
	ShowSubFolders objFSO.GetFolder(strStartFolder)
	ExecRunAsAdmin objFSO.GetFolder(strStartFolder)	
	DeleteFiles objFSO.GetFolder(strStartFolder)
End If
 
' Liste tout fichier LNK contenu dans l'arborescence du dossier racine
Sub ShowSubFolders(objFolder)
	For Each objFile In  objFolder.Files
		' Enumère tous les fichiers ShortCut LNK
		If InStr(1, ".lnk", Lcase(Right(objFile.Name,4))) <> 0 Then
			' Chemin Uniquement
			LNKPath = objFolder.Path & "\"
			' Chemin Complet avec Nom Fichier LNK
			LNKFull = objFolder.Path & "\" & objFile.Name
			'WScript.Echo "Chemin complet : " & LNKFull
 
			ListeLNK(LNKFull)
			CopieFichier(LNKPath)
		End If
	Next
    For Each objSubfolder In objFolder.SubFolders
        ShowSubFolders objSubfolder
    Next
End Sub
 
Sub ListeLNK(strLNKFull)
			' Ajout les Chemin Complet avec Nom Fichier LNK dans un fichier 
			Set objFile = objFSO.OpenTextFile(outListeLNK, ForAppending)
			objFile.write strLNKFull & vbCrLf
			objFile.Close
End Sub
 
Sub CopieFichier(strLNKPath)
			' Copy le fichier RunAsAdmin.vbs dans chaque sous-dossier et dossier racine
			objFSO.CopyFile RunAsAdmin, strLNKPath
			ActiveRunAsAdmin(strLNKPath)
			'WScript.Echo "Nouveau Chemin Cible complet : " & vbCrLf & vbCrLf & strLNKPath & "RunAsAdmin.vbs"
End Sub
 
Sub ActiveRunAsAdmin(RunAsAdminLNKPath)
' la procédure recherche un mot clef connu dans un fihier puis le remplace par une autre valeur variable -- strNewText --
' ligne effectuant l'oprération -- strNewText = Replace(strText, strOldText, strNewText) --
 
			'WScript.Echo "Nouveau Chemin Cible Uniquement  - RunAsAdminLNKPath : " & vbCrLf & vbCrLf & RunAsAdminLNKPath
			Dim oFSO, rech, Ligne
 
			strNewText = RunAsAdminLNKPath
			'WScript.Echo "Nouveau Chemin Cible Uniquement - strNewText : " & vbCrLf & vbCrLf & strNewText
 
			strFileName = RunAsAdminLNKPath & "RunAsAdmin.vbs"
			'WScript.Echo "Nouveau Chemin Cible et fichier RunAsAdmin.vbs - strfileName : " & vbCrLf & vbCrLf & strfileName
 
			strOldText = "Chemin"
			'WScript.Echo "Mot clef à trouver dans le fichier RunAsAdmin.vbs de référence - strOldText : " & vbCrLf & vbCrLf & strOldText
 
			Set objFSO = CreateObject("Scripting.FileSystemObject")
 
			' Si fichier non existant, alors stop
			If objFSO.FileExists(strFileName) = False Then Wscript.Quit
 
			Set objFile = objFSO.OpenTextFile(strFileName, ForReading)
				rech = 0
				While Not objFile.AtEndOfStream
					Ligne = objFile.ReadLine
					' Recherche la présence strOldText et combien de fois
					If Instr(Ligne, strOldText) <> 0 Then rech = rech + 1
				Wend
				'WScript.Echo "Mot clef à trouvé " & vbCrLf & vbCrLf & rech & "x" & vbCrLf & vbCrLf & "dans le fichier"
 
			objFile.Close
 
			Set objFile = objFSO.OpenTextFile(strFileName, ForReading)
			strText = objFile.ReadAll
			objFile.Close
 
			strNewText = Replace(strText, strOldText, strNewText)
			Set objFile = objFSO.OpenTextFile(strFileName, ForWriting)
			objFile.Write strNewText
			objFile.Close
End Sub
 
Sub ExecRunAsAdmin(strRacine)
		'WScript.Echo "strRacine : " & strRacine
	For Each objFile In  strRacine.Files
		' Enumère tous les fichiers RunAsAdmin.vbs
		If InStr(1, "RunAsAdmin.vbs", Lcase(Right(objFile.Name,8))) <> 0 Then
			' Chemin Uniquement
			LNKPath = strRacine.Path & "\"
			' Chemin Complet avec Nom Fichier LNK
			LNKFull = strRacine.Path & "\" & objFile.Name
			'WScript.Echo "Chemin complet0 : " & LNKFull
			'WScript.Echo "Chemin complet1 : " & Chr(34) & LNKFull &  Chr(34)
 
			ListeVBS(LNKFull)
 
			Set WshShell = CreateObject("WScript.Shell")
			WshShell.Run chr(34) & LNKFull & chr(34), 0, True
		End If
	Next
    For Each objSubfolder In strRacine.SubFolders
        ExecRunAsAdmin objSubfolder
    Next
End Sub
 
Sub ListeVBS(strLNKFull)
			' Ajout les Chemin Complet avec Nom Fichier VBS dans un fichier 
			Set objFile = objFSO.OpenTextFile(outListeVBS, ForAppending)
			objFile.write strLNKFull & vbCrLf
			objFile.Close
End Sub
 
Sub DeleteFiles(strRacine1)
	'WScript.Echo "strRacine1 : " & strRacine1
	For Each objFile In  strRacine1.Files
		' Suppression de tous fichiers RunAsAdmin.vbs
		If InStr(1, "RunAsAdmin.vbs", Lcase(Right(objFile.Name,8))) <> 0 Then
			' Chemin Uniquement
			LNKPath = strRacine1.Path & "\"
			' Chemin Complet avec Nom Fichier LNK
			LNKFull = strRacine1.Path & "\" & objFile.Name
			'WScript.Echo "Chemin complet0 : " & LNKFull
 
			objFSO.DeleteFile LNKFull
		End If
 
		' Suppression Chemin_LNK.txt
		If (objFSO.FileExists(outListeLNK)) Then
			objFSO.DeleteFile outListeLNK
		End If
 
		' Suppression Chemin_VBS.txt
		If (objFSO.FileExists(outListeVBS)) Then
			objFSO.DeleteFile outListeVBS
		End If
	Next
 
    For Each objSubfolder In strRacine1.SubFolders
        DeleteFiles objSubfolder
    Next
End Sub

Fichier : RunAsAdmin.vbs

Son rôle est d'activer la case "Exécuter en tant qu'administrateur" pour chaque raccourci référencé.

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
 
========================================================================================================= '
'
'
'  Cette routine permet d'activer l'option avancée "Exécuter en tant qu'administrateur" de raccourcis LNK
'
'
' ========================================================================================================= '
 
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set wshShell = CreateObject("WScript.Shell")
 
Dim oFile, iSize, aInput(), ts, i
 
'strStartFolder = "C:\ProgramData\Microsoft\Windows\Start Menu\Programs"
strStartFolder = "Chemin"
set objFolder = objFSO.GetFolder(strStartFolder)
'WScript.Echo "NOm du chemin cible uniquement : " & strStartFolder
 
' Liste tout fichier LNK contenu dans le dossier 
' Assigne l'attribut "Exécuter en tant qu'administrateur"
 
	For Each objFile In  objFolder.Files
		' Enumère tous les fichiers ShortCut LNK
 
		If InStr(1, ".lnk", Lcase(Right(objFile.Name,4))) <> 0 Then
 
			'Wscript.Echo "Nom du Raccourci : " & objfile.name
			LNKName = objfile.name
			'Wscript.Echo "LNKName : " & LNKName
			FullPath = strStartFolder & LNKName
			'Wscript.Echo "FullPath : " & strStartFolder & LNKName
 
			Set oFile = objFSO.GetFile(FullPath)
			iSize = oFile.Size
			ReDim aInput(iSize)
			Set ts = oFile.OpenAsTextStream()
			i = 0
			Do While Not ts.AtEndOfStream
				aInput(i) = ts.Read(1)
				i = i + 1
			Loop
			ts.Close
			' --> Assigne l'attribut "Exécuter en tant qu'administrateur"
			If (Asc(aInput(21)) And 32) = 0 Then 
				aInput(21) = Chr(Asc(aInput(21)) + 32)
			Else
			End If
 
			Set ts = objFSO.CreateTextFile(FullPath, True)
			ts.Write(Join(aInput, ""))
			ts.Close
 
		End If
	Next

au plaisir de partager!
a+

LNK Raccourcis - "Exécuter en tant qu'administrateur"

VBScript

Discussions similaires

Partager

Partager