Try this HTA and i hope that can did the trick.
NB : The Password is 9999 and of course you can change it at this line
MyGoodPassword = "9999"
<HTML>
<HEAD>
<TITLE></TITLE>
<HTA:APPLICATION
APPLICATIONNAME="Access to the system © Hackoo © 2015"
BORDER="THIN"
BORDERSTYLE="NORMAL"
ICON="Explorer.exe"
INNERBORDER="NO"
MAXIMIZEBUTTON="NO"
MINIMIZEBUTTON="NO"
SCROLL="NO"
SELECTION="NO"
SINGLEINSTANCE="YES"/>
</HEAD>
<META HTTP-EQUIV="MSThemeCompatible" CONTENT="YES">
<BODY TOPMARGIN="1" LEFTMARGIN="1"><CENTER><DIV><SPAN ID="ONSCR"></SPAN></DIV></CENTER></BODY>
<SCRIPT LANGUAGE="VBScript">
Option Explicit
Dim Title,ws,Voice,ErrorMsg,WelcomeMsg,MyGoodPassword,Password,Temp,Tests,ProcessEnv,UserName
Title = "Access to the system © Hackoo 2015"
Dim objFSO : Set objFSO = CreateObject("Scripting.FileSystemObject")
Set ws = CreateObject("wscript.Shell")
Set ProcessEnv = Ws.Environment("Process")
UserName = ProcessEnv("USERNAME")
Temp = WS.ExpandEnvironmentStrings("%Temp%")
Tests = Temp &"\Tests.txt"
'------------------------------------------------------------------------------------
Sub window_onload()
CenterWindow 280,180
Call PasswordForm()
Call TextFocus
Dim Count : Count = 0
If Not objFSO.FileExists(Tests) Then
Dim Logfile : Set Logfile = objFSO.OpenTextFile(Tests,2,True)
Logfile.writeline Count
Logfile.Close
end If
Call Kill("Explorer.exe")
Call DisableTaskMgr()
End Sub
'------------------------------------------------------------------------------------
Sub CenterWindow(x,y)
Dim iLeft,itop
window.resizeTo x,y
iLeft = window.screen.availWidth/2 - x/2
itop = window.screen.availHeight/2 - y/2
window.moveTo ileft,itop
End Sub
'------------------------------------------------------------------------------------
Sub PasswordForm()
Self.document.title = "Access to the system © Hackoo 2015"
Self.document.bgColor = "DarkOrange"
ONSCR.InnerHTML="<center><FONT COLOR=""#FFFFFF"" SIZE=""+1"" FACE=""VERDANA,ARIAL,HELVETICA,SANS-SERIF"">Type your Password</FONT><br><br><input type=""password"" name=""PasswordArea"" size=""20"" onKeyUp=""TextFocus""><P>"_
&"<input type=""Submit"" STYLE=""HEIGHT:25;WIDTH:190"" value=""Access to the system"" name=""run_button"" onClick=""CheckPassword"">"
END Sub
'------------------------------------------------------------------------------------
Sub CheckPassword
Dim NB_Tests_MAX : NB_Tests_MAX = 3
Dim Readfile,Count,NB_Tests_Remaining,Logfile,Controle,Command,Executer,MsgNumbTests,MsgReboot
Set Voice = CreateObject("SAPI.SpVoice")
ErrorMsg = "ATTENTION ! ! ! "& vbcr &"The Password is Wrong ! "& vbcr &"Try Again !"
WelcomeMsg = "Welcome again "& DblQuote(UserName) &" in your System !"
MyGoodPassword = "9999"
Set Readfile = objFSO.OpenTextFile(Tests,1)
Count = Readfile.ReadAll
Readfile.Close
Controle = True
While Controle
Count = Count + 1
NB_Tests_Remaining = NB_Tests_MAX - Count
Set Logfile = objFSO.OpenTextFile(Tests,2,True)
Logfile.writeline Count
Logfile.Close
If PasswordArea.Value <> MyGoodPassword Then
Voice.Speak ErrorMsg
ws.Popup ErrorMsg,"1",Title,0+16
MsgNumbTests = "ATTENTION !!! "&vbcr&"Bad Password and NB°of TESTS is " & Count &"."&vbCr&_
"The remaining number of tests is "& NB_Tests_Remaining
Voice.Speak MsgNumbTests
MsgBox MsgNumbTests,48,Title
Sleep(1)
Location.Reload(True)
end if
If PasswordArea.Value = MyGoodPassword Then
If objFSO.FileExists(Tests) Then objFSO.DeleteFile Tests,True
Controle = False
Voice.Speak WelcomeMsg
ws.Popup WelcomeMsg,"1",Title,0+64
Call Launch("Explorer.exe")
Call EnableTaskMgr()
Self.Close
Exit Sub
End If
If Count = NB_Tests_MAX Then
If objFSO.FileExists(Tests) Then objFSO.DeleteFile Tests,True
Voice.Speak "The computer will reboot in 30 seconds !"
MsgReboot = "The Limit number of tests is reached ! "&vbcr& "The computer will Reboot in 30 seconds !"
MsgBox MsgReboot,48,"The Limit number of tests is reached ! "
Command="cmd /c Shutdown.exe -r -t 30 -c " & chr(34) & "The computer will reboot in 30 seconds !" & chr(34)
Executer = WS.Run(Command,0,False)
window.close
End If
Exit Sub
wend
End Sub
'----------------------------------------------------------------------------------
Sub TextFocus
PasswordArea.Focus
End Sub
'----------------------------------------------------------------------------------
Sub Kill(Process)
Dim Ws,Command,Execution
Set Ws = CreateObject("Wscript.Shell")
Command = "cmd /c Taskkill /F /IM "&Process&""
Execution = Ws.Run(Command,0,False)
End Sub
'----------------------------------------------------------------------------------
Sub Launch(Process)
Dim Ws,Command,Execution
Set Ws = CreateObject("Wscript.Shell")
Command = "cmd /c Start "&Process&""
Execution = Ws.Run(Command,0,False)
End Sub
'-----------------------------------------------------------------------------------
'------------------------------EnableTaskMgr----------------------------------------
Sub EnableTaskMgr()
Dim WshShell,System
System="HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\System\"
Set WshShell=CreateObject("WScript.Shell")
Wshshell.RegWrite System, "REG_SZ"
WshShell.RegWrite System &"\DisableTaskMgr", 0, "REG_DWORD"
End sub
'------------------------------------------------------------------------------------
'-----------------------------DisableTaskMgr-----------------------------------------
Sub DisableTaskMgr()
Dim WshShell,System
System="HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\System\"
Set WshShell=CreateObject("WScript.Shell")
Wshshell.RegWrite System, "REG_SZ"
WshShell.RegWrite System &"\DisableTaskMgr", 1, "REG_DWORD"
End sub
'--------------------------------------------------------------------------------------
Sub Sleep(intNumSecs)
' Because WScript.Sleep () is not available in HTA
' scripts, invoke a VBScript file to do the waiting.
Dim strScriptFile, strCommand, intRetcode, objWS
If intNumSecs <= 0 Then Exit Sub
Set objWS = CreateObject ("WScript.Shell")
strScriptFile = "%temp%\wait" & intNumSecs & "seconds.vbs"
strCommand = "cmd /c ""echo WScript.Sleep " & intNumSecs * 1000 & " >" & strScriptFile & _
"&start /wait """" wscript.exe " & strScriptFile & """"
intRetCode = objWS.Run (strCommand, 0, True)
If intRetCode = 0 Then Exit Sub
End Sub
'---------------------------------------------------------------------------------------
Function DblQuote(Str)
DblQuote = Chr(34) & Str & Chr(34)
End Function
'---------------------------------------------------------------------------------------
</SCRIPT>
