Faid's Blog™: 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>
Faid's Blog™

My Blog Menu

Friday, August 31, 2012

Make Folder Locker from HTA (HTML Application)

No comments:

Post a Comment
