Bonjour, bonsoir,

J'ai trouvé ce code sur le forum qui permet de protéger un dossier sur une clé usb avec un mot de passe. Cependant lors de la procédure d'installation une fenêtre Internet Explorer s'ouvre avec les deux champs pour choisir son mot de passe mais ne réagit pas lorsque je clique sur "Envoyer". Des messages d'erreurs s'affichent

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
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
Call checkUSB()
Titre="Protection du Dossier Private dans le Flash USB © Hackoo"
Set fso = CreateObject("Scripting.FileSystemObject")
Set Ws = CreateObject("Wscript.Shell")
Set dc = fso.Drives
	For Each d in dc
	If d.IsReady  and d.DriveType = 1 Then
	NumSerie=dc(d + "\").SerialNumber
    RacineUSB = d.Driveletter
	MsgBox "Votre Lecteur Flash est le " &RacineUSB&":\",64,Titre
	MsgBox "La Clé Usb inséré a comme Num° de Série "&NumSerie,64,"Vérification Clé Usb © Hackoo"
'Titre=" Private Dossier © Hackoo © 2012 "
strDirectory = RacineUSB&":\Private"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Desktop = RacineUSB&":\Private\desktop.ini"
MDP = RacineUSB&":\Private\MDP.txt"
 If objFSO.FileExists(Desktop) or objFSO.FileExists(MDP) Then
 Call InputPassword
 Else
 Call Setup_Password()
end if
		end if
	Next	
 
Sub checkUSB
strComputer = "."
On Error Resume Next
Set WshShell = CreateObject("Wscript.Shell")
beep = chr(007)
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.ExecQuery("Select * from Win32_DiskDrive WHERE InterfaceType='USB'",,48)
intCount = 0
For Each drive In colItems
    If drive.mediaType <> "" Then
        intCount = intCount + 1
    End If
Next
If intCount > 0 Then
    MsgBox "Votre Clé USB Personnelle est bien Connectée !",64,"Flash Drive Check © Hackoo!"
else
	WshShell.Run "cmd /c @echo " & beep, 0
	wscript.sleep 1000
	MsgBox "Votre Clé USB Personnelle n'est pas Connectée !" &VbCrlf&_
	"Veuillez SVP la brancher puis réexécuter ce VBScript de nouveau !"&VbCrlf&_
	"Merci !",48,"Flash Drive Check © Hackoo !"
	wscript.Quit
End If
End Sub
 
Sub WriteDesktopINI
Set objFSO = CreateObject("Scripting.FileSystemObject")
'strDirectory ="C:\Private"
strFile = "\desktop.ini"
strText = "[.ShellClassInfo]" & vbCrLf & "CLSID={21EC2020-3AEA-1069-A2DD-08002B30309D}"'"{645FF040-5081-101B-9F08-00AA002F954E}"<======>'clé systeme indiquant le dossier protègé est comme la Corbeille
'Set objFile = objFSO.CreateTextFile(strDirectory & strFile)
Set objTextFile = objFSO.OpenTextFile(strDirectory & strFile,2,True)
objTextFile.WriteLine(strText)
objTextFile.Close
End Sub
 
Sub Hide()
Set WS = CreateObject("WScript.Shell")
com="cmd /c attrib +h +s "&strDirectory&""
com1="cmd /c type nul > \\?\"&strDirectory&"\lpt3.Dossier_protégé"
Result = Ws.Run(Com,0,True)
Result1 = Ws.Run(Com1,0,True)
End Sub
 
Sub Setup_Password()
Dim Ws,Password,MDP,LireMDP
Set Ws = CreateObject("Wscript.Shell")
'Set FSO = CreateObject("Scripting.FileSystemObject")
'strDirectory ="C:\Private"
If Not FSO.FolderExists(strDirectory) Then
FSO.CreateFolder (strDirectory)
end if
MDP = strDirectory&"\MDP.txt"
 
VIDE=True
While VIDE
If Password="" Then
  Set colItems = GetObject("winmgmts:root\cimv2").ExecQuery("Select ScreenHeight, ScreenWidth from Win32_DesktopMonitor Where ScreenHeight Is Not Null And ScreenWidth Is Not Null") 
     For Each objItem in colItems 
        intHorizontal = objItem.ScreenWidth
        intVertical = objItem.ScreenHeight
    Next 
   On error resume next
    Dim objExplorer : Set objExplorer = WScript.CreateObject("InternetExplorer.Application", "IE_")
    With objExplorer
        .Navigate "about:blank"  
        .ToolBar = 0
        '.Left = (intVertical+intHorizontal+700) / 2
        '.Top = (intVertical+intHorizontal+570) / 2
        .StatusBar = 0
        .Width = 370
        .Height = 280
        .Visible = 1   
        .Resizable = 0	
		.MenuBar = 0
		'.ScrollBar = 0
        .Document.Title = "Setup du Mot de Passe © Hackoo ******"
        Dim strHTML : strHTML = "<center><h3 style='color:Red'>Choisissez Votre Mot de Passe</h3>"
		strHTML = strHTML &"<body bgcolor='#FFFFD2' scroll='no'>"
        strHTML = strHTML & "<input type='password' name='txt_Password1' size='30'>"
		strHTML = strHTML & "<h3 style='color:Red'>Retapez Votre Mot de Passe</h3>"
		strHTML = strHTML & "<input type='password' name='txt_Password2' size='30'><br>"
        strHTML = strHTML & "<br><button type='submit' style='font-familc:\privateVerdana;font-size:14px;height:30px;Width:180px;' id='btn_Exit' onclick=" & Chr(34)& "VBScript:me.Value='Enregistrement....'" & Chr(34)& " title='Enregistrement....'>Envoyer</button></body></center>"
       .Document.Body.InnerHTML = strHTML
	   .Document.Body.Style.overflow = "auto"
	   .Document.body.style.backgroundcolor="lightblue"
 
    End With
    Do While (objExplorer.Document.All.btn_Exit.Value = "Envoyer")
        Wscript.Sleep 250
    Loop
	Password1=objExplorer.document.GetElementByID("txt_Password1").Value
	Password2=objExplorer.document.GetElementByID("txt_Password2").Value
If Password1 = Password2 and Password1 = "" Then
MsgBox "Le mot passe choisi est vide !"& vbcr &_
"Veuillez SVP Choisir un Mot de Passe non vide "& vbcr &_
"Merci !"& vbcr & vbcr &_
"The password chosen is empty !"& vbcr &_
"Please choose a password is not empty "& vbcr &_
"Thanks !",48,"Mot de Passe vide © Hackoo ******************"
end if
If Password1 = Password2 and Password1 <> "" Then
    Password = objExplorer.document.GetElementByID("txt_Password2").Value
    PasswordCrypt = Scramble(Password,2012)
Set objTextFile = FSO.OpenTextFile(MDP,2,True)
objTextFile.WriteLine(passwordCrypt)
objTextFile.Close
Call AutoCopy2Flash
MsgBox "Votre Mot de Passe Crypté est: " & PasswordCrypt & vbcr&_
    "Encrypted Password is: "& PasswordCrypt ,64,"Mot de Passe Crypté"	
Msgbox "VOTRE MOT DE PASSE EN CLAIR EST  ""{"&Password&"}""  SAUVEGARDER LE BIEN ! C'EST LE SEUL MOYEN POUR DEBLOQUER LE DOSSIER Private !" &vbcr&vbcr&_
	"YOUR PASSWORD IS IN CLEAR ""{"& Password &"}"" SAVE IT IN A GOOD PLACE ! THIS IS THE ONLY WAY TO UNLOCK THE FILE Private !",64,"MOT DE PASSE INSTALLE Hackoo © 2012 !"
	else
	MsgBox "Les deux mots de passe ne sont pas identiques !" & vbcr & vbcr &_
	"The two passwords do not match !",16,"Mot de Passe Erroné © Hackoo ****************"
	end if
    If Password <>"" Then 
      VIDE=False
       Call WriteDesktopINI
	   Call Hide()
	   Call Autorun()
	   Call AutoCopy2Flash()
 MsgBox "Le Dossier Private est désormais créé et protégé avec succès ! et vous pouvez copier vos dossiers et vos fichiers dans ce dernier pour les protéger !"& vbcr & vbcr &_
 "Folder Private Created and Protected Sucessfully ! and of course you can copy your folders and files in it to protect them !",64,Titre
    End if 
End if
objExplorer.Quit
Set objExplorer = Nothing
Wend
Call InputPassword()
end sub
'--------------------------------InputPassword-------------------------
Sub InputPassword()
Const ForWriting = 2
Const ForAppending = 8
Dim Ws,Password,MDP,itemtype,LireMDP
Titre=" Private Dossier © Hackoo © 2012 "
Set Ws = CreateObject("Wscript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
MDP = strDirectory&"\MDP.txt"
 
Set colItems = GetObject("winmgmts:root\cimv2").ExecQuery("Select ScreenHeight, ScreenWidth from Win32_DesktopMonitor Where ScreenHeight Is Not Null And ScreenWidth Is Not Null") 
 
    For Each objItem in colItems 
        intHorizontal = objItem.ScreenWidth
        intVertical = objItem.ScreenHeight
    Next 
 On error resume next  
    Dim objExplorer : Set objExplorer = WScript.CreateObject("InternetExplorer.Application", "IE_")
    With objExplorer
        .Navigate "about:blank"  
        .ToolBar = 0
        .Left = (intHorizontal-300) / 2
        .Top = (intVertical-300) / 2
        .StatusBar = 0
        .Width = 320
        .Height = 190
        .Visible = 1   
        .Resizable = 0	
		.MenuBar = 0
		'.ScrollBar = 0
        .Document.Title = "Mot de Passe © Hackoo ************** "
        Dim strHTML : strHTML = "<center><h3 style='color:Red'>Entrez Votre Mot de Passe</h3>"
		strHTML = strHTML &"<body bgcolor='#FFFFD2' scroll='no'>"
        strHTML = strHTML & "<input type='password' name='txt_Password' size='30'><br>"
        strHTML = strHTML & "<br><button type='submit' style='font-familc:\privateVerdana;font-size:14px;height:30px;Width:180px;' id='btn_Exit' onclick=" & Chr(34)& "VBScript:me.Value='AUTENTIFICATION...'" & Chr(34)& " title='Vérifier le mot de passe...'>Envoyer</button></body></center>"
       .Document.Body.InnerHTML = strHTML
	   .Document.Body.Style.overflow = "auto"
	   .Document.body.style.backgroundcolor="lightblue"
 
    End With
    Do While (objExplorer.Document.All.btn_Exit.Value = "Envoyer")
        Wscript.Sleep 250
    Loop
    Password = objExplorer.document.GetElementByID("txt_Password").Value
Set objTextFile = FSO.OpenTextFile(MDP,1,True)
LireMDP = objTextFile.ReadLine
objTextFile.Close
	objExplorer.Quit
	Set objExplorer = Nothing
 
If  FSO.FileExists(MDP) Then
	 LireMDP = Scramble(LireMDP,-2012)
If Password = LireMDP then
Question = MsgBox ("Voulez-vous accéder à votre Dossier protégé ? " &vbcr &_
"Do you want to access your protected folder ?",VBYesNO+VbQuestion,Titre)
 If Question = VbYes then
 Call Delete_Desktop()
	 Explorer(strDirectory)
	 else
       Call WriteDesktopINI
	   Call Hide()
	   Call Autorun()
	   Call AutoCopy2Flash
 end if
else
       Call WriteDesktopINI
	   Call Hide()
	   Call Autorun()
	   Call AutoCopy2Flash
   Msgbox "MOT DE PASSE INCORRECT ET PERMISSION REFUSEE D'ACCEDER A CE DOSSIER !" & vbCr & vbCr &_
	"PASSWORD INCORRECT AND PERMISSION DENIED TO ACCESS TO THIS FOLDER !",16,"MOT DE PASSE INCORRECT Hackoo © 2012 !"
end if
end if
end sub
'--------------------Fin du InputPassword-------------
 
Function Explorer(Dir)
    Set ws=CreateObject("wscript.shell")
    ws.run "Explorer.exe "& Dir & "\"
end Function
 
 
Sub Delete_Desktop()
Set objFSO = CreateObject("Scripting.FileSystemObject")
desktop = strDirectory&"\desktop.ini"
If objFSO.FileExists(desktop) Then
    objFSO.DeleteFile desktop, True
end if
end sub
 
Function Scramble (strText, lngSeed)
     Dim L,intRand,bytASC
     '---- Force seeded random mode 
     Rnd(-1)
     '---- Set (positive) seed 
     Randomize ABS(lngSeed)
     '---- Scan through string
     For L = 1 To Len(strText)
         '---- Get ASC of char
         bytASC=Asc(Mid(strText, L))
         '---- Fix for quotes (tilde to quote)
         If bytASC=126 then bytASC=34
         '---- Add a random value from -80 to 80, encode\decode is decided by the seed's sign
         intRand = bytASC + ((Int(Rnd(1) * 160) - 80) * SGN(lngSeed)) 
         '---- Cycle char between 32 and 125 (with carry)
         If intRand <= 31 Then 
             intRand = 125 - (31 - intRand)
         ElseIf intRand >= 126 Then
             intRand = 32 + (intRand - 126)
         End If
         '---- Fix for quotes (quote to tilde)
         If intRand=34 then intRand=126
          '---- Output string
         Scramble = Scramble & Chr(intRand)
     Next
 End Function
 
Sub AutoRun()
NomScript = WScript.ScriptName
Set auto = fso.CreateTextFile(RacineUSB&":\AutoRun.inf", True)
auto.Write "[autorun]"& vbcrlf & "shellexecute=wscript.exe "& NomScript & vbcrlf & "shell\open=Ouvrir"
auto.Write vbcrlf & "shell\Open\Command= wscript "& NomScript & vbCrLf & "shell\open\Default=1" & vbcrlf & "shell\explore=Explorer" & vbcrlf & "shell\explore\Command= wscript "& NomScript
auto.Close
Set tf1=fso.getfile(RacineUSB&":\AutoRun.inf")
tf1.Attributes = 32
End Sub
 
Sub AutoCopy2Flash
Monscript = WScript.ScriptFullName
cible = RacineUSB &":\"
if (not fso.fileexists(cible & Monscript)) then
		fso.copyfile Monscript ,cible, True
		end if
End sub
Messages d'erreurs :
Nom : 1418548561-capture.png
Affichages : 344
Taille : 290,9 Ko
Nom : 1418548558-capture2.png
Affichages : 340
Taille : 34,0 Ko

Les messages d'erreurs n'apparaissent pas quand je clique sur "Envoyer" mais de base, et forment une boucle quand sur "Ok".


En espérant que vous pourrez m'aider,
almagros