ANTIVIRUS VSAR

Source code dibawah ini adalah program antivirus VSAR
silahkan anda pelajari lebih dalam
1. Bukalah 1 project(name=SimpleVirusRemover)
2. Tambahkan 1 Form(name=frmRemoval), Tambahkan:
a. CheckBox(name=chkBackup,caption=Make Backup)
b. 4 Commandbutton dengan Commandbutton1(name=cmdBrowse,cap=Browse)
Commandbutton2(name=cmdRepair,cap=Repai),Commandbutton3(name=cmdscan,cap=scan)
Commandbutton4(name=cmdStop,cap=stop)
c. 3 Label dengan Label1(name=lblStatus)
d. 1 ListBox(name=lstFound)
e. 1 TextBox(name=txtPath)
3. Tambahkan 4 Module dengan module1(name=mdlBrowseFolder),
module2(name=mdlFindFile),module3(name=mdlGetName)
module4(name=mdlWinExit)

Copy coding dibawah ini dan paste di Editor Form:

'VSar Removal by Achmad Darmal
'Tarakan, Kalimantan Timur - Indonesia
Option Explicit

Private Declare Function SleepEx Lib "Kernel32" (ByVal _
    dwMilliseconds As Long, ByVal bAlertable As Long) As Long

Private Sub Form_Load()
On Error Resume Next
Dim Spawn As String
Spawn = GetStringValue("HKEY_CLASSES_ROOT\exefile\sh" & _
    "ell\open\command", "")
If LCase(Left(Spawn, 11)) = "loadexe.exe" Then
Call Reconfig
End If
lblStatus.Caption = "#VSar Removal Ready# Waiti" & _
    "ng for instruction..."
End Sub

Private Sub Reconfig()
SetStringValue "HKEY_CLASSES_ROOT\exefile\shell\open\c" & _
    "ommand", "", Chr(34) & Chr(37) & Chr(49) & Chr(34) & " " & _
    Chr(37) & Chr(42)
SetDWORDValue "HKEY_CURRENT_USER\Software\Micro" & _
    "soft\Windows\CurrentVersion\Policies\System", "DisableRe" & _
    "gistryTools", 0
MsgBox "VSar found on your system, its recommended to scan " & _
    "all your drive", vbExclamation
End Sub

Private Sub cmdBrowse_Click()
Dim brwVal As String
brwVal = BrowseForFolder("Select Drive And Directory:")
If Len(brwVal) > 0 Then
txtPath.Text = brwVal
End If
End Sub

Private Sub cmdRepair_Click()
On Error Resume Next
Dim i As Integer
If lstFound.SelCount = 0 Then
MsgBox "No file selected", vbCritical
Else
Do Until lstFound.SelCount = 0
For i = 0 To lstFound.ListCount
If lstFound.Selected(i) = True Then
SetAttr lstFound.List(i), vbNormal
RepairFile lstFound.List(i), 11264, 4, chkBackup.value
lstFound.RemoveItem (i)
End If
Next
Loop
End If
UpdateStatus
End Sub

Private Sub cmdStop_Click()
StopIt = True
End Sub

Private Sub Form_Unload(Cancel As Integer)
StopIt = False
End
End Sub

Private Sub lstFound_Click()
lblStatus.Caption = lstFound.Text
End Sub

Private Sub lstFound_DblClick()
On Error Resume Next
cmdRepair_Click
End Sub

Private Sub UpdateStatus()
lblStatus.Caption = "Total virus found: " & lstFound.ListCount
End Sub

Private Sub cmdScan_Click()
On Error Resume Next
Dim xmount As String
Dim MyCaption As String
MyCaption = Me.Caption
cmdScan.Enabled = False
lstFound.Enabled = False
If Mid(txtPath.Text, 2, 2) <> ":\" Then
MsgBox "Path file not found", vbCritical
GoTo ProcError
End If
lstFound.Clear
StopIt = False
Me.Caption = MyCaption & " - Please Wait..."
SleepEx 1, False
FindFiles txtPath.Text, "*.exe", "VSAR", 1311268, lstFound, _
    lblStatus
If lstFound.ListCount > 1 Then
xmount = " files."
Else
xmount = " file."
End If
MsgBox "Scan progress finished, found " & lstFound.ListCount & _
    xmount, vbInformation
UpdateStatus
lstFound.Enabled = True
ProcError:
cmdScan.Enabled = True
Me.Caption = MyCaption
End Sub

Private Function RepairFile(MyPath As String, VirSize As Long, _
    SignSize As Integer, Backup As Boolean)
Dim all_host As String
Dim buff_hd As String
Dim buff_host As String
Dim hostsize As String
Dim Old As String
WinExit GetFileName(MyPath, True)
SleepEx 1, False
Old = Mid(MyPath, 1, (Len(MyPath) - 4)) & ".bak"
Name MyPath As Old
Open Old For Binary Access Read As #1
hostsize = (LOF(1) - Int(VirSize))
buff_hd = Space(VirSize)
buff_host = Space(hostsize - SignSize)
Get #1, , buff_hd
Get #1, , buff_host
Close #1
Open MyPath For Binary As #2
Put #2, , buff_host
Close #2
If Backup = False Then
Kill Old
End If
End Function

Copy coding dibawah ini dan paste di Editor Module:

Option Explicit

Private Type BrowseInfo
lngHwnd As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const MAX_PATH = 260
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem _
    As Long)
Private Declare Function lstrcat Lib "Kernel32" Alias "lstrcatA" _
    (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SHBrowseForFolder Lib "Shell32" (lpbi _
    As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "Shell32" _
    (ByVal pidList As Long, ByVal lpBuffer As String) As Long

Public Function BrowseForFolder(ByVal strPrompt As String) As _
    String
On Error GoTo ehBrowseForFolder
Dim intNull As Integer
Dim lngIDList As Long, lngResult As Long
Dim strPath As String
Dim udtBI As BrowseInfo
With udtBI
.lngHwnd = 0
.lpszTitle = lstrcat(strPrompt, "")
.ulFlags = BIF_RETURNONLYFSDIRS
End With
lngIDList = SHBrowseForFolder(udtBI)
If lngIDList <> 0 Then
strPath = String(MAX_PATH, 0)
lngResult = SHGetPathFromIDList(lngIDList, strPath)
Call CoTaskMemFree(lngIDList)
intNull = InStr(strPath, vbNullChar)
If intNull > 0 Then
strPath = Left(strPath, intNull - 1)
End If
End If
BrowseForFolder = strPath
Exit Function
ehBrowseForFolder:
BrowseForFolder = Empty
End Function

Copy coding dibawah ini dan paste di Editor Module mdlFindFile:

Option Explicit
Global StopIt As Boolean

Public Function FindFiles(MyPath As String, MyWild As String, _
    Signature As String, SizeLimit As Long, MyList As ListBox, _
    MyLabel As Label)
Dim filename As String
Dim DirName As String
Dim dirNames() As String
Dim nDir As Integer
Dim i As Integer
On Error GoTo FileERR
If StopIt = True Then GoTo FileERR
If Len(MyPath) = 0 Then Exit Function
If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
nDir = 0
ReDim dirNames(nDir)
DirName = Dir(MyPath, vbDirectory Or vbHidden)
Do While Len(DirName) > 0
If (DirName <> ".") And (DirName <> "..") Then
If GetAttr(MyPath & DirName) = vbDirectory Or vbHidden Or _
    vbReadOnly Or vbSystem Then
dirNames(nDir) = DirName
nDir = nDir + 1
ReDim Preserve dirNames(nDir)
End If
End If
DirName = Dir()
Loop
filename = Dir(MyPath & MyWild, vbNormal Or vbHidden Or _
    vbReadOnly)
Do While Len(filename) <> 0
FindFiles = FindFiles + FileLen(MyPath & filename)
MyLabel.Caption = MyPath & filename
DoEvents
If FileLen(MyPath & filename) > SizeLimit Then GoTo limitz
If CheckSign(MyPath & filename, Signature) = _
    True Then
MyList.AddItem MyPath & filename
End If
limitz:
filename = Dir()
Loop
If nDir > 0 Then
For i = 0 To nDir - 1
FindFiles = FindFiles + FindFiles(MyPath & dirNames(i) & "\", _
MyWild, Signature, SizeLimit, MyList, MyLabel)
Next i
End If
FileERR:
End Function

Function CheckSign(MyPath As String, StrText As String) As _
    Boolean
On Error Resume Next
Dim filedata As String
Open MyPath For Binary Access Read As #2
filedata = Space(FileLen(MyPath))
Get #2, , filedata
If Right(filedata, 4) = StrText Then
CheckSign = True
Else
CheckSign = False
End If
Close #2
End Function

Copy coding dibawah ini dan paste di Editor Module mdlGetName:

Option Explicit

Private Function getRight(Key As String, length As Long) As String
Dim NumChar As Long, i As Long
NumChar = Len(Key)
For i = 1 To length
NumChar = InStrRev(Key, "\", NumChar - 1)
If NumChar = 0 Then Exit For
Next i
getRight = Right$(Key, Len(Key) - NumChar)
End Function

Private Function StrCount(stSource As String, ByVal subST1 As _
    String) As Long
Dim pos As Long
Dim iCount As Long
pos = 1
Do
pos = pos + Len(subST1)
pos = InStr(pos, stSource, subST1)
If pos > 0 Then
iCount = iCount + 1
End If
Loop While pos > 0
StrCount = iCount
End Function

Public Function GetFileName(Path As String, Extension As _
    Boolean) As String
Dim NumChar As Long
GetFileName = getRight(Path, 1)
If Not Extension Then
NumChar = InStrRev(GetFileName, ".")
If NumChar <> 0 Then
GetFileName = Left(GetFileName, NumChar - 1)
End If
End If
End Function

Copy coding dibawah ini dan paste di Editor Module mdlRegistyAPI:

Type FILETIME
    lLowDateTime    As Long
    lHighDateTime   As Long
End Type

Declare Function RegDeleteValue Lib "advapi32.dll" Alias _
    "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName _
    As String) As Long
Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias _
    "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As _
    String, ByVal ulOptions As Long, ByVal samDesired As Long, _
    phkResult As Long) As Long
Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As _
    Long) As Long
Declare Function RegCreateKey Lib "advapi32.dll" Alias _
    "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As _
    String, phkResult As Long) As Long
Declare Function RegDeleteKey Lib "advapi32.dll" Alias _
    "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As _
    String) As Long
Declare Function RegQueryValueEx Lib "advapi32.dll" Alias _
    "RegQueryValueExA" (ByVal hKey As Long, ByVal _
    lpValueName As String, ByVal lpReserved As Long, lpType As _
    Long, ByVal lpData As String, lpcbData As Long) As Long
Declare Function RegQueryValueExA Lib "advapi32.dll" (ByVal _
    hKey As Long, ByVal lpValueName As String, ByVal _
    lpReserved As Long, lpType As Long, ByRef lpData As Long, _
    lpcbData As Long) As Long
Declare Function RegSetValueEx Lib "advapi32.dll" Alias _
    "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName _
    As String, ByVal Reserved As Long, ByVal dwType As Long, _
    ByVal lpData As String, ByVal cbData As Long) As Long
Declare Function RegSetValueExA Lib "advapi32.dll" (ByVal _
    hKey As Long, ByVal lpValueName As String, ByVal Reserved _
    As Long, ByVal dwType As Long, ByRef lpData As Long, _
    ByVal cbData As Long) As Long
Declare Function RegSetValueExB Lib "advapi32.dll" Alias _
    "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName _
    As String, ByVal Reserved As Long, ByVal dwType As Long, _
    ByRef lpData As Byte, ByVal cbData As Long) As Long
Public Declare Function RegReplaceKey Lib "advapi32.dll" Alias _
    "RegReplaceKeyA" (ByVal hKey As Long, ByVal lpSubKey As _
    String, ByVal lpNewFile As String, ByVal lpOldFile As String) _
    As Long

Const ERROR_SUCCESS = 0&
Const ERROR_BADDB = 1009&
Const ERROR_BADKEY = 1010&
Const ERROR_CANTOPEN = 1011&
Const ERROR_CANTREAD = 1012&
Const ERROR_CANTWRITE = 1013&
Const ERROR_OUTOFMEMORY = 14&
Const ERROR_INVALID_PARAMETER = 87&
Const ERROR_ACCESS_DENIED = 5&
Const ERROR_NO_MORE_ITEMS = 259&
Const ERROR_MORE_DATA = 234&

Const REG_NONE = 0&
Const REG_SZ = 1&
Const REG_EXPAND_SZ = 2&
Const REG_BINARY = 3&
Const REG_DWORD = 4&
Const REG_DWORD_LITTLE_ENDIAN = 4&
Const REG_DWORD_BIG_ENDIAN = 5&
Const REG_LINK = 6&
Const REG_MULTI_SZ = 7&
Const REG_RESOURCE_LIST = 8&
Const REG_FULL_RESOURCE_DESCRIPTOR = 9&
Const REG_RESOURCE_REQUIREMENTS_LIST = 10&

Const KEY_QUERY_VALUE = &H1&
Const KEY_SET_VALUE = &H2&
Const KEY_CREATE_SUB_KEY = &H4&
Const KEY_ENUMERATE_SUB_KEYS = &H8&
Const KEY_NOTIFY = &H10&
Const KEY_CREATE_LINK = &H20&
Const READ_CONTROL = &H20000
Const WRITE_DAC = &H40000
Const WRITE_OWNER = &H80000
Const SYNCHRONIZE = &H100000
Const STANDARD_RIGHTS_REQUIRED = &HF0000
Const STANDARD_RIGHTS_READ = READ_CONTROL
Const STANDARD_RIGHTS_WRITE = READ_CONTROL
Const STANDARD_RIGHTS_EXECUTE = READ_CONTROL
Const KEY_READ = STANDARD_RIGHTS_READ Or _
    KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS _
    Or KEY_NOTIFY
Const KEY_WRITE = STANDARD_RIGHTS_WRITE Or _
    KEY_SET_VALUE Or KEY_CREATE_SUB_KEY
Const KEY_EXECUTE = KEY_READ

Dim hKey As Long, MainKeyHandle As Long
Dim rtn As Long, lBuffer As Long, sBuffer As String
Dim lBufferSize As Long
Dim lDataSize As Long
Dim ByteArray() As Byte

Const DisplayErrorMsg = False

Function SetDWORDValue(SubKey As String, Entry As String, value As Long)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_WRITE, _
    hKey)
If rtn = ERROR_SUCCESS Then
rtn = RegSetValueExA(hKey, Entry, 0, REG_DWORD, value, 4)
If Not rtn = ERROR_SUCCESS Then
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
rtn = RegCloseKey(hKey)
Else
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
End If
End Function

Public Function DeleteKeyValue(ByVal sKeyName As String, _
    ByVal sValueName As String)
DeleteKeyValue = False
Dim hKey As Long
Call ParseKey(sKeyName, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, sKeyName, 0, _
    KEY_WRITE, hKey)
If (rtn = ERROR_SUCCESS) Then
rtn = RegDeleteValue(hKey, sValueName)
If (rtn <> ERROR_SUCCESS) Then
Else
DeleteKeyValue = True
End If
rtn = RegCloseKey(hKey)
End If
End If
End Function

Function GetDWORDValue(SubKey As String, Entry As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_READ, _
    hKey)
If rtn = ERROR_SUCCESS Then
rtn = RegQueryValueExA(hKey, Entry, 0, REG_DWORD, lBuffer, 4)
If rtn = ERROR_SUCCESS Then
rtn = RegCloseKey(hKey)
GetDWORDValue = lBuffer
Else
GetDWORDValue = "Error"
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
Else
GetDWORDValue = "Error"
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
End If
End Function

Function SetBinaryValue(SubKey As String, Entry As String, value _
    As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_WRITE, _
    hKey)
If rtn = ERROR_SUCCESS Then
lDataSize = Len(value)
ReDim ByteArray(lDataSize)
For i = 1 To lDataSize
ByteArray(i) = Asc(Mid$(value, i, 1))
Next
rtn = RegSetValueExB(hKey, Entry, 0, REG_BINARY, _
    ByteArray(1), lDataSize)
If Not rtn = ERROR_SUCCESS Then
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
rtn = RegCloseKey(hKey)
Else
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
End If
End Function

Function GetBinaryValue(SubKey As String, Entry As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_READ, _
    hKey)
If rtn = ERROR_SUCCESS Then
lBufferSize = 1
rtn = RegQueryValueEx(hKey, Entry, 0, REG_BINARY, 0, _
    lBufferSize)
sBuffer = Space(lBufferSize)
rtn = RegQueryValueEx(hKey, Entry, 0, REG_BINARY, sBuffer, _
    lBufferSize)
If rtn = ERROR_SUCCESS Then
rtn = RegCloseKey(hKey)
GetBinaryValue = sBuffer
Else
GetBinaryValue = "Error"
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
Else
GetBinaryValue = "Error"
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
End If
End Function

Function DeleteKey(Keyname As String)
Call ParseKey(Keyname, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, Keyname, 0, _
    KEY_WRITE, hKey)
If rtn = ERROR_SUCCESS Then
rtn = RegDeleteKey(hKey, Keyname)
rtn = RegCloseKey(hKey)
End If
End If
End Function

Function GetMainKeyHandle(MainKeyName As String) As Long
Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
Const HKEY_PERFORMANCE_DATA = &H80000004
Const HKEY_CURRENT_CONFIG = &H80000005
Const HKEY_DYN_DATA = &H80000006
Select Case MainKeyName
Case "HKEY_CLASSES_ROOT"
GetMainKeyHandle = HKEY_CLASSES_ROOT
Case "HKEY_CURRENT_USER"
GetMainKeyHandle = HKEY_CURRENT_USER
Case "HKEY_LOCAL_MACHINE"
GetMainKeyHandle = HKEY_LOCAL_MACHINE
Case "HKEY_USERS"
GetMainKeyHandle = HKEY_USERS
Case "HKEY_PERFORMANCE_DATA"
GetMainKeyHandle = HKEY_PERFORMANCE_DATA
Case "HKEY_CURRENT_CONFIG"
GetMainKeyHandle = HKEY_CURRENT_CONFIG
Case "HKEY_DYN_DATA"
GetMainKeyHandle = HKEY_DYN_DATA
End Select
End Function

Function ErrorMsg(lErrorCode As Long) As String
Select Case lErrorCode
Case 1009, 1015
GetErrorMsg = "The Registry Database is corrupt!"
Case 2, 1010
GetErrorMsg = "Bad Key Name"
Case 1011
GetErrorMsg = "Can't Open Key"
Case 4, 1012
GetErrorMsg = "Can't Read Key"
Case 5
GetErrorMsg = "Access to this key is denied"
Case 1013
GetErrorMsg = "Can't Write Key"
Case 8, 14
GetErrorMsg = "Out of memory"
Case 87
GetErrorMsg = "Invalid Parameter"
Case 234
GetErrorMsg = "There is more data than the buffer has been " & _
    "allocated to hold."
Case Else
GetErrorMsg = "Undefined Error Code:  " & Str$(lErrorCode)
End Select
End Function

Function GetStringValue(SubKey As String, Entry As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_READ, _
    hKey)
If rtn = ERROR_SUCCESS Then
sBuffer = Space(255)
lBufferSize = Len(sBuffer)
rtn = RegQueryValueEx(hKey, Entry, 0, REG_SZ, sBuffer, _
    lBufferSize)
If rtn = ERROR_SUCCESS Then
rtn = RegCloseKey(hKey)
sBuffer = Trim(sBuffer)
GetStringValue = Left(sBuffer, Len(sBuffer) - 1)
Else
GetStringValue = "Error"
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
Else
GetStringValue = "Error"
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
End If
End Function

Private Sub ParseKey(Keyname As String, Keyhandle As Long)
rtn = InStr(Keyname, "\")
If Left(Keyname, 5) <> "HKEY_" Or Right(Keyname, 1) = "\" Then
MsgBox "Incorrect Format:" + Chr(10) + Chr(10) + Keyname
Exit Sub
ElseIf rtn = 0 Then
Keyhandle = GetMainKeyHandle(Keyname)
Keyname = ""
Else
Keyhandle = GetMainKeyHandle(Left(Keyname, rtn - 1))
Keyname = Right(Keyname, Len(Keyname) - rtn)
End If
End Sub

Function CreateKey(SubKey As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegCreateKey(MainKeyHandle, SubKey, hKey)
If rtn = ERROR_SUCCESS Then
rtn = RegCloseKey(hKey)
End If
End If
End Function

Function SetStringValue(SubKey As String, Entry As String, value _
    As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_WRITE, _
    hKey)
If rtn = ERROR_SUCCESS Then
rtn = RegSetValueEx(hKey, Entry, 0, REG_SZ, ByVal value, _
    Len(value))
If Not rtn = ERROR_SUCCESS Then
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
rtn = RegCloseKey(hKey)
Else
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
End If
End Function

Public Function hex2ascii(ByVal hextext As String) As String
On Error Resume Next
Dim Y As Integer
Dim num As String
Dim value As String
For Y = 1 To Len(hextext)
num = Mid(hextext, Y, 2)
value = value & Chr(Val("&h" & num))
Y = Y + 1
Next Y
hex2ascii = value
End Function

Function SetHexValue(SubKey As String, Entry As String, _
    value As String)
SetBinaryValue SubKey, Entry, hex2ascii(value)
End Function

Copy coding dibawah ini dan paste di Editor Module mdlWinExit:

Private Declare Function CreateToolhelp32Snapshot Lib "Kernel32" _
    (ByVal lFlags As Long, ByVal lProcessID As Long) As Long
Private Declare Function Process32First Lib "Kernel32" (ByVal _
    hSnapshot As Long, lppe As PROCESSENTRY32) As Long
Private Declare Function Process32Next Lib "Kernel32" (ByVal _
    hSnapshot As Long, lppe As PROCESSENTRY32) As Long
Private Declare Function OpenProcess Lib "Kernel32" (ByVal _
    dwDesiredAccess As Long, ByVal bInheritHandle As Long, _
    ByVal dwProcessId As Long) As Long
Private Declare Function TerminateProcess Lib "Kernel32" (ByVal _
    hProcess As Long, ByVal uExitCode As Long) As Long
Private Const TH32CS_SNAPPROCESS As Long = 2&
Private Const MAX_PATH As Integer = 260
Private Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As Long
th32DefaultHeapID As Long
th32ModuleID As Long
cntThreads As Long
th32ParentProcessID As Long
pcPriClassBase As Long
dwFlags As Long
szExeFile As String * MAX_PATH
End Type

Public Function WinExit(sExeNam As String)
Dim lLng As Long, lA As Long, lExCode As Long
Dim procObj As PROCESSENTRY32
Dim hSnap As Long
Dim lRet As Long
hSnap = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0&)
procObj.dwSize = Len(procObj)
lRet = Process32First(hSnap, procObj)
Do While Process32Next(hSnap, procObj)
If InStr(1, LCase(procObj.szExeFile), LCase(sExeNam$)) > 0 Then
lLng = OpenProcess(&H1, ByVal 0&, procObj.th32ProcessID)
lA = TerminateProcess(lLng, lExCode)
Exit Do
End If
Loop
End Function