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
| Option Explicit
Dim bPasswordBoxWait,bPasswordBoxOkay
Dim Titre,fso,ws,dc,d,NumSerie,RacineUSB,strDirectory,Desktop,MDP
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 Numero de Série "& NumSerie,64,"Vérification Clé Usb © Hackoo"
strDirectory = RacineUSB&":\Private"
Set FSO = CreateObject("Scripting.FileSystemObject")
Desktop = RacineUSB &":\Private\desktop.ini"
MDP = RacineUSB &":\Private\MDP.txt"
If FSO.FileExists(Desktop) or FSO.FileExists(MDP) Then
Call InputPassword
Else
Call Setup_Password()
end if
end if
Next
'**************************************************************************************************************************************************************************
Function Setup_Password()
Dim Password1,Password2,FSO
Dim Ws,Password,MDP,LireMDP,PasswordCrypt,objTextFile
Set Ws = CreateObject("Wscript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
If Not FSO.FolderExists(strDirectory) Then
FSO.CreateFolder(strDirectory)
end if
MDP = strDirectory &"\MDP.txt"
'La valeure = True ==> en plein écran = FullScreen
'La valeure = False ==> Taille réduite
Password1 = PasswordBox("Veuillez taper votre mot de passe pour la 1ère fois",False)
Password2 = PasswordBox("Veuillez re-taper encore votre mot de passe pour la 2ème fois",False)
If Password1 = Password2 and Password1 <> "" Then
Setup_Password = Password2
Password = Setup_Password
PasswordCrypt = Scramble(Password,2015)
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 "& RacineUSB &":\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 © 2015 !"
Call WriteDesktopINI
Call Hide()
wscript.sleep 3000
Call InputPassword()
Else
MsgBox "Les deux mots de passe ne correspondent pas",VbCritical,"Les deux mots de passe ne correspondent pas"
Call Setup_Password()
End if
End Function
'**************************************************************************************************************************************************************************
Function PasswordBox(sTitle,FullScreen)
Dim oIE
set oIE = CreateObject("InternetExplorer.Application")
With oIE
If FullScreen = True Then
.FullScreen = True
Else
.FullScreen = False
End if
.ToolBar = False : .RegisterAsDropTarget = False
.StatusBar = False : .Navigate("about:blank")
.Resizable = False
While .Busy : WScript.Sleep 100 : Wend
With .document
.Title = "Veuillez taper votre mot de passe * * * * * * * * * * * * *"
With .ParentWindow
.resizeto 450,120
.moveto .screen.width/2-200, .screen.height/2-50
End With
.WriteLn("<html><title>Veuillez taper votre mot de passe * * * * * * * * * * * * * * * *</title><body text=white bgColor=DarkOrange><center>")
.WriteLn(sTitle)
.WriteLn("<input type=password id=pass>" & _
"<input type=Submit id=but0 value=Envoyer>")
.WriteLn("</center></body></html>")
With .ParentWindow.document.body
.scroll="no"
.style.borderStyle = "outset"
.style.borderWidth = "1px"
End With
.all.but0.onclick = getref("PasswordBox_Submit")
.all.pass.focus
oIE.Visible = True
bPasswordBoxOkay = False : bPasswordBoxWait = True
On Error Resume Next
While bPasswordBoxWait
WScript.Sleep 100
if oIE.Visible Then bPasswordBoxWait = bPasswordBoxWait
if Err Then bPasswordBoxWait = False
Wend
PasswordBox = .all.pass.value
End With ' document
.Visible = False
.Quit
End With ' IE
End Function
'**************************************************************************************************************************************************************************
Sub PasswordBox_Submit()
bPasswordBoxWait = False
End Sub
'**************************************************************************************************************************************************************************
Function Explorer(Dir)
Set ws=CreateObject("wscript.shell")
ws.run "Explorer.exe "& Dir & "\"
end Function
'**************************************************************************************************************************************************************************
Sub AutoCopy2Flash
Dim Monscript,cible
Monscript = WScript.ScriptFullName
cible = RacineUSB &":\"
if (not fso.fileexists(cible & Monscript)) then
fso.copyfile Monscript ,cible, True
end if
End sub
'**************************************************************************************************************************************************************************
Sub Delete_Desktop()
Dim objFSO,desktop
Set objFSO = CreateObject("Scripting.FileSystemObject")
desktop = strDirectory&"\desktop.ini"
If objFSO.FileExists(desktop) Then
objFSO.DeleteFile desktop, True
end if
end sub
'**************************************************************************************************************************************************************************
Sub WriteDesktopINI
Dim objFSO,strFile,strText,objTextFile
Set objFSO = CreateObject("Scripting.FileSystemObject")
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 objTextFile = objFSO.OpenTextFile(strDirectory & strFile,2,True)
objTextFile.WriteLine(strText)
objTextFile.Close
End Sub
'**************************************************************************************************************************************************************************
Sub Hide()
Dim WS,com,com1,Result,Result1
Set WS = CreateObject("WScript.Shell")
com="cmd /c attrib +h +s "& strDirectory &""
com1="cmd /c type nul > \\?\"& strDirectory &"\lpt3.Dossier_by_Hackoo"
Result = Ws.Run(Com,0,True)
Result1 = Ws.Run(Com1,0,True)
End Sub
'**************************************************************************************************************************************************************************
Sub CheckUSB()
Dim strComputer,WshShell,beep,objWMIService,colItems,intCount,drive
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
'**************************************************************************************************************************************************************************
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
'**************************************************************************************************************************************************************************
'--------------------------------InputPassword-------------------------
Sub InputPassword()
Const ForWriting = 2
Const ForAppending = 8
Dim Ws,Password,MDP,LireMDP,Titre,FSO,objTextFile
Titre =" Private Dossier © Hackoo © 2015 "
Set Ws = CreateObject("Wscript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
MDP = strDirectory &"\MDP.txt"
Password = PasswordBox("Mot de passe pour accéder à votre espace privé",False)
Set objTextFile = FSO.OpenTextFile(MDP,1,True)
LireMDP = objTextFile.ReadLine
objTextFile.Close
If FSO.FileExists(MDP) Then
LireMDP = Scramble(LireMDP,-2015)
If Password = LireMDP then
Call Delete_Desktop()
Explorer(strDirectory)
Else
Call WriteDesktopINI
Call Hide()
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,Titre
end if
end if
end sub
'--------------------Fin du InputPassword-------------
'**************************************************************************************************************************************************************************
Function Explorer(Dir)
Set ws=CreateObject("wscript.shell")
ws.run "Explorer.exe "& Dir & "\"
end Function
'************************************************************************************************************************************************************************** |
Problème code pour protéger un dossier d'une clé usb avec mot de passe
Répondre avec citation
Partager