Faid's Blog™: August 2012

Friday, August 31, 2012

Make Folder Locker from HTA (HTML Application)

Previously I've talked about making a VBS folder locker, now I make a version of HTML Application (HTA), just copy code below into notepad and save it as "*.HTA" extension (ex."Locker.hta"), and then double click it and enjoy,,, if some problem found in my HTA, please fix it,,, if you run the HTA for first time, you'll asked to make new folder and new password...

code:

<html><head><title>Folder Locker</title>
<script language='VBScript'>Window.MoveTo Screen.Width,Screen.Height</script>
<hta:application
applicationname="folder-locker"
version="5.7.9.5"
border="thin"
borderstyle="normal"
icon="Locker.ico"
innerborder="no"
maximizebutton="no"
minimizebutton="no"
scroll="no"
selection="no"
singleinstance="yes"/>
<style type='text/css'>td{text-align:center;};</style>
<meta http-equiv='MSThemeCompatible' content='yes'/>
<body id='OnScr' leftMargin='0' topMargin='0'/>
<script language='VBScript'>
On Error Resume Next
Dim CBtn,FileFolder,FolderName,HsfReg,LockFolder,NameFile,ObjFSO,PassFile,WshShell
Set ObjFSO=CreateObject("Scripting.FileSystemObject")
Set WshShell=CreateObject("WScript.Shell")
FileFolder="\     "
LockFolder=FileFolder&"\ "
NameFile=FileFolder&"\  "
PassFile=FileFolder&"\   "
HsfReg="HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\ShowSuperHidden"
If ObjFSO.FileExists(NameFile) Then FolderName=Decrypt(ObjFSO.OpenTextFile(NameFile,1,True,True).ReadLine)

If ObjFSO.FolderExists(FileFolder) Then ObjFSO.GetFolder(FileFolder).Attributes=39
If ObjFSO.FolderExists(LockFolder) Then ObjFSO.GetFolder(LockFolder).Attributes=39
If ObjFSO.FileExists(NameFile) Then ObjFSO.GetFile(NameFile).Attributes=39
If ObjFSO.FileExists(PassFile) Then ObjFSO.GetFile(PassFile).Attributes=39
If WshShell.RegRead(HsfReg)<>"0" Then WshShell.RegWrite(HsfReg),"0","REG_DWORD"

If Not ObjFSO.FolderExists(FolderName) And Not ObjFSO.FolderExists(LockFolder) Then
CBtn="Window.Close" : Call nF()
ElseIf Not ObjFSO.FileExists(PassFile) Then CBtn="Window.Close" : Call pS()
ElseIf ObjFSO.FolderExists(LockFolder) Then CBtn="mM()" : Call uL()
ElseIf ObjFSO.FolderExists(FolderName) Then CBtn="mM()" : Call mM()
End If

Function Clean(Text)
On Error Resume Next
Chars=Array("\","/",":","*","?","""","<",">","|")
For Each Replaced In Chars
Text=Replace(Text,Replaced,"")
Next
Clean=Text
End Function

Function Decrypt(Text)
On Error Resume Next
For I=1 To Len(Text)
X=Mid(Text,I,1)
Tmp=Tmp&ChrW(AscW(X)-(50+I))
Next
Decrypt=Tmp
End Function

Function Encrypt(Text)
On Error Resume Next
For I=1 To Len(Text)
X=Mid(Text,I,1)
Tmp=Tmp&ChrW(AscW(X)+(50+I))
Next
Encrypt=Tmp
End Function

Sub InnerWindowSize(IntWidth,IntHeight)
On Error Resume Next
Window.ResizeTo IntWidth,IntHeight
Window.ResizeTo IntWidth+(IntWidth-Document.Body.OffsetWidth),IntHeight+(IntHeight-Document.Body.OffsetHeight)
Window.MoveTo ((Screen.Width-IntWidth)/2),((Screen.Height-IntHeight)/2)
End Sub

Sub Lock()
On Error Resume Next
Dim FolderName
FolderName=Decrypt(ObjFSO.OpenTextFile(NameFile,1,True,True).ReadLine)
ObjFSO.MoveFolder(FolderName),(LockFolder)
ObjFSO.GetFolder(LockFolder).Attributes=39
If ObjFSO.FolderExists(FolderName) Then
MsgBox "Unable to Lock folder."&vbNewLine&"Save all data and close all applications that use this folder, then try again.",16,"Folder Locker"
Exit Sub
End If
MsgBox "Folder locked successfully",64,"Folder Locker"
Window.Close
End Sub

Sub MakeFolder()
On Error Resume Next
Dim NewName
NewName=NameFolder.Value
If (NewName)<>"" Then
NewName=Clean(NewName)
If Not ObjFSO.FolderExists(FileFolder) Then
ObjFSO.CreateFolder(FileFolder)
ObjFSO.GetFolder(FileFolder).Attributes=39
End If
If Not ObjFSO.FolderExists(NewName) Then
ObjFSO.CreateFolder(NewName)
Else
MsgBox "Unable to make a new folder."&vbNewLine&"Folder with same name is already exist in this directory."&vbNewLine&"Try another name.",16,"Folder Locker"
NameFolder.Select
Exit Sub
End If
If Not ObjFSO.FolderExists(NewName) Then
MsgBox "Unable to make a new folder",16,"Folder Locker"
NameFolder.Select
Exit Sub
End If
If ObjFSO.FileExists(NameFile) Then
ObjFSO.GetFile(NameFile).Attributes=0
ObjFSO.DeleteFile(NameFile),True
End If
ObjFSO.CreateTextFile(NameFile,True,True).Write(Encrypt(NewName))
ObjFSO.GetFile(NameFile).Attributes=39
MsgBox "Folder created successfully",64,"Folder Locker"
Call pS()
Else
MsgBox "Folder Name can't be empty !!!",48,"Folder Locker"
NameFolder.Select
Exit Sub
End If
End Sub

Sub mM()
On Error Resume Next
OnScr.InnerHTML="<table height='234px' width='200px' cellspacing='0' cellpadding='0'>"_
&"<tr bgcolor='#346e99' height='45px'><td><font color='#ffffff' size='+2' face='verdana,arial,helvetica,sans-serif'>MAIN MENU</font></td></tr>"_
&"<tr bgcolor='#bbbfff'><td><button style='height:25px;width:165px' onclick='Lock()'>Lock Folder</button><p/>"_
&"<button style='height:25px;width:165px' onclick='rN()'>Rename Folder</button><p/>"_
&"<button style='height:25px;width:165px' onclick='pS()'>Change Password</button><p/>"_
&"<button style='height:25px;width:165px' onclick='Window.Close'>Exit</button>"_
&"</td></tr></table>"
Call InnerWindowSize(200,234)
End Sub

Sub nF()
On Error Resume Next
OnScr.InnerHTML="<table height='116px' width='242px' bgcolor='#ffffff'>"_
&"<tr><td><center><text>Type new folder name</text><br/><input type='text' id='NameFolder' size='30' maxlength='50'><p/>"_
&"<button type='submit' style='width:85px' onclick='MakeFolder()'>Create</button> "_
&"<button style='width:85px' onclick='Window.Close'>Cancel</button></center></td></tr>"
Call InnerWindowSize(242,116)
NameFolder.Select
End Sub

Sub Password()
On Error Resume Next
Dim Password1,Password2
Password1=NewPassword.Value
Password2=VerifyPassword.Value
On Error Resume Next
If (Password1)<>"" And (Password2)="" Then VerifyPassword.Select : Exit Sub : End If
If (Password1)<>"" And (Password2)<>"" Then
If (Password1)=(Password2) Then
If ObjFSO.FileExists(PassFile) Then
ObjFSO.GetFile(PassFile).Attributes=0
ObjFSO.DeleteFile(PassFile),True
End If
ObjFSO.CreateTextFile(PassFile,True,True).Write(Encrypt(Password2))
ObjFSO.GetFile(PassFile).Attributes=39
MsgBox "New password has been saved",64,"Folder Locker"
CBtn="mM()"
Call mM()
Else
MsgBox "Password doesn't match !!!",16,"Folder Locker"
NewPassword.Value=""
VerifyPassword.Value=""
NewPassword.Select
Exit Sub
End If
Else
MsgBox "Password can't be empty !!!",48,"Folder Locker"
NewPassword.Select
Exit Sub
End If
End Sub

Sub pS()
On Error Resume Next
OnScr.InnerHTML="<table height='160px' width='242px' bgcolor='#ffffff'>"_
&"<tr><td><text>Type new password</text><br/><input type='password' id='NewPassword' size='30'><br/>"_
&"<text>Re-type new password</text><br/><input type='password' id='VerifyPassword' size='30'><p/>"_
&"<button type='submit' style='width:85px' onclick='Password()'>Save</button> "_
&"<button style='width:85px' onclick='"&CBtn&"'>Cancel</button></td></tr>"
Call InnerWindowSize(242,160)
NewPassword.Select
End Sub

Sub Rename()
On Error Resume Next
Dim FolderName,NewName
FolderName=Decrypt(ObjFSO.OpenTextFile(NameFile,1,True,True).ReadLine)
NewName=NameFolder.Value
If (NewName)<>"" Then
NewName=Clean(NewName)
If ObjFSO.FolderExists(NewName) Then
MsgBox "Unable to rename folder."&vbNewLine&"Folder with same name is already exist in this directory."&vbNewLine&"Try another name.",16,"Folder Locker"
NameFolder.Select
Exit Sub
End If
ObjFSO.MoveFolder(FolderName),(NewName)
If Not ObjFSO.FolderExists(NewName) Then
MsgBox "Unable to rename folder",16,"Folder Locker"
NameFolder.Select
Exit Sub
Else
If ObjFSO.FileExists(NameFile) Then
ObjFSO.GetFile(NameFile).Attributes=0
ObjFSO.DeleteFile(NameFile),True
End If
ObjFSO.CreateTextFile(NameFile,True,True).Write(Encrypt(NewName))
ObjFSO.GetFile(NameFile).Attributes=39
MsgBox "Folder renamed successfully",64,"Folder Locker"
Call mM()
End If
Else
MsgBox "Folder name can't be empty !!!",48,"Folder Locker"
NameFolder.Select
Exit Sub
End If
End Sub

Sub rN()
On Error Resume Next
OnScr.InnerHTML="<table height='116px' width='242px' bgcolor='#ffffff'>"_
&"<tr><td><text>Type new name for your folder</text><br/><input type='text' id='NameFolder' size='30' maxlength='50'><p/>"_
&"<button type='submit' style='width:85px' onclick='Rename()'>Rename</button> "_
&"<button style='width:85px' onclick='mM()'>Cancel</button></td></tr>"
Call InnerWindowSize(242,116)
NameFolder.Select
End Sub

Sub uL()
On Error Resume Next
OnScr.InnerHTML="<table height='116px' width='242px' bgcolor='#ffffff'>"_
&"<tr><td><text>Type password to unlock folder</text><br/><input type='password' id='PasswordInput' size='30'><p/>"_
&"<button type='submit' style='width:85px' onclick='Unlock()'>Unlock</button> "_
&"<button style='width:85px' onclick='Window.Close'>Cancel</button></td></tr>"
Call InnerWindowSize(242,116)
PasswordInput.Select
End Sub

Sub Unlock()
On Error Resume Next
Dim Pass,UserPassword
Pass=PasswordInput.Value
If (Pass)<>"" Then
UserPassword=Decrypt(ObjFSO.OpenTextFile(PassFile,1,True,True).ReadLine)
If Not (Pass)=(UserPassword) Then
MsgBox "Wrong password !!!",16,"Folder Locker"
PasswordInput.Value=""
PasswordInput.Select
Exit Sub
Else
If ObjFSO.FolderExists(FolderName) Then
MsgBox "Unable to unlock folder",48,"Folder Locker"
Window.Close
Else
ObjFSO.GetFolder(LockFolder).Attributes=9
ObjFSO.MoveFolder(LockFolder),(FolderName)
MsgBox "Folder unlocked successfully",64,"Folder Locker"
WshShell.Run(""".\"&FolderName&"\""")
Window.Close
End If
End If
Else
MsgBox "Empty password !!!",48,"Folder Locker"
PasswordInput.Select
Exit Sub
End If
End Sub
</script></head></html>

Wednesday, August 1, 2012

Membuat Folder Locker dari Visual Basic Script (VBS)

Sebelumnya ane udah membahas soal "Membuat Folder Locker dari BATCH", nah, sekarang ane buat yang baru nih, kali ini bukan bahasa BATCH yang digunakan, tetapi bahasa Visual Basic Script (VBS),,, tetapi mungkin masih banyak kesalahan pengeditan, soalnya ane juga masih awam dalam bahasa VBScript, kalo ada yang nemu kesalahan tolong di fix ya, Ok, langsung aja, pertama2 copass semua script di bawah ini ke notepad, lalu save dengan extensi "*.VBS", caranya setelah nulis di notepad pilih save as, terus tambahin .vbs dibelakang nama file, dan ubah formatnya menjadi all files, lalu save deh...

code:

ON ERROR RESUME NEXT
DIM FileFolder,FolderName,LockFolder,NameFile,ObjFSO,PassFile
SET ObjFSO=CreateObject("Scripting.FileSystemObject")
FileFolder="\C2F41D69-E2A7-5795-89B40080"
LockFolder=FileFolder&"\D4E221D2-3A5B-1069-52CF0600"
NameFile=FileFolder&"\E85D24D8-98F5-68C0-B28A0100"
PassFile=FileFolder&"\F69CD1E2-B5C3-21A7-A94E0070"
FolderName=ObjFSO.OpenTextFile(NameFile,1).ReadLine
CALL Decrypt(FolderName)
IF ObjFSO.FolderExists(FileFolder) THEN ObjFSO.GetFolder(FileFolder).attributes=39
IF ObjFSO.FolderExists(LockFolder) THEN ObjFSO.GetFolder(LockFolder).attributes=39
IF ObjFSO.FileExists(NameFile) THEN ObjFSO.GetFile(NameFile).attributes=39
IF ObjFSO.FileExists(PassFile) THEN ObjFSO.GetFile(PassFile).attributes=39
CreateObject("WScript.Shell").RegWrite "HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\ShowSuperHidden",0,"REG_DWORD"
IF NOT ObjFSO.FolderExists(FolderName) AND NOT ObjFSO.FolderExists(LockFolder) THEN
CALL MakeFolder()
ELSE
IF NOT ObjFSO.FileExists(PassFile) THEN CALL NewPass()
END IF
IF ObjFSO.FolderExists(LockFolder) THEN
CALL VerifyUser()
CALL Unlock()
END IF
IF ObjFSO.FolderExists(FolderName) THEN CALL Menu()

SUB MakeFolder()
ON ERROR RESUME NEXT
DIM NewName
NewName=InputBox("Tulis nama untuk folder baru Anda :","Folder Locker")
IF IsEmpty(NewName) THEN WScript.Quit
IF (NewName)<>"" THEN
IF NOT ObjFSO.FolderExists(FileFolder) THEN
ObjFSO.CreateFolder(FileFolder)
ObjFSO.GetFolder(FileFolder).attributes=39
END IF
IF NOT ObjFSO.FolderExists(NewName) THEN
ObjFSO.CreateFolder(NewName)
ELSE
IF(MsgBox("Gagal membuat folder baru."&vbNewLine&"Folder dengan nama yang sama sudah ada di direktori ini."&vbNewLine&"Coba nama yang lain.",21,"Folder Locker"))=4 THEN
CALL MakeFolder()
ELSE
WScript.Quit
END IF
END IF
IF NOT ObjFSO.FolderExists(NewName) THEN
IF (MsgBox("Gagal membuat folder baru."&vbNewLine&"Beberapa karakter tidak benar.",21,"Folder Locker"))=4 THEN
CALL MakeFolder()
ELSE
WScript.Quit
END IF
END IF
IF ObjFSO.FileExists(NameFile) THEN
ObjFSO.GetFile(NameFile).attributes=0
ObjFSO.DeleteFile(NameFile),TRUE
END IF
CALL Encrypt(NewName)
ObjFSO.CreateTextFile(NameFile,TRUE).Write(NewName)
ObjFSO.GetFile(NameFile).attributes=39
MsgBox "Folder berhasil dibuat",64,"Folder Locker"
CALL NewPass()
WScript.Quit
ELSE
MsgBox "Nama folder tidak boleh kosong !!!",48,"Folder Locker"
CALL MakeFolder()
END IF
END SUB

SUB Rename()
ON ERROR RESUME NEXT
DIM NewName
NewName=InputBox("Tulis nama baru untuk folder Anda :","Folder Locker")
IF IsEmpty(NewName) THEN CALL Menu()
IF (NewName)<>"" THEN
IF ObjFSO.FolderExists(NewName) THEN
IF (MsgBox("Gagal mengubah nama folder."&vbNewLine&"Folder dengan nama yang sama sudah ada di direktori ini."&vbNewLine&"Coba nama yang lain.",21,"Folder Locker"))=4 THEN
CALL Rename()
ELSE
CALL Menu()
END IF
END IF
ObjFSO.MoveFolder(FolderName),(NewName)
IF NOT ObjFSO.FolderExists(NewName) THEN
IF (MsgBox("Gagal mengubah nama folder",21,"Folder Locker"))=4 THEN
CALL Rename()
ELSE
CALL Menu()
END IF
ELSE
IF ObjFSO.FileExists(NameFile) THEN
ObjFSO.GetFile(NameFile).attributes=0
ObjFSO.DeleteFile(NameFile),TRUE
END IF
CALL Encrypt(NewName)
ObjFSO.CreateTextFile(NameFile,TRUE).Write(NewName)
ObjFSO.GetFile(NameFile).attributes=39
FolderName=ObjFSO.OpenTextFile(NameFile,1).ReadLine
CALL Decrypt(FolderName)
MsgBox "Berhasil mengubah nama folder",64,"Folder Locker"
CALL Menu()
END IF
ELSE
MsgBox "Nama folder tidak boleh kosong !!!",48,"Folder Locker"
CALL Rename()
END IF
END SUB

SUB VerifyUser()
ON ERROR RESUME NEXT
DIM PASS,UserPassword
PASS=InputBox("Masukkan sandi Anda untuk membuka folder :","Folder Locker")
IF IsEmpty(PASS) THEN WScript.Quit
IF (PASS)<>"" THEN
UserPassword=ObjFSO.OpenTextFile(PassFile,1).ReadLine
CALL Decrypt(UserPassword)
IF NOT (PASS)=(UserPassword) THEN
IF (MsgBox("Sandi salah !!!",21,"Folder Locker"))=4 THEN
CALL VerifyUser()
ELSE
WScript.Quit
END IF
END IF
ELSE
MsgBox "Sandi kosong !!!",48,"Folder Locker"
CALL VerifyUser()
END IF
END SUB

SUB Unlock()
ON ERROR RESUME NEXT
IF ObjFSO.FolderExists(FolderName) THEN
MsgBox "Gagal membuka folder",48,"Folder Locker"
WScript.Quit
ELSE
ObjFSO.GetFolder(LockFolder).attributes=9
ObjFSO.MoveFolder(LockFolder),(FolderName)
MsgBox "Folder berhasil dibuka",64,"Folder Locker"
WScript.CreateObject("WScript.Shell").Run("explorer.exe "&FolderName)
WScript.Quit
END IF
END SUB

SUB ChangePass()
ON ERROR RESUME NEXT
DIM Password
Password=InputBox("Masukkan sandi baru :","Folder Locker")
IF IsEmpty(Password) THEN CALL Menu()
IF (Password)<>"" THEN
DIM NewPassword
NewPassword=InputBox("Verifikasi sandi baru Anda :","Folder Locker")
IF IsEmpty(NewPassword) THEN CALL Menu()
IF (NewPassword)=(Password) THEN
CALL Encrypt(NewPassword)
IF ObjFSO.FileExists(PassFile) THEN
ObjFSO.GetFile(PassFile).attributes=0
ObjFSO.DeleteFile(PassFile),TRUE
END IF
ObjFSO.CreateTextFile(PassFile,TRUE).Write(NewPassword)
ObjFSO.GetFile(PassFile).attributes=39
MsgBox "Sandi baru telah disimpan",64,"Folder Locker"
CALL Menu()
ELSE
IF (MsgBox("Sandi tidak cocok !!!",21,"Folder Locker"))=4 THEN
CALL ChangePass()
ELSE
CALL Menu()
END IF
END IF
ELSE
MsgBox "Sandi tidak boleh kosong !!!",48,"Folder Locker"
CALL ChangePass()
END IF
END SUB

SUB NewPass()
ON ERROR RESUME NEXT
DIM Password
Password=InputBox("Masukkan sandi baru :","Folder Locker")
IF IsEmpty(Password) THEN WScript.Quit
IF (Password)<>"" THEN
DIM NewPassword
NewPassword=InputBox("Verifikasi sandi baru :","Folder Locker")
IF IsEmpty(NewPassword) THEN WScript.Quit
IF (NewPassword)=(Password) THEN
CALL Encrypt(NewPassword)
IF ObjFSO.FileExists(PassFile) THEN
ObjFSO.GetFile(PassFile).attributes=0
ObjFSO.DeleteFile(PassFile),TRUE
END IF
ObjFSO.CreateTextFile(PassFile,TRUE).Write(NewPassword)
ObjFSO.GetFile(PassFile).attributes=39
MsgBox "Sandi baru telah disimpan",64,"Folder Locker"
WScript.Quit
ELSE
IF (MsgBox("Sandi tidak cocok !!!",21,"Folder Locker"))=4 THEN
CALL NewPass()
ELSE
WScript.Quit
END IF
END IF
ELSE
MsgBox "Sandi tidak boleh kosong !!!",48,"Folder Locker"
CALL NewPass()
END IF
END SUB

SUB Lock()
ON ERROR RESUME NEXT
ObjFSO.MoveFolder(FolderName),(LockFolder)
ObjFSO.GetFolder(LockFolder).attributes=39
IF ObjFSO.FolderExists(FolderName) THEN
IF (MsgBox("Gagal mengunci folder."&vbNewLine&"Simpan semua data dan tutup semua aplikasi yang menggunakan folder ini, lalu coba lagi.",21,"Folder Locker"))=4 THEN
CALL Lock()
ELSE
CALL Menu()
END IF
END IF
MsgBox "Folder berhasil dikunci",64,"Folder Locker"
WScript.Quit
END SUB

SUB Encrypt(NewPassword)
ON ERROR RESUME NEXT
FOR i=1 TO LEN(NewPassword)
X=MID(NewPassword,i,1)
TMP=TMP & CHR(ASC(X)+50) & CHR(ASC(X)+99)
NEXT
NewPassword=TMP
END SUB

SUB Decrypt(UserPassword)
ON ERROR RESUME NEXT
FOR i=1 TO LEN(UserPassword) STEP 2
X=MID(UserPassword,i,1)
TMP=TMP & CHR(ASC(X)-50)
NEXT
UserPassword=TMP
END SUB

SUB Encrypt(NewName)
ON ERROR RESUME NEXT
FOR i=1 TO LEN(NewName)
X=MID(NewName,i,1)
TMP=TMP & CHR(ASC(X)+50) & CHR(ASC(X)+99)
NEXT
NewName=TMP
END SUB

SUB Decrypt(FolderName)
ON ERROR RESUME NEXT
FOR i=1 TO LEN(FolderName) STEP 2
X=MID(FolderName,i,1)
TMP=TMP & CHR(ASC(X)-50)
NEXT
FolderName=TMP
END SUB

SUB Menu()
ON ERROR RESUME NEXT
DIM Choice
Choice=InputBox("1)  Kunci Folder"&vbNewLine&"2)  Ubah Nama Folder"&vbNewLine&"3)  Ganti Sandi"&vbNewLine&""&vbNewLine&""&vbNewLine&"Masukkan pilihan Anda :","Folder Locker")
IF IsEmpty(Choice) THEN WScript.Quit
IF (Choice)="1" THEN
IF (MsgBox("Kunci folder Anda lalu keluar ?",36,"Folder Locker"))=7 THEN
CALL Menu()
ELSE
CALL Lock()
END IF
END IF
IF (Choice)="2" THEN CALL Rename()
IF (Choice)="3" THEN CALL ChangePass()
MsgBox "Pilihan Salah !!!",16,"Folder Locker"
CALL Menu()
END SUB

Make Folder Locker with Visual Basic Script (VBS)

Previously I've talked about making a batch folder locker, now I make a version of Visual Basic Script (VBS), but my knowledge about VBS less than about BAT, if there are any problems found, please fix it, Ok, let's start, first Copy this script into notepad and save as "*.VBS" extension, ex:"Locker.vbs", after that, run the VBScript file and follow the wizard to make new folder and new password...

code:

ON ERROR RESUME NEXT
DIM FileFolder,FolderName,LockFolder,NameFile,ObjFSO,PassFile
SET ObjFSO=CreateObject("Scripting.FileSystemObject")
FileFolder="\C2F41D69-E2A7-5795-89B40080"
LockFolder=FileFolder&"\D4E221D2-3A5B-1069-52CF0600"
NameFile=FileFolder&"\E85D24D8-98F5-68C0-B28A0100"
PassFile=FileFolder&"\F69CD1E2-B5C3-21A7-A94E0070"
FolderName=ObjFSO.OpenTextFile(NameFile,1).ReadLine
CALL Decrypt(FolderName)
IF ObjFSO.FolderExists(FileFolder) THEN ObjFSO.GetFolder(FileFolder).attributes=39
IF ObjFSO.FolderExists(LockFolder) THEN ObjFSO.GetFolder(LockFolder).attributes=39
IF ObjFSO.FileExists(NameFile) THEN ObjFSO.GetFile(NameFile).attributes=39
IF ObjFSO.FileExists(PassFile) THEN ObjFSO.GetFile(PassFile).attributes=39
CreateObject("WScript.Shell").RegWrite "HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\ShowSuperHidden",0,"REG_DWORD"
IF NOT ObjFSO.FolderExists(FolderName) AND NOT ObjFSO.FolderExists(LockFolder) THEN
CALL MakeFolder()
ELSE
IF NOT ObjFSO.FileExists(PassFile) THEN CALL NewPass()
END IF
IF ObjFSO.FolderExists(LockFolder) THEN
CALL VerifyUser()
CALL Unlock()
END IF
IF ObjFSO.FolderExists(FolderName) THEN CALL Menu()

SUB MakeFolder()
ON ERROR RESUME NEXT
DIM NewName
NewName=InputBox("Type new folder name :","Folder Locker")
IF IsEmpty(NewName) THEN WScript.Quit
IF (NewName)<>"" THEN
IF NOT ObjFSO.FolderExists(FileFolder) THEN
ObjFSO.CreateFolder(FileFolder)
ObjFSO.GetFolder(FileFolder).attributes=39
END IF
IF NOT ObjFSO.FolderExists(NewName) THEN
ObjFSO.CreateFolder(NewName)
ELSE
IF(MsgBox("Unable to make a new folder."&vbNewLine&"Folder with same name is already exist in this directory."&vbNewLine&"Try another name.",21,"Folder Locker"))=4 THEN
CALL MakeFolder()
ELSE
WScript.Quit
END IF
END IF
IF NOT ObjFSO.FolderExists(NewName) THEN
IF (MsgBox("Unable to make a new folder."&vbNewLine&"Some character is invalid.",21,"Folder Locker"))=4 THEN
CALL MakeFolder()
ELSE
WScript.Quit
END IF
END IF
IF ObjFSO.FileExists(NameFile) THEN
ObjFSO.GetFile(NameFile).attributes=0
ObjFSO.DeleteFile(NameFile),TRUE
END IF
CALL Encrypt(NewName)
ObjFSO.CreateTextFile(NameFile,TRUE).Write(NewName)
ObjFSO.GetFile(NameFile).attributes=39
MsgBox "Folder created successfully",64,"Folder Locker"
CALL NewPass()
WScript.Quit
ELSE
MsgBox "Folder Name can't be empty !!!",48,"Folder Locker"
CALL MakeFolder()
END IF
END SUB

SUB Rename()
ON ERROR RESUME NEXT
DIM NewName
NewName=InputBox("Type new name for your folder :","Folder Locker")
IF IsEmpty(NewName) THEN CALL Menu()
IF (NewName)<>"" THEN
IF ObjFSO.FolderExists(NewName) THEN
IF (MsgBox("Unable to rename folder."&vbNewLine&"Folder with same name is already exist in this directory."&vbNewLine&"Try another name.",21,"Folder Locker"))=4 THEN
CALL Rename()
ELSE
CALL Menu()
END IF
END IF
ObjFSO.MoveFolder(FolderName),(NewName)
IF NOT ObjFSO.FolderExists(NewName) THEN
IF (MsgBox("Unable to rename folder",21,"Folder Locker"))=4 THEN
CALL Rename()
ELSE
CALL Menu()
END IF
ELSE
IF ObjFSO.FileExists(NameFile) THEN
ObjFSO.GetFile(NameFile).attributes=0
ObjFSO.DeleteFile(NameFile),TRUE
END IF
CALL Encrypt(NewName)
ObjFSO.CreateTextFile(NameFile,TRUE).Write(NewName)
ObjFSO.GetFile(NameFile).attributes=39
FolderName=ObjFSO.OpenTextFile(NameFile,1).ReadLine
CALL Decrypt(FolderName)
MsgBox "Folder renamed successfully",64,"Folder Locker"
CALL Menu()
END IF
ELSE
MsgBox "Folder name can't be empty !!!",48,"Folder Locker"
CALL Rename()
END IF
END SUB

SUB VerifyUser()
ON ERROR RESUME NEXT
DIM PASS,UserPassword
PASS=InputBox("Type your password to unlock folder :","Folder Locker")
IF IsEmpty(PASS) THEN WScript.Quit
IF (PASS)<>"" THEN
UserPassword=ObjFSO.OpenTextFile(PassFile,1).ReadLine
CALL Decrypt(UserPassword)
IF NOT (PASS)=(UserPassword) THEN
IF (MsgBox("Wrong password !!!",21,"Folder Locker"))=4 THEN
CALL VerifyUser()
ELSE
WScript.Quit
END IF
END IF
ELSE
MsgBox "Empty password !!!",48,"Folder Locker"
CALL VerifyUser()
END IF
END SUB

SUB Unlock()
ON ERROR RESUME NEXT
IF ObjFSO.FolderExists(FolderName) THEN
MsgBox "Unable to unlock folder",48,"Folder Locker"
WScript.Quit
ELSE
ObjFSO.GetFolder(LockFolder).attributes=9
ObjFSO.MoveFolder(LockFolder),(FolderName)
MsgBox "Folder unlocked successfully",64,"Folder Locker"
WScript.CreateObject("WScript.Shell").Run("explorer.exe "&FolderName)
WScript.Quit
END IF
END SUB

SUB ChangePass()
ON ERROR RESUME NEXT
DIM Password
Password=InputBox("Type new password :","Folder Locker")
IF IsEmpty(Password) THEN CALL Menu()
IF (Password)<>"" THEN
DIM NewPassword
NewPassword=InputBox("Verify your new password :","Folder Locker")
IF IsEmpty(NewPassword) THEN CALL Menu()
IF (NewPassword)=(Password) THEN
CALL Encrypt(NewPassword)
IF ObjFSO.FileExists(PassFile) THEN
ObjFSO.GetFile(PassFile).attributes=0
ObjFSO.DeleteFile(PassFile),TRUE
END IF
ObjFSO.CreateTextFile(PassFile,TRUE).Write(NewPassword)
ObjFSO.GetFile(PassFile).attributes=39
MsgBox "New password has been saved",64,"Folder Locker"
CALL Menu()
ELSE
IF (MsgBox("Password doesn't match !!!",21,"Folder Locker"))=4 THEN
CALL ChangePass()
ELSE
CALL Menu()
END IF
END IF
ELSE
MsgBox "Password can't be empty !!!",48,"Folder Locker"
CALL ChangePass()
END IF
END SUB

SUB NewPass()
ON ERROR RESUME NEXT
DIM Password
Password=InputBox("Type new password :","Folder Locker")
IF IsEmpty(Password) THEN WScript.Quit
IF (Password)<>"" THEN
DIM NewPassword
NewPassword=InputBox("Verify new password :","Folder Locker")
IF IsEmpty(NewPassword) THEN WScript.Quit
IF (NewPassword)=(Password) THEN
CALL Encrypt(NewPassword)
IF ObjFSO.FileExists(PassFile) THEN
ObjFSO.GetFile(PassFile).attributes=0
ObjFSO.DeleteFile(PassFile),TRUE
END IF
ObjFSO.CreateTextFile(PassFile,TRUE).Write(NewPassword)
ObjFSO.GetFile(PassFile).attributes=39
MsgBox "New password has been saved",64,"Folder Locker"
WScript.Quit
ELSE
IF (MsgBox("Password doesn't match !!!",21,"Folder Locker"))=4 THEN
CALL NewPass()
ELSE
WScript.Quit
END IF
END IF
ELSE
MsgBox "Password can't be empty !!!",48,"Folder Locker"
CALL NewPass()
END IF
END SUB

SUB Lock()
ON ERROR RESUME NEXT
ObjFSO.MoveFolder(FolderName),(LockFolder)
ObjFSO.GetFolder(LockFolder).attributes=39
IF ObjFSO.FolderExists(FolderName) THEN
IF (MsgBox("Unable to Lock folder."&vbNewLine&"Save all data and close all applications that use this folder, then try again.",21,"Folder Locker"))=4 THEN
CALL Lock()
ELSE
CALL Menu()
END IF
END IF
MsgBox "Folder Locked successfully",64,"Folder Locker"
WScript.Quit
END SUB

SUB Encrypt(NewPassword)
ON ERROR RESUME NEXT
FOR i=1 TO LEN(NewPassword)
X=MID(NewPassword,i,1)
TMP=TMP & CHR(ASC(X)+50) & CHR(ASC(X)+99)
NEXT
NewPassword=TMP
END SUB

SUB Decrypt(UserPassword)
ON ERROR RESUME NEXT
FOR i=1 TO LEN(UserPassword) STEP 2
X=MID(UserPassword,i,1)
TMP=TMP & CHR(ASC(X)-50)
NEXT
UserPassword=TMP
END SUB

SUB Encrypt(NewName)
ON ERROR RESUME NEXT
FOR i=1 TO LEN(NewName)
X=MID(NewName,i,1)
TMP=TMP & CHR(ASC(X)+50) & CHR(ASC(X)+99)
NEXT
NewName=TMP
END SUB

SUB Decrypt(FolderName)
ON ERROR RESUME NEXT
FOR i=1 TO LEN(FolderName) STEP 2
X=MID(FolderName,i,1)
TMP=TMP & CHR(ASC(X)-50)
NEXT
FolderName=TMP
END SUB

SUB Menu()
ON ERROR RESUME NEXT
DIM Choice
Choice=InputBox("1)  Lock Folder"&vbNewLine&"2)  Rename Folder"&vbNewLine&"3)  Change Password"&vbNewLine&""&vbNewLine&""&vbNewLine&"Input your choice :","Folder Locker")
IF IsEmpty(Choice) THEN WScript.Quit
IF (Choice)="1" THEN
IF (MsgBox("Lock your folder and exit ?",36,"Folder Locker"))=7 THEN
CALL Menu()
ELSE
CALL Lock()
END IF
END IF
IF (Choice)="2" THEN CALL Rename()
IF (Choice)="3" THEN CALL ChangePass()
MsgBox "Invalid input !!!",16,"Folder Locker"
CALL Menu()
END SUB

My Blog Menu

Friday, August 31, 2012

Make Folder Locker from HTA (HTML Application)

Wednesday, August 1, 2012

Membuat Folder Locker dari Visual Basic Script (VBS)

Make Folder Locker with Visual Basic Script (VBS)