Faid's Blog™: Membuat Folder Locker dari HTA (HTML Application)

Sebelumnya ane pernah membahas soal folder locker dari VBS, nahh, sekarang ane buat lebih "powerfull" dengan script HTA (HTML Application), caranya mudah, cukup copas semua kode di bawah ini ke dalam notepad lalu simpan dengan ekstensi "*.HTA" (mis."Locker.hta") lalu jalankan,,, saat pemakaian pertama, agan/sist bakal disuruh buat folder baru dan password baru... ;)
code:
<HTML><HEAD>
<TITLE>Folder Locker</TITLE>
<SCRIPT LANGUAGE="VBScript">Self.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"/>
<META HTTP-EQUIV='MSThemeCompatible' CONTENT='YES'>
</HEAD>

<BODY ID='ONSCR' LEFTMARGIN='0' TOPMARGIN='0'></BODY>

<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="Self.Close" : CALL NF
ElseIF NOT ObjFSO.FileExists(PassFile) THEN CBtn="Self.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
Self.ResizeTo intWidth,intHeight
Self.ResizeTo intWidth+(intWidth-Document.Body.OffsetWidth),intHeight+(intHeight-Document.Body.OffsetHeight)
Self.MoveTo (Screen.Width/2)-(intWidth/2),(Screen.Height/2)-(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 "Gagal mengunci folder."&vbNewLine&"Simpan data lalu tutup semua aplikasi yang menggunakan folder ini, lalu coba lagi.",16,"Folder Locker"
EXIT SUB
END IF
MsgBox "Folder berhasil dikunci",64,"Folder Locker"
Self.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 "Gagal membuat folder baru."&vbNewLine&"Folder dengan nama yang sama sudah ada di direktori ini."&vbNewLine&"Cobalah nama yang lain.",16,"Folder Locker"
NameFolder.Select
EXIT SUB
END IF
IF NOT ObjFSO.FolderExists(NewName) THEN
MsgBox "Gagal membuat folder baru",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
NewName=Encrypt(NewName)
ObjFSO.CreateTextFile(NameFile,TRUE,TRUE).Write(NewName)
ObjFSO.GetFile(NameFile).attributes=39
MsgBox "Folder baru berhasil dibuat",64,"Folder Locker"
CALL PS
ELSE
MsgBox "Nama folder tidak boleh kosong !!!",48,"Folder Locker"
NameFolder.Select
EXIT SUB
END IF
END SUB

SUB MM
ON ERROR RESUME NEXT
CALL InnerWindowSize(200,234)
ONSCR.InnerHTML="<TABLE HEIGHT='234px' WIDTH='200px' CELLSPACING='0' CELLPADDING='0'>"_
&"<TR BGCOLOR='#346E99' HEIGHT='45px'><TD><CENTER><FONT COLOR='#FFFFFF' SIZE='+2' FACE='VERDANA,ARIAL,HELVETICA,SANS-SERIF'>MENU UTAMA</FONT></CENTER></TD></TR>"_
&"<TR BGCOLOR='#BBBFFF'><TD><CENTER><BUTTON STYLE='HEIGHT:25px;WIDTH:165px' ONCLICK='Lock'>Kunci Folder</BUTTON><P/>"_
&"<BUTTON STYLE='HEIGHT:25px;WIDTH:165px' ONCLICK='RN'>Ubah Nama Folder</BUTTON><P/>"_
&"<BUTTON STYLE='HEIGHT:25px;WIDTH:165px' ONCLICK='PS'>Ganti Password</BUTTON><P/>"_
&"<BUTTON STYLE='HEIGHT:25px;WIDTH:165px' ONCLICK='Self.Close'>Keluar</BUTTON>"_
&"</TD></CENTER></TR></TABLE>"
END SUB

SUB NF
ON ERROR RESUME NEXT
CALL InnerWindowSize(272,116)
ONSCR.InnerHTML="<TABLE HEIGHT='116px' WIDTH='272px' BGCOLOR='#FFFFFF'>"_
&"<TR><TD><CENTER><TEXT>Tulis nama untuk folder baru</TEXT><BR/><INPUT TYPE='TEXT' NAME='NameFolder' SIZE='35' MaxLength='50'><P/>"_
&"<BUTTON TYPE='SUBMIT' STYLE='WIDTH:90px' ONCLICK='MakeFolder'>Buat</BUTTON> "_
&"<BUTTON STYLE='WIDTH:90px' ONCLICK='Self.Close'>Batal</BUTTON></CENTER></TD></TR>"
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
Password2=Encrypt(Password2)
IF ObjFSO.FileExists(PassFile) THEN
ObjFSO.GetFile(PassFile).attributes=0
ObjFSO.DeleteFile(PassFile),TRUE
END IF
ObjFSO.CreateTextFile(PassFile,TRUE,TRUE).Write(Password2)
ObjFSO.GetFile(PassFile).attributes=39
MsgBox "Password baru telah disimpan",64,"Folder Locker"
CBtn="MM"
CALL MM
ELSE
MsgBox "Password tidak cocok !!!",16,"Folder Locker"
NewPassword.Value=""
VerifyPassword.Value=""
NewPassword.Select
EXIT SUB
END IF
ELSE
MsgBox "Password tidak boleh kosong !!!",48,"Folder Locker"
NewPassword.Select
EXIT SUB
END IF
END SUB

SUB PS
ON ERROR RESUME NEXT
CALL InnerWindowSize(272,160)
ONSCR.InnerHTML="<TABLE HEIGHT='160px' WIDTH='272px' BGCOLOR='#FFFFFF'>"_
&"<TR><TD><CENTER><TEXT>Tulis password baru</TEXT><BR/><INPUT TYPE='PASSWORD' NAME='NewPassword' SIZE='35'><BR/>"_
&"<TEXT>Tulis lagi password yang baru</TEXT><BR/><INPUT TYPE='PASSWORD' NAME='VerifyPassword' SIZE='35'><P/>"_
&"<BUTTON TYPE='SUBMIT' STYLE='WIDTH:90px' ONCLICK='Password'>Simpan</BUTTON> "_
&"<BUTTON STYLE='WIDTH:90px' ONCLICK='"&Cbtn&"'>Batal</BUTTON></CENTER></TD></TR>"
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 "Gagal mengubah nama folder."&vbNewLine&"Folder dengan nama yang sama sudah ada di direktori ini."&vbNewLine&"Cobalah nama yang lain.",16,"Folder Locker"
NameFolder.Select
EXIT SUB
END IF
ObjFSO.MoveFolder(FolderName),(NewName)
IF NOT ObjFSO.FolderExists(NewName) THEN
MsgBox "Gagal mengubah nama 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
NewName=Encrypt(NewName)
ObjFSO.CreateTextFile(NameFile,TRUE,TRUE).Write(NewName)
ObjFSO.GetFile(NameFile).attributes=39
MsgBox "Nama folder berhasil diganti",64,"Folder Locker"
CALL MM
END IF
ELSE
MsgBox "Nama folder tidak boleh kosong !!!",48,"Folder Locker"
NameFolder.Select
EXIT SUB
END IF
END SUB

SUB RN
ON ERROR RESUME NEXT
CALL InnerWindowSize(272,116)
ONSCR.InnerHTML="<TABLE HEIGHT='116px' WIDTH='272px' BGCOLOR='#FFFFFF'>"_
&"<TR><TD><CENTER><TEXT>Tulis nama baru untuk folder Anda</TEXT><BR/><INPUT TYPE='TEXT' NAME='NameFolder' SIZE='35' MaxLength='50'><P/>"_
&"<BUTTON TYPE='SUBMIT' STYLE='WIDTH:90px' ONCLICK='Rename'>Ubah Nama</BUTTON> "_
&"<BUTTON STYLE='WIDTH:90px' ONCLICK='MM'>Batal</BUTTON></CENTER></TD></TR>"
NameFolder.Select
END SUB

SUB UL
ON ERROR RESUME NEXT
CALL InnerWindowSize(272,116)
ONSCR.InnerHTML="<TABLE HEIGHT='116px' WIDTH='272px' BGCOLOR='#FFFFFF'>"_
&"<TR><TD><CENTER><TEXT>Tulis password untuk membuka folder</TEXT><BR/><INPUT TYPE='PASSWORD' NAME='PasswordInput' SIZE='35'><P/>"_
&"<BUTTON TYPE='SUBMIT' STYLE='WIDTH:90px' ONCLICK='Unlock'>Buka</BUTTON> "_
&"<BUTTON STYLE='WIDTH:90px' ONCLICK='Self.Close'>Batal</BUTTON></CENTER></TD></TR>"
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 "Password salah !!!",16,"Folder Locker"
PasswordInput.Value=""
PasswordInput.Select
EXIT SUB
ELSE
IF ObjFSO.FolderExists(FolderName) THEN
MsgBox "Gagal membuka folder",48,"Folder Locker"
Self.Close
ELSE
ObjFSO.GetFolder(LockFolder).attributes=9
ObjFSO.MoveFolder(LockFolder),(FolderName)
MsgBox "Folder berhasil dibuka",64,"Folder Locker"
WshShell.Run("explorer.exe "&FolderName)
Self.Close
END IF
END IF
ELSE
MsgBox "Password kosong !!!",48,"Folder Locker"
PasswordInput.Select
EXIT SUB
END IF
END SUB
</SCRIPT>
</HTML>
2 comments:

AnonymousFebruary 29, 2016 at 11:16 AM
Added some changes to ur folder lckr for my needs. Maybe u can clean up the syntax. (See link below)

http://pastebin.com/viDDsTSh
AnonymousMarch 1, 2016 at 6:02 AM
Just verified my own work. My HTA (http://pastebin.com/viDDsTSh) does not work in win7. Sori 4 the inconvenience.
Back to the drawing board.
Faid's Blog™

My Blog Menu

Thursday, October 18, 2012

Membuat Folder Locker dari HTA (HTML Application)

2 comments:
