przez x-awier 23 Lut 2006, 11:29
[code][quote]log z silenta
'Silent Runners.vbs -- find out what programs start up with Windows!
'
'DO NOT REMOVE THIS HEADER!
'
'Copyright Andrew ARONOFF 30 December 2004, http://www.silentrunners.org/
'This script is provided without any warranty, either expressed or implied
'It may not be copied or distributed without permission
'
'** YOU RUN THIS SCRIPT AT YOUR OWN RISK! **
'HEADER ENDS HERE
Option Explicit
Dim strRevNo : strRevNo = "RED (R28)"
'This script is divided into 14 sections.
'Each section outputs the contents of
'registry keys (I-IX), INI/INF-files (X-XI), folders (XII),
'enabled scheduled tasks (XIII) and started services (XIV)
'which may harbor malware.
'Output is suppressed if registry key or file contents are deemed
'to be normal.
' I. HKCU/HKLM... Run/RunOnce/RunOnce\Setup
' HKLM... RunOnceEx/RunServices/RunServicesOnce
' HKCU/HKLM... Policies\Explorer\Run
' II. HKLM... Active Setup\Installed Components\
' HKCU... Active Setup\Installed Components\
' (StubPath <> "" And HKLM version # > HKCU version #)
' III. HKLM... Explorer\Browser Helper Objects\
' IV. HKLM... Explorer\SharedTaskScheduler\ (InProcServer32 <> "browseui.dll")
' V. HKCU/HKLM... ShellServiceObjectDelayLoad\
' VI. HKCU... Command Processor\AutoRun ((default) <> "")
' HKCU... Windows\load & run ((default) <> "")
' HKCU... Command Processor\AutoRun ((default) <> "")
' HKLM... Windows\AppInit_DLLs ((default) <> "")
' HKLM... Winlogon\Shell/Userinit/System/Ginadll ((default) <> explorer.exe, userinit.exe, "", "")
' VII. HKLM... Winlogon\Notify\ (subkey names/DLLName values <> O/S-specific dictionary data)
'VIII. HKCU/HKLM... Policies... Startup/Shutdown, Logon/Logoff
' IX. HKCR executable file type (bat/com/exe/hta/pif)
' (shell\open\command data <> "%1" %*; hta <> mshta.exe "%1" %*)
' X. WIN.INI (load/run <> ""), SYSTEM.INI (shell <> explorer.exe), WINSTART.BAT
' XI. AUTORUN.INF in root of fixed drive (open/shellexecute <> "")
' XII. %WINDIR%... Startup & All Users... Startup (W98/WME) or
' %USERNAME%... Startup & All Users... Startup folder contents
'XIII. Scheduled Tasks
' XIV. Started Services
Dim Wshso : Set Wshso = WScript.CreateObject("WScript.Shell")
Dim WshoArgs : Set WshoArgs = WScript.Arguments
Dim Fso : Set Fso = CreateObject("Scripting.FileSystemObject")
Dim oNetwk : Set oNetwk = WScript.CreateObject("WScript.Network")
Const HKLM = &H80000002 : Const HKCU = &H80000001
'determine whether output is via MsgBox/PopUp or Echo
Dim flagOut
If InStr(LCase(WScript.FullName),"wscript.exe") > 0 Then
flagOut = "W" 'WScript
ElseIf InStr(LCase(WScript.FullName),"cscript.exe") > 0 Then
flagOut = "C" 'CScript
Else
WScript.Echo "Neither WScript.exe nor CScript.exe was detected as " &_
"the script host." & vbCRLF & Chr(34) & "Silent Runners" & Chr(34) &_
" will exit!"
End If 'script host
Const SysFolder = 1 : Const WinFolder = 0
Dim strOS : strOS = "Unknown"
Dim strOSLong : strOSLong = "Unknown"
Dim intMB 'MsgBox return value
Public strFPSF : strFPSF = Fso.GetSpecialFolder(SysFolder).Path 'FullPathSystemFolder
Public strFPWF : strFPWF = Fso.GetSpecialFolder(WinFolder).Path 'FullPathWindowsFolder
Public strWDN : strWDN = Fso.GetDriveName(strFPWF) 'Windows Drive Name
Public strExeBareName 'bare file name w/o windows or system folder prefixes
Public flagFW : flagFW = "SO" 'FileWrite flag: SO = Script Output, EO = Echo Output
Public oFN 'output file via script object
Dim strSysVer 'Winver.exe version number
Dim intErrNum 'error number
Dim strURL 'download URL
'greater-than chr representation
Public strGT : strGT = " -> "
'Winver.exe is in \Windows under W98, but in \System32 for other O/S's
'trap GetFileVersion error for VBScript version < 5.1
On Error Resume Next
If Fso.FileExists (strFPSF & "\Winver.exe") Then
strSysVer = Fso.GetFileVersion(strFPSF & "\Winver.exe")
Else
strSysVer = Fso.GetFileVersion(strFPWF & "\Winver.exe")
End If
intErrNum = Err.Number
On Error Goto 0
Err.Clear
'if old VBScript version
If intErrNum <> 0 Then
'store dl URL
strURL = "http://tinyurl.com/7zh0"
'if using WScript
If flagOut = "W" Then
'explain the problem
intMB = MsgBox ("This script requires VBScript 5.1 or higher " &_
"to run." & vbCRLF & vbCRLF & "The latest version of VBScript can " &_
"be downloaded at: " & strURL & vbCRLF & vbCRLF &_
"Press " & Chr(34) & "OK" & Chr(34) & " to direct your browser to " &_
"the download site or " & Chr(34) & "Cancel" & Chr(34) &_
" to quit." & vbCRLF & vbCRLF & "(WMI is also required. If it's " &_
"missing, download instructions will appear later.)", _
vbOKCancel + vbExclamation,"Unsupported VBScript Version!")
'if dl wanted now, send browser to dl site
If intMB = 1 Then Wshso.Run strURL
'if using CScript
Else 'flagOut = "C"
'explain the problem
WScript.Echo Chr(34) & "Silent Runners" & Chr(34) & " requires " &_
"VBScript 5.1 or higher to run." & vbCRLF & vbCRLF &_
"It can be downloaded at: " & strURL
End If 'WScript or CScript?
'quit the script
WScript.Quit
End If 'error encountered?
'use WINVER.EXE file version to determine O/S
If Instr(Left(strSysVer,3),"4.1") > 0 Then
strOS = "W98" : strOSLong = "Windows 98"
ElseIf Instr(Left(strSysVer,5),"4.0.1") > 0 Then
strOS = "NT4" : strOSLong = "Windows NT 4.0"
ElseIf Instr(Left(strSysVer,8),"4.0.0.95") > 0 Then
strOS = "W98" : strOSLong = "Windows 95 (interpreted as Windows 98)"
ElseIf Instr(Left(strSysVer,3),"5.0") > 0 Then
strOS = "W2K" : strOSLong = "Windows 2000"
ElseIf Instr(Left(strSysVer,3),"5.1") > 0 Then
'SP0 & SP1 = 5.1.2600.0, SP2 = 5.1.2600.2180
strOS = "WXP" : strOSLong = "Windows XP"
If Instr(strSysVer,".2180") > 0 Then strOSLong = "Windows XP SP2"
ElseIf Instr(Left(strSysVer,3),"4.9") > 0 Then
strOS = "WME" : strOSLong = "Windows Millennium"
ElseIf Instr(Left(strSysVer,3),"5.2") > 0 Then
strOS = "WS2K3" : strOSLong = "Windows Server 2003"
If flagOut = "W" Then
MsgBox "The " & Chr(34) & "Silent Runners" & Chr(34) & " script cannot " &_
"run under Windows Server 2003." & vbCRLF & vbCRLF & "This script will " &_
"exit.",48,"WS2K3 Detected!"
WScript.Quit
Else 'flagOut = "C"
WScript.Echo Chr(34) & "Silent Runners" & Chr(34) & " cannot " &_
"run under Windows Server 2003." & vbCRLF & vbCRLF & "This script will " &_
"exit."
WScript.Quit
End If
Else
If flagOut = "W" Then
intMB = MsgBox ("The " & Chr(34) & "Silent Runners" & Chr(34) & " script cannot " &_
"determine the operating system." & vbCRLF & vbCRLF & "Click " &_
Chr(34) & "OK" & Chr(34) & " to send an e-mail to the author, providing the following information:" &_
vbCRLF & vbCRLF & "WINVER.EXE file version = " & strSysVer & vbCRLF & vbCRLF & "or click " & Chr(34) &_
"Cancel" & Chr(34) & " to quit.",49,"O/S Unknown!")
If intMB = 1 Then Wshso.Run "mailto:Andrew%20Aronoff%20" &_
"<%73%72.%6F%73.%76%65%72.%65%72%72%6F%72@%61%61%72%6F%6E%6F%66%66.%63%6F%6D>?subject=Silent%20Runners%20" &_
"OS%20Version%20Error&body=WINVER.EXE%20file%20version%20=%20" & strSysVer
Else 'flagOut = "C"
WScript.Echo Chr(34) & "Silent Runners" & Chr(34) & " cannot " &_
"determine the operating system." & vbCRLF & vbCRLF & "This script will exit."
End If
WScript.Quit
End If
'array of Run keys, counter x 5, hive member, startup folder file, startup file shortcut
Dim arRunKeys, i, ii, j, k, l, oHiveElmt, oSUFi, oSUSC
'Run key names, keys x 2, value type, name member, key member x 2
Dim arNames(), arKeys(), arType, oName, oKey, oKey2
'values x 3, single character, startup folder name, startup folder
Dim strValue, strValue2, strValue3, strChr, arSUFN, oSUF
'output file msg x 2, warning string, title lines x 2, register key x 2, executable extension array
Dim strLine, strLine1, strLine2, strWarn, strTitleLine1, strTitleLine2, strKey, strKey2, arExeExt
'output file name string, short name, PIF path string, single binary character
Dim strFN, strFNS, strPIFTgt, bin1C
Public flagTLW : flagTLW = False 'flag Title Line Written
Public flagSTLW : flagSTLW = False 'flag Sub-Title Line Written
Dim flagInfect : flagInfect = False 'flag infected condition
Dim flagMatch 'flag matching keys
Dim ScrPath : ScrPath = Fso.GetParentFolderName(WScript.ScriptFullName)
If Right(ScrPath,1) <> "\" Then ScrPath = ScrPath & "\"
'initialize Path of Output File Folder to script path
Dim strPathOFFo : strPathOFFo = ScrPath
'constant dictionary
Dim arHives(1,1)
arHives(0,0) = "HKCU" : arHives(1,0) = "HKLM"
arHives(0,1) = &H80000001 : arHives(1,1) = &H80000002
'create output file name with computer name & today's date
'Startup Programs (pc_name_here) yyyy-mm-dd.txt
'check if output directory was supplied as argument
If WshoArgs.length > 0 Then
'if argument directory exists
If Fso.FolderExists(WshoArgs(0)) Then
'get the path
Dim oOFFo : Set oOFFo = Fso.GetFolder(WshoArgs(0))
strPathOFFo = oOFFo.Path
If Right(strPathOFFo,1) <> "\" Then strPathOFFo = strPathOFFo & "\"
Set oOFFo=Nothing
Else 'argument directory doesn't exist
If flagOut = "W" Then 'pop up a message window
Wshso.Popup "The specified directory:" & vbCRLF &_
Chr(34) & UCase(WshoArgs(0)) & Chr(34) & vbCRLF &_
"... can't be found." & vbCRLF & vbCRLF &_
"The output file will be put into the script directory:" &_
vbCRLF & Chr(34) & ScrPath & Chr(34),5, _
"Output Directory Not Found!", vbOKOnly + vbExclamation
Else 'flagOut = "C" 'write the message to the console
WScript.Echo "The specified directory: " &_
Chr(34) & UCase(WshoArgs(0)) & Chr(34) &_
" can't be found." & vbCRLF & vbCRLF &_
"The output file will be put into the script directory: " &_
Chr(34) & ScrPath & Chr(34) & vbCRLF
End If 'WScript host?
'since argument directory doesn't exist, use the script directory
strPathOFFo = ScrPath
End If 'argument directory exists?
End If 'directory argument was passed?
'assemble report file name: LFN for all O/S's except W98;
' SFN for W98 = root of system (boot) partition\SUPgms.txt
strFN = strPathOFFo & "Startup Programs [RED] (" & oNetwk.ComputerName & ") " & FmtDate & ".txt"
strFNS = strWDN & "\" & "SUPgms.txt"
Set oNetwk=Nothing
'try to create report file & write to it
On Error Resume Next
'delete report file if it exists to avoid bug with W2KFR SP0 that
'replaced chrs in file instead of replacing file with ">" redirection
If Fso.FileExists(strFN) Then Fso.DeleteFile(strFN)
Err.Clear
Set oFN = Fso.CreateTextFile(strFN,True)
oFN.WriteLine Chr(34) & "Silent Runners.vbs" & Chr(34) & ", revision " &_
strRevNo & ", launched at: " & FmtTime
intErrNum = Err.Number
On Error Goto 0
Err.Clear
'*****
intErrNum = 1
'if oFN can't be written to, echo must be used
If intErrNum > 0 Then
flagFW = "EO" 'switch to Echo output
strGT = " -^> " 'escape > for NT4/W2K/WXP
oFN = 0 'assign oFN non-object value
'prepare first line of report file
strLine = Chr(34) & "Silent Runners.vbs" & Chr(34) & ", revision " &_
strRevNo & " (Echo output), launched at: " & FmtTime & "> "
If strOS = "W98" Or strOs = "WME" Then
'echo into SFN (echo to LFN incurs 62-chr line length limit)
strLine = strLine & strFNS
'avoid > under W98 since it cannot be easily escaped
strGT = " -) "
Else
'for all other O/S's, echo into LFN
strLine = strLine & Chr(34) & strFN & Chr(34)
End If 'W98?
'create report file with Echo
Wshso.Run "%COMSPEC% /c echo " & strLine,0,TRUE
End If 'intErrNum > 0?
WriteOut "Operating System: " & strOSLong : SkipLine : SkipLine
'use WMI to connect to the registry
On Error Resume Next
Dim oReg : Set oReg = GetObject("winmgmts:root\default:StdRegProv")
intErrNum = Err.Number
On Error Goto 0
Err.Clear
If intErrNum <> 0 Then
strURL = "http://tinyurl.com/7wd7"
If strOS = "W98" Then strURL = "http://tinyurl.com/jbxe"
WriteOut "This script requires WMI, which can be downloaded at: " & strURL
If IsObject(oFN) Then oFN.Close
If flagOut = "W" Then
intMB = MsgBox ("This script requires " & Chr(34) & "WMI" & Chr(34) &_
", Windows Management Instrumentation, to run." & vbCRLF &_
vbCRLF & "It can be downloaded at: " & strURL & vbCRLF & vbCRLF &_
"Press " & Chr(34) & "OK" & Chr(34) & " to direct your browser to " &_
"the download site or " & Chr(34) & "Cancel" & Chr(34) &_
" to quit.", vbOKCancel + vbExclamation,"WMI Not Installed!")
If intMB = 1 Then Wshso.Run strURL
Else 'flagOut = "C"
WScript.Echo Chr(34) & "Silent Runners" & Chr(34) & " requires " &_
Chr(34) & "WMI" & Chr(34) & ", Windows Management Instrumentation, " &_
"to run." & vbCRLF & vbCRLF & "It can be downloaded at: " & strURL
End If
WScript.Quit
End If 'WMI execution error
'I. Examine HKCU/HKLM... Run/RunOnce/RunOnceEx/RunServices/RunServicesOnce
' and HKCU/HKLM... Policies\Explorer\Run
'put keys in array (Key Index 0 - 6)
arRunKeys = Array ("SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\Explorer\Run", _
"SOFTWARE\Microsoft\Windows\CurrentVersion\Run", _
"SOFTWARE\Microsoft\Windows\CurrentVersion\RunOnce", _
"SOFTWARE\Microsoft\Windows\CurrentVersion\RunOnce\Setup", _
"SOFTWARE\Microsoft\Windows\CurrentVersion\RunOnceEx", _
"SOFTWARE\Microsoft\Windows\CurrentVersion\RunServices", _
"SOFTWARE\Microsoft\Windows\CurrentVersion\RunServicesOnce")
'Key Execution Flag/Subkey Recursion Flag array
'
'first number in the ordered pair in the array immediately below pertains to execution of the key:
'0: not executed (ignore)
'1: may be executed so display with EXECUTION UNLIKELY warning
'2: executable
'
'second number in the ordered pair pertains to subkey recursion
'0: subkeys not used
'1: subkey recursion necessary
'Hive HKCU - 0 HKLM - 1
'
'Key 0 1 2 3 4 5 6 0 1 2 3 4 5 6
'Index
'
'O/S:
'W98 0,0 2,0 2,0 0,0 0,0 0,0 0,0 0,0 2,0 2,0 2,0 2,1 2,0 2,0
'WME 0,0 2,0 2,0 0,0 0,0 0,0 0,0 0,0 2,0 2,0 2,0 2,1 2,0 2,0
'NT4 1,0 2,0 2,0 0,0 0,0 0,0 0,0 1,0 2,0 2,0 1,0 2,1 0,0 0,0
'W2K 2,1 2,1 2,1 0,0 0,0 0,0 0,0 2,1 2,1 2,1 0,0 2,1 0,0 0,0
'WXP 2,0 2,0 2,0 0,0 0,0 0,0 0,0 2,0 2,0 2,0 1,0 2,1 0,0 0,0
'WS2K3 ??? ??? ??? ??? ??? ??? ??? ??? ??? ??? ??? ??? ??? ???
'arRegFlag(i,j,k): put flags in array by O/S:
'hive = i (0 or 1), key_# = j (0-6), flags (key execution/subkey recursion) = k (0 or 1)
' k = 0 holds key execution value = 0/1/2
' 1 holds subkey recursion value = 0/1
Dim arRegFlag()
ReDim arRegFlag(1,6,1)
'initialize entire array to zero
For i = 0 To 1 : For j = 0 To 6 : For k = 0 To 1
arRegFlag(i,j,k) = 0
Next : Next : Next
'add data to array for O/S that's running
'W98 0,0 2,0 2,0 0,0 0,0 0,0 0,0 0,0 2,0 2,0 2,0 2,1 2,0 2,0
If strOS = "W98" Or strOS = "WME" Then
arRegFlag(0,1,0) = 2 'HKCU,Run = no-warn
arRegFlag(0,2,0) = 2 'HKCU,RunOnce = no-warn
arRegFlag(1,1,0) = 2 'HKLM,Run = no-warn
arRegFlag(1,2,0) = 2 'HKLM,RunOnce = no-warn
arRegFlag(1,3,0) = 2 'HKLM,RunOnce\Setup = no-warn
arRegFlag(1,4,0) = 2 'HKLM,RunOnceEx = no-warn
arRegFlag(1,4,1) = 1 'HKLM,RunOnceEx = sub-keys
arRegFlag(1,5,0) = 2 'HKLM,RunServices = no-warn
arRegFlag(1,6,0) = 2 'HKLM,RunServicesOnce = no-warn
End If
'NT4 1,0 2,0 2,0 0,0 0,0 0,0 0,0 1,0 2,0 2,0 1,0 2,1 0,0 0,0
If strOS = "NT4" Then
arRegFlag(0,0,0) = 1 'HKCU,Explorer\Run = warning
arRegFlag(0,1,0) = 2 'HKCU,Run = no-warn
arRegFlag(0,2,0) = 2 'HKCU,RunOnce = no-warn
arRegFlag(1,0,0) = 1 'HKLM,Explorer\Run = warning
arRegFlag(1,1,0) = 2 'HKLM,Run = no-warn
arRegFlag(1,2,0) = 2 'HKLM,RunOnce = no-warn
arRegFlag(1,3,0) = 1 'HKLM,RunOnce\Setup = warning
arRegFlag(1,4,0) = 2 'HKLM,RunOnceEx = no-warn
arRegFlag(1,4,1) = 1 'HKLM,RunOnceEx = sub-keys
End If
'W2K 2,1 2,1 2,1 0,0 0,0 0,0 0,0 2,1 2,1 2,1 0,0 2,1 0,0 0,0
If strOs = "W2K" Then
arRegFlag(0,0,0) = 2 'HKCU,Explorer\Run = no-warn
arRegFlag(0,0,1) = 1 'HKCU,Explorer\Run = sub-keys
arRegFlag(0,1,0) = 2 'HKCU,Run = no-warn
arRegFlag(0,1,1) = 1 'HKCU,Run = sub-keys
arRegFlag(0,2,0) = 2 'HKCU,RunOnce = no-warn
arRegFlag(0,2,1) = 1 'HKCU,RunOnce = sub-keys
arRegFlag(1,0,0) = 2 'HKLM,Explorer\Run = no-warn
arRegFlag(1,0,1) = 1 'HKLM,Explorer\Run = sub-keys
arRegFlag(1,1,0) = 2 'HKLM,Run = no-warn
arRegFlag(1,1,1) = 1 'HKLM,Run = sub-keys
arRegFlag(1,2,0) = 2 'HKLM,RunOnce = no-warn
arRegFlag(1,2,1) = 1 'HKLM,RunOnce = sub-keys
arRegFlag(1,4,0) = 2 'HKLM,RunOnceEx = no-warn
arRegFlag(1,4,1) = 1 'HKLM,RunOnceEx = sub-keys
End If
'WXP 2,0 2,0 2,0 0,0 0,0 0,0 0,0 2,0 2,0 2,0 1,0 2,1 0,0 0,0
If strOs = "WXP" Then
arRegFlag(0,0,0) = 2 'HKCU,Explorer\Run = no-warn
arRegFlag(0,1,0) = 2 'HKCU,Run = no-warn
arRegFlag(0,2,0) = 2 'HKCU,RunOnce = no-warn
arRegFlag(1,0,0) = 2 'HKLM,Explorer\Run = no-warn
arRegFlag(1,1,0) = 2 'HKLM,Run = no-warn
arRegFlag(1,2,0) = 2 'HKLM,RunOnce = no-warn
arRegFlag(1,3,0) = 1 'HKLM,RunOnce\Setup = warning
arRegFlag(1,4,0) = 2 'HKLM,RunOnceEx = no-warn
arRegFlag(1,4,1) = 1 'HKLM,RunOnceEx = sub-keys
End If
'write registry header lines to file
strLine = "Startup items buried in registry:"
WriteOut strLine : WriteOut String(Len(strLine),"-") : SkipLine
'for each hive
For i = 0 To 1
'for each key
For j = 0 To 6
'if key is not ignored
If arRegFlag(i,j,0) > 0 Then
'intialize string with warning if necessary
strWarn = ""
If arRegFlag(i,j,0) = 1 Then strWarn = "EXECUTION UNLIKELY: "
'find key's entries
EnumKeyData arHives(i,1), arHives(i,0), arRunKeys(j), strWarn
'recurse subkeys if necessary
If arRegFlag(i,j,1) = 1 Then
'put all subkeys into array
oReg.EnumKey arHives(i,1),arRunKeys(j),arKeys
'if sub-keys exist
If IsArray(arKeys) Then
'in W98, if no sub-keys exist, IsArray(arKeys) = True & UBound(arKeys) = -1
'in W2K, False
If UBound(arKeys) >= 0 Then
'for each subkey
For Each oKey in arKeys
'find key's entries
EnumKeyData arHives(i,1), arHives(i,0), arRunKeys(j) & "\" & oKey, strWarn
Next
End If 'UBounds sub-keys array >= 0?
End If 'sub-keys array exists?
End If 'enum sub-keys?
End If 'arRegFlag(i,j,0) > 0
Next 'Run key
Next 'Hive
'recover array memory
ReDim arRunKeys(0)
ReDim arKeys(0)
ReDim arRegFlag(0,0,0)
'II. Examine HKLM... Active Setup\Installed Components
'flags True if only numeric & comma chrs in Version values
Dim flagHKLMVer, flagHKCUVer
'StubPath Value string, HKLM Version value, HKCU Version value
Dim strSPV, strHKLMVer, strHKCUVer
Dim arHKLMKeys, arHKCUKeys, oHKLMKey, oHKCUKey
strKey = "Software\Microsoft\Active Setup\Installed Components"
'find all the subkeys
oReg.EnumKey HKLM, strKey, arHKLMKeys 'HKLM
oReg.EnumKey HKCU, strKey, arHKCUKeys 'HKCU
'enumerate HKLM keys if present
If IsArray(arHKLMKeys) Then
'for each HKLM key
For Each oHKLMKey In arHKLMKeys
'get the StubPath value
oReg.GetStringValue HKLM,strKey & "\" & oHKLMKey,"StubPath",strSPV
'if the StubPath value exists
If Not IsNull(strSPV) And strSPV <> "" Then
flagMatch = False
'if HKCU keys present
If IsArray(arHKCUKeys) Then
'for each HKCU key
For Each oHKCUKey in arHKCUKeys
'if identical HKLM key exists
If oHKLMKey = oHKCUKey Then
'assume Version fmts are OK
flagHKLMVer = True : flagHKCUVer = True
'get HKLM & HKCU Version values
'if values are not set, returned strings will be random chrs (W2K) or empty string (W98)
oReg.GetStringValue HKLM,strKey & "\" & oHKLMKey,"Version",strHKLMVer 'HKLM Version #
oReg.GetStringValue HKCU,strKey & "\" & oHKCUKey,"Version",strHKCUVer 'HKCU Version #
'if HKLM Version name exists (value may not be set!)
If Not IsNull(strHKLMVer) Then
'the next two loops check for allowed chars (numeric & comma)
' in returned Version values
For i = 1 To Len(strHKLMVer)
strChr = Mid(strHKLMVer,i,1)
If Not IsNumeric(strChr) And strChr <> "," Then flagHKLMVer = False
Next
End If 'HKLM Version not null
'if HKCU Version name exists (value may not be set!)
If Not IsNull(strHKCUVer) Then
'check that value consists only of numeric & comma chrs
For i = 1 To Len(strHKCUVer)
strChr = Mid(strHKCUVer,i,1)
If Not IsNumeric(strChr) And strChr <> "," Then flagHKCUVer = False
Next
End If 'HKCU Version null or MT?
'if HKLM Ver # has illegal fmt (i.e., is not set) or doesn't exist (is Null)
' or is empty, match = True
'if HKCU/HKLM Ver # fmts OK And HKCU Ver # >= HKLM Ver #, match = True
'if HKLM Ver # = "0,0" and HKCU Ver # = "", key will output
' but StubPath will not launch
If Not flagHKLMVer Or IsNull(strHKLMVer) Or strHKLMVer = "" Then flagMatch = True
If flagHKLMVer And flagHKCUVer And strHKCUVer >= strHKLMVer Then flagMatch = True
End If 'HKCU key=HKLM key?
Next 'HKCU Installed Components key
End If 'HKCU Installed Components subkeys exist?
'if the StubPath will launch
If Not flagMatch Then
'get the default value (program name)
oReg.GetStringValue HKLM,strKey & "\" & oHKLMKey,"",strHKCUVer
'output the title line if not already done
If Not flagTLW Then
WriteOut "HKLM" & "\" & strKey & "\"
flagTLW = True
End If
On Error Resume Next
'write the quote-delimited name and default value to a file
WriteOut Chr(34) & oHKLMKey & "\(Default)" & Chr(34) & " = " &_
Chr(34) & strHKCUVer & Chr(34)
If Err.Number <> 0 Then WriteOut Chr(34) & oHKLMKey & "\(Default)" & Chr(34) &_
" = (no title provided)"
Err.Clear
WriteOut Space(Len(oHKLMKey)+1) & "\StubPath = " &_
Chr(34) & strSPV & Chr(34) & CoName(IDExe(strSPV))
If Err.Number <> 0 Then WriteOut Space(Len(oHKLMKey)+1) & "\StubPath = " &_
"** WARNING -- empty or invalid data! **"
Err.Clear
On Error GoTo 0
End If 'flagMatch false?
End If 'StubPath value exists?
Next 'HKLM Installed Components subkey
End If 'HKLM Installed Components subkeys exist?
If flagTLW Then SkipLine
flagTLW = False
'recover array memory
ReDim arHKLMKeys(0)
ReDim arHKCUKeys(0)
'III. Examine HKLM... Explorer\Browser Helper Objects
strKey = "Software\Microsoft\Windows\CurrentVersion\Explorer\Browser Helper Objects"
'find all the subkeys
oReg.EnumKey HKLM, strKey, arKeys
'enumerate data if present
If IsArray(arKeys) Then
'for each key
For Each oKey In arKeys
If Not flagTLW Then
WriteOut "HKLM" & "\" & strKey & "\"
flagTLW = True
End If
If Len(oKey) = 38 Then 'oKey is CLSID
'get the data
oReg.GetStringValue HKLM,strKey & "\" & oKey,"",strValue
'if the name doesn't exist
If IsNull(strValue) Or strValue = "" Then
'check the CLSID default value
strKey2 = "Software\Classes\CLSID\" & oKey
oReg.GetStringValue HKLM,strKey2,"",strValue
End If
'if the name doesn't exist
If IsNull(strValue) Or strValue = "" Then
'use a standard string
strValue = "(no title provided)"
Else 'the name exists so embed it in quotes
strValue = Chr(34) & strValue & Chr(34)
End If
'resolve the data via HKLM\Software\Classes\CLSID\{data}\InProcServer32
strKey2 = "Software\Classes\CLSID\" & oKey & "\InProcServer32"
oReg.GetExpandedStringValue HKLM,strKey2,"",strValue2
If IsNull(strValue2) Or strValue2 = "" Then strValue2 = "(no data)"
On Error Resume Next
'write the quote-delimited name and value to a file
WriteOut oKey & "\(Default) = " & strValue
If Err.Number <> 0 Then WriteOut oKey & "\(Default) = (no title provided)"
Err.Clear
WriteOut " " & strGT & "resolves to: {CLSID}\InprocServer32\(Default) = " &_
Chr(34) & strValue2 & Chr(34) & CoName(IDExe(strValue2))
If Err.Number <> 0 Then
WriteOut " " & strGT & "resolves to: {CLSID}\InprocServer32\(Default) = " &_
"** WARNING! empty or invalid data **"
End If
Err.Clear
On Error GoTo 0
End If 'oKey CSID?
Next 'BHO subkey
End If 'BHO subkeys exist?
If flagTLW Then SkipLine
flagTLW = False
'recover array memory
ReDim arKeys(0)
'IV. Examine HKLM... Explorer\SharedTaskScheduler
strKey = "Software\Microsoft\Windows\CurrentVersion\Explorer\SharedTaskScheduler"
'find all the names in the key
oReg.EnumValues HKLM, strKey, arNames, arType
'enumerate data if present
If IsArray(arNames) Then
'for each name
For Each oName In arNames
If Len(oName) = 38 Then 'oName is CLSID
'get the data
oReg.GetStringValue HKLM,strKey,oName,strValue
'resolve the data via HKLM\Software\Classes\CLSID\{data}\InProcServer32
strKey2 = "Software\Classes\CLSID\" & oName & "\InProcServer32"
oReg.GetExpandedStringValue HKLM,strKey2,"",strValue2
strLine = LCase(Fso.GetSpecialFolder(SysFolder).Path)
'write unexpected quote-delimited name and value to the file
If InStr(LCase(strValue2),strLine & "\browseui.dll") = 0 Then
'output the title line if not already done
If Not flagTLW Then
WriteOut "HKLM" & "\" & strKey & "\"
flagTLW = True
End If
On Error Resume Next
WriteOut "INFECTION WARNING! " & Chr(34) & oName & Chr(34) &_
" = " & Chr(34) & strValue & Chr(34)
If Err.Number <> 0 Then WriteOut Chr(34) & oName & Chr(34) &_
" = ** WARNING -- empty or invalid data! **"
Err.Clear
WriteOut " " & strGT & "resolves to: {CLSID}\InprocServer32\(Default) = " &_
strValue2 & CoName(IDExe(strValue2))
If Err.Number <> 0 Then WriteOut " " & strGT & "resolves to: " &_
"{CLSID}\InprocServer32\(Default) = ** WARNING -- empty or invalid data! **"
Err.Clear
On Error GoTo 0
End If 'unexpected data?
Else 'oName is _not_ CLSID
'output the title line if not already done
If Not flagTLW Then
WriteOut "HKLM" & "\" & strKey & "\"
flagTLW = True
End If
WriteOut Chr(34) & oName & Chr(34) & " = ** INVALID DATA (not CLSID) **"
End If 'oName CLSID?
Next 'arNames array member
End If 'arNames array exists
If flagTLW Then SkipLine
flagTLW = False
'recover array memory
ReDim arNames(0)
'V. Examine HKCU/HKLM... ShellServiceObjectDelayLoad
strKey = "Software\Microsoft\Windows\CurrentVersion\ShellServiceObjectDelayLoad"
'Dim arHives(1,1)
'arHives(0,0) = "HKCU" : arHives(1,0) = "HKLM"
'arHives(0,1) = &H80000001 : arHives(1,1) = &H80000002
For i = 0 To 1 'for each hive
'find all the names in the key
oReg.EnumValues arHives(i,1), strKey, arNames, arType
'enumerate data if present
If IsArray(arNames) Then
'write the full key name
WriteOut arHives(i,0) & "\" & strKey & "\"
flagTLW = True
'for each name
For Each oName In arNames
'get the data
oReg.GetStringValue arHives(i,1),strKey,oName,strValue
If Len(strValue) = 38 Then 'data is CLSID
'find the data for HKLM\Software\Classes\CLSID\{this data}\InProcServer32
strKey2 = "Software\Classes\CLSID\" & strValue & "\InProcServer32"
oReg.GetStringValue HKLM,strKey2,"",strValue2
'write the quote-delimited name and value to the file
On Error Resume Next
WriteOut Chr(34) & oName & Chr(34) & " = " & Chr(34) & strValue & Chr(34)
If Err.Number <> 0 Then WriteOut Chr(34) & oName & Chr(34) &_
" = ** WARNING -- empty or invalid data! **"
Err.Clear
WriteOut " " & strGT & "resolves to: {CLSID}\InprocServer32\(Default) = " &_
Chr(34) & strValue2 & Chr(34) & CoName(IDExe(strValue2))
If Err.Number <> 0 Then WriteOut " " & strGT & "resolves to: " &_
"{CLSID}\InprocServer32\(Default) = ** WARNING -- empty or invalid data! **"
Err.Clear
On Error GoTo 0
Else 'corrupt CLSID
'write the quote-delimited name and bad data warning to the file
WriteOut Chr(34) & oName & Chr(34) & " = ** INVALID DATA ** (not CLSID)"
End If
Next
End If 'arNames array exists
If flagTLW Then SkipLine
flagTLW = False
Next 'hive
strLine = ""
'recover array memory
ReDim arType(0)
ReDim arNames(0)
'VI. Find values of specific names:
' HKCU... Command Processor\AutoRun
' HKCU... Policies\System\Shell (XP only!)
' HKCU... Windows\load & run
' HKCU... Command Processor\AutoRun
' HKCU... Winlogon\Shell
' HKLM... Windows\AppInit_DLLs
' HKLM... Winlogon\Shell & Userinit & System & Ginadll
If strOS <> "W98" And strOS <> "WME" Then
'HKCU\Software\Microsoft\Command Processor\AutoRun
RegDataChk HKCU, "SOFTWARE\Microsoft\Command Processor", "AutoRun", strValue, ""
If flagTLW Then SkipLine
flagTLW = False
If strOS = "WXP" Then
'HKCU\SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\System\Shell
'"Shell" = ""
RegDataChk HKCU, "SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\System", "Shell", strValue, ""
If flagTLW Then SkipLine
flagTLW = False
End If
'HKCU\Software\Microsoft\Windows NT\CurrentVersion\Windows\load & run
RegDataChk HKCU, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Windows", "load", strValue, ""
RegDataChk HKCU, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Windows", "run", strValue, ""
If flagTLW Then SkipLine
flagTLW = False
'HKCU\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon\Shell
'"Shell" = "Explorer.exe"
RegDataChk HKCU, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon", "Shell", strValue, "explorer.exe"
If flagTLW Then SkipLine
flagTLW = False
'HKLM\Software\Microsoft\Command Processor\AutoRun
RegDataChk HKLM, "SOFTWARE\Microsoft\Command Processor", "AutoRun", strValue, ""
If flagTLW Then SkipLine
flagTLW = False
'HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Windows\AppInit_DLLs
RegDataChk HKLM, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Windows", "AppInit_DLLs", strValue, ""
If flagTLW Then SkipLine
flagTLW = False
'HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon\GinaDLL & Shell & Userinit & System
'"GinaDLL" = "MSGina.dll"; "Shell" = "Explorer.exe"; "Userinit" = "%SystemRoot%\system32\userinit.exe,"; "System" = ""
RegDataChk HKLM, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon", "GinaDLL", strValue, "msgina.dll"
RegDataChk HKLM, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon", "Shell", strValue, "explorer.exe"
'find value for "Userinit" name
strKey = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon"
oReg.GetStringValue HKLM,strKey,"Userinit",strValue
If strOS = "NT4" And LCase(strValue) <> "userinit,nddeagnt.exe" Then
flagInfect = True
ElseIf strOS <> "NT4" And (InStr(strValue,",") > 0 And Len(Trim(Mid(strValue,InStr(strValue,",")+1))) > 0 Or _
InStr(LCase(strValue),"userinit.exe") = 0) Then
flagInfect = True
End If 'userinit string test
If flagInfect Then
If Not flagTLW Then
WriteOut "HKLM" & "\" & strKey
flagTLW = True
End If
strLine = "INFECTION WARNING! "
'write name and value to file
WriteOut strLine & Chr(34) & "Userinit" & Chr(34) & " = " &_
Chr(34) & strValue & Chr(34) & LRParse(strValue)
End If 'flagInfect
flagInfect = False
If strOS = "NT4" Then
RegDataChk HKLM, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon", "System", strValue, "lsass.exe"
Else
RegDataChk HKLM, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon", "System", strValue, ""
End If
If flagTLW Then SkipLine
flagTLW = False
'HKLM\System\CurrentControlSet\Control\Session Manager\BootExecute
strKey = "System\CurrentControlSet\Control\Session Manager"
oReg.GetMultiStringValue HKLM,strKey,"BootExecute",arNames
strLine = ""
'alert if autocheck not in string
For i = 0 To UBound(arNames)
If InStr(LCase(arNames(i)),"autocheck") = 0 Then
If Not flagTLW Then
WriteOut "HKLM" & "\" & strKey & "\"
flagTLW = True
End If
strLine = strLine & arNames(i) & " "
End If 'value = autocheck?
Next 'arNames member
'write name and value to file
On Error Resume Next
If flagTLW Then
WriteOut "INFECTION WARNING! " & Chr(34) & "BootExecute" &_
Chr(34) & " = " & Chr(34) & RTrim(strLine) & Chr(34) & LRParse(strLine)
If Err.Number <> 0 Then WriteOut strLine & Chr(34) &_
"BootExecute" & Chr(34) & " = ** WARNING -- empty or invalid data! **"
Err.Clear
On Error GoTo 0
SkipLine
End If
End If 'not W98/WME
flagTLW = False
strLine = ""
'VII. Examine HKLM... Winlogon\Notify\ subkey DLLName values
Dim arSK : Set arSK = CreateObject("Scripting.Dictionary") 'key, item
If strOS = "W2K" Then
arSK.Add "crypt32chain", "crypt32.dll"
arSK.Add "cryptnet", "cryptnet.dll"
arSK.Add "cscdll", "cscdll.dll"
arSK.Add "sclgntfy", "sclgntfy.dll"
arSK.Add "senslogn", "wlnotify.dll"
arSK.Add "termsrv", "wlnotify.dll"
arSK.Add "wzcnotif", "wzcdlg.dll"
ElseIf strOS = "WXP" Or strOS = "WS2K3" Then
arSK.Add "crypt32chain", "crypt32.dll"
arSK.Add "cryptnet", "cryptnet.dll"
arSK.Add "cscdll", "cscdll.dll"
arSK.Add "sccertprop", "wlnotify.dll"
arSK.Add "schedule", "wlnotify.dll"
arSK.Add "sclgntfy", "sclgntfy.dll"
arSK.Add "senslogn", "wlnotify.dll"
arSK.Add "termsrv", "wlnotify.dll"
arSK.Add "wlballoon", "wlnotify.dll"
End If
Dim arSKk : arSKk = arSK.Keys
Dim arSKi : arSKi = arSK.Items
If strOS <> "W98" And strOS <> "WME" Then
strKey = "Software\Microsoft\Windows NT\CurrentVersion\Winlogon\Notify"
'find all the subkeys
oReg.EnumKey HKLM, strKey, arKeys
'enumerate data if present
If IsArray(arKeys) Then
'for each key
For Each oKey In arKeys
'get the DLLName data
oReg.GetStringValue HKLM,strKey & "\" & oKey,"DLLName",strValue
flagInfect = True
For i = 0 To arSK.Count-1
'if key = dictionary key & value = dictionary item
If LCase(oKey) = arSKk(i) And LCase(strValue) = arSKi(i) Then
'toggle flag & exit -- no output necessary
flagInfect = False : Exit For
End If
Next 'dictionary key
If flagInfect Then 'if flag not found in O/S-specific dictionary
'output section title lines if not already done
If Not flagTLW Then
WriteOut "HKLM" & "\" & strKey & "\"
flagTLW = True
End If
'check for empty or null data
If IsNull(strValue) Or strValue = "" Then strValue = "(no data)"
'try writing, on error write "no data"
On Error Resume Next
'write the quote-delimited name and value to a file
WriteOut "INFECTION WARNING! " & Chr(34) & oKey & "\DLLName" &_
Chr(34) & " = " & Chr(34) & strValue & Chr(34) & CoName(IDExe(strValue))
If Err.Number <> 0 Then WriteOut "INFECTION WARNING! " &_
Chr(34) & oKey & "\DLLName" & Chr(34) & " = (no data)"
Err.Clear
On Error GoTo 0
End If 'flag not found in dictionary?
Next 'Notify subkey
End If 'Notify subkeys exist?
If flagTLW Then SkipLine
flagTLW = False
End If 'not W98/WME
'recover array memory
ReDim arKeys(0)
'VIII. For W2K & WXP, check for startup/shutdown & logon/logoff scripts
Dim strCmd : strCmd = "" 'script command line string
Select Case strOS
Case "W2K"
'collection flag
Dim flagColl : flagColl = False
'for every hive
For i = 0 To 1
'check for HKCU, then HKLM key
strKey = "Software\Policies\Microsoft\Windows\System\Scripts"
If oReg.EnumValues(arHives(i,1), strKey, arNames, arType) = 0 Then
'if name/value pairs exist in the Scripts key
If TypeName(arNames) <> "Null" Then
'for each name
For Each oName In arNames
'get the value
oReg.GetStringValue arHives(i,1),strKey,oName,strValue
'if value points to SCRIPTS.INI, parse the file
If Fso.FileExists(strValue & "\scripts.ini") Then
ScrIP strValue, oName
'if SCRIPTS.INI doesn't appear to exist, output a warning
ElseIf strValue <> "" Then
WriteOut arHives(i,0) & "\" & strKey
WriteOut " ** WARNING! Either " & Chr(34) & strValue & "\scripts.ini" &_
Chr(34) & " doesn't exist"
WriteOut Space(13) & "or there is insufficient permission to read it! **"
flagTLW = True
End If
Next 'Scripts key name
End If 'Scripts key name/value pairs exist?
End If 'Scripts key exists?
If flagTLW Then SkipLine
flagTLW = False
Next 'hive type
Case "WXP"
'Base Key string
Dim strBK : strBK = "Software\Policies\Microsoft\Windows\System\Scripts\"
Dim arXPS() 'WXP Script array
ReDim arXPS(1,1) '2 x 2 array
arXPS(0,0) = "Logoff" : arXPS(0,1) = "Logon"
arXPS(1,0) = "Shutdown" : arXPS(1,1) = "Startup"
Dim arNKSE 'Numbered (master) Keys containing Script Executable values
Dim strSPXP : strSPXP = "" 'Script Path XP string
'values: DisplayName, FileSysPath, Script, Parameter
Dim strDispName, strFSP, strScript, strParam
'for every hive
For i = 0 To 1
'for every script type
For j = 0 To 1
'look for script type subkeys
oReg.EnumKey arHives(i,1),strBK & arXPS(i,j),arKeys
'enumerate data if present
If IsArray(arKeys) Then
'for each numbered key header (containing numbered script keys)
For Each oKey in arKeys
'find DisplayName & FileSysPath
oReg.GetStringValue arHives(i,1),strBK & arXPS(i,j) & "\" & oKey,"DisplayName",strDispName
oReg.GetStringValue arHives(i,1),strBK & arXPS(i,j) & "\" & oKey,"FileSysPath",strFSP
'if FileSysPath value exists
If strFSP <> "" Then
'look for numbered script subkeys
oReg.EnumKey arHives(i,1),strBK & arXPS(i,j) & "\" & oKey,arNKSE
'enumerate data if present
If IsArray(arNKSE) Then
'for each numbered script key
For Each oKey2 in arNKSE
'find Parameter & Script values
oReg.GetStringValue arHives(i,1),strBK & arXPS(i,j) & "\" & oKey & "\" & oKey2,"Parameters",strParam
oReg.GetStringValue arHives(i,1),strBK & arXPS(i,j) & "\" & oKey & "\" & oKey2,"Script",strScript
'if executable string exists
If strScript <> "" Then
'form script executable string
'if script string has no backslash, use FileSysPath for directory
'and append \Scripts\[script type]\
If InStr(strScript,"\") = 0 Then
strSPXP = strFSP & "\Scripts\" & arXPS(i,j) & "\"
strCmd = strSPXP & strScript
End If
'if parameter string is not empty, append it
If Trim(strParam) <> "" Then strScript = strScript & " " & strParam
'write title lines if necessary for this master key
If Not flagTLW Then
WriteOut arHives(i,0) & "\" & strBK & arXPS(i,j) & "\" & oKey
WriteOut "DisplayName = " & Chr(34) & strDispName & Chr(34)
flagTLW = True
End If
'write script executable
WriteOut "\" & oKey2 & strGT & "launches: " & Chr(34) &_
strSPXP & strScript & Chr(34) & CoName(strCmd)
strSPXP = "" 'reset script path
End If 'executable string not empty?
Next 'numbered script executable key
If flagTLW Then SkipLine
flagTLW = False
End If 'script executable key array exists?
End If 'FileSysPath exists?
Next 'master key
If flagTLW Then SkipLine
flagTLW = False
End If 'master key array exists?
If flagTLW Then SkipLine
flagTLW = False
Next 'script type
If flagTLW Then SkipLine
flagTLW = False
Next 'hive type
If flagTLW Then SkipLine
flagTLW = False
'recover array memory
ReDim arXPS(0,0)
End Select 'W2K or WXP?
'IX. Check default executables (except "hta") for default string: "%1\" %*
' Check "hta" for mshta.exe "%1" %*
'set up executables array
arExeExt = Array("bat","com","exe","hta","pif")
'for each executable type
For i = 0 To 4
'form the registry key string
strKey = "SOFTWARE\Classes\" & arExeExt(i) & "file\shell\open\command"
'find the value
oReg.GetStringValue HKLM,strKey,"",strValue
'alert if "hta" value not system_folder_path\mshta.exe "%1" %*
'or if any other executable's value is not "%1" %*
If arExeExt(i) = "hta" Then
'check found "hta" value against expected value
If Trim(LCase(strValue)) <> LCase(Fso.GetSpecialFolder(1)) &_
"\mshta.exe ""%1"" %*" Then
'output section titles if not done already
If Not flagTLW Then DefExeTitles
'write name and value to file
strLine = "INFECTION WARNING! "
WriteOut "HKLM" & "\" & strKey & "\"
On Error Resume Next
WriteOut strLine & Chr(34) & "Default" & Chr(34) & " = " &_
Chr(34) & strValue & Chr(34) & CoName(IDExe(strValue))
If Err.Number <> 0 Then WriteOut strLine & Chr(34) &_
"Default" & Chr(34) & " = ** WARNING -- empty or invalid data! **"
Err.Clear
On Error GoTo 0
flagTLW = True
End If 'hta value = expected value?
'executable other than "hta"
Else
'check against expected value
If Trim(LCase(strValue)) <> """%1"" %*" Then
'output section titles if not done already
If Not flagTLW Then DefExeTitles
'write name and value to file
strLine = "INFECTION WARNING! "
WriteOut "HKLM" & "\" & strKey & "\"
On Error Resume Next
WriteOut strLine & Chr(34) & "Default" & Chr(34) & " = " &_
Chr(34) & strValue & Chr(34) & CoName(IDExe(strValue))
If Err.Number <> 0 Then WriteOut strLine & Chr(34) &_
"Default" & Chr(34) & " = ** WARNING -- empty or invalid data! **"
Err.Clear
On Error GoTo 0
flagTLW = True
End If 'value = expected value?
End If 'hta or not
Next 'next executable in array
If flagTLW Then SkipLine
flagTLW = False
'recover array memory
ReDim arExeExt(0)
'X. For W98/WME, check inside WIN.INI (load=, run=), SYSTEM.INI (shell=) &
' list contents of non-empty WINSTART.BAT
If strOS = "W98" Or strOS = "WME" Then
Dim oSCF 'System Configuration File
'true if in INI-file section containing targeted lines
Dim flagSection : flagSection = False
Dim intEqu 'pos'n of equals sign
'open WIN.INI
Set oSCF = Fso.OpenTextFile (strFPWF & "\WIN.INI",1)
'for each line of WIN.INI
Do While Not oSCF.AtEndOfStream
'read a line
strLine = oSCF.ReadLine
'if inside [windows] section
If flagSection Then
IniInfParse strLine, "load", "", "WIN.INI",""
IniInfParse strLine, "run", "", "WIN.INI",""
'if line is beginning of another section
If Left(LTrim(strLine),1) = "[" Then
'toggle flag to false and exit Do
flagSection = False
Exit Do
End If 'next section?
End If 'flagSection?
'if first 9 chars of line = [windows], then in the right section
'so toggle flagSection to True
If LCase(Left(LTrim(strLine),9)) = "[windows]" Then flagSection = True
Loop 'next line of WIN.INI
oSCF.Close 'close WIN.INI
flagSection = False
'open SYSTEM.INI
Set oSCF = Fso.OpenTextFile (strFPWF & "\SYSTEM.INI",1)
'for each line of SYSTEM.INI
Do While Not oSCF.AtEndOfStream
strLine = oSCF.ReadLine
'if inside [boot] section
If flagSection Then
IniInfParse strLine, "shell", "explorer.exe", "SYSTEM.INI",""
If Left(LTrim(strLine),1) = "[" Then
'toggle flagSection and exit
flagSection = False
Exit Do
End If 'shell line?
End If 'inside boot section?
'if first 6 chars of line = [boot], then in the right section
'so toggle flagSection to True
If LCase(Left(LTrim(strLine),6)) = "[boot]" Then flagSection = True
Loop
oSCF.Close
If flagTLW Then SkipLine
flagTLW = False
flagSTLW = False
'open WINSTART.BAT if it exists
If Fso.FileExists(strFPWF & "\WINSTART.BAT") Then
Set oSCF = Fso.OpenTextFile (strFPWF & "\WINSTART.BAT",1)
'for each line of WINSTART.BAT
Do While Not oSCF.AtEndOfStream
strLine = oSCF.ReadLine
If strLine <> "" Then 'examine line if it's not a CR
If Len(strLine) >= 3 Then 'test against REM if long enough
'if not REM, then output
If LCase(Left(LTrim(strLine),3)) <> "rem" Then
If Not flagTLW Then
SkipLine
WriteOut "WINSTART.BAT contents:" : WriteOut String(22,"-") : SkipLine
flagTLW = True
End If
WriteOut strLine & CoName(IDExe(strLine))
End If
Else 'len 1-2
If Not flagTLW Then
SkipLine
WriteOut "WINSTART.BAT contents:" : WriteOut String(22,"-") : SkipLine
flagTLW = True
End If
WriteOut strLine
End If 'len < 3?
End If 'carriage return?
Loop 'WINSTART.BAT lines
If flagTLW Then SkipLine
oSCF.Close
Set oSCF=Nothing
End If 'WINSTART.BAT exists?
End If 'strOS = W98/WME
'reset title line flags
flagTLW = False
flagSTLW = False
'XI. AUTORUN.INF in root directory of local fixed disks for which
' autorun is enabled
'WXP SP2 does not launch AUTORUN.INF on local fixed disks
If strOSLong <> "Windows XP SP2" Then
'fixed disk, DWORD value, binary value array, AutoRun.Inf file, integer work variable
Dim oDisk, hVal, arBVal, oARI
'array of fixed disks
Public arFixedDisks()
'Disk Letter dictionary (needed to calculate power of 2)
'dictDL.Item(6) returns "G:"
Public dictDL : Set dictDL = CreateObject("Scripting.Dictionary")
dictDL.Add 0, "A:" : dictDL.Add 1, "B:" : dictDL.Add 2, "C:"
dictDL.Add 3, "D:" : dictDL.Add 4, "E:" : dictDL.Add 5, "F:"
dictDL.Add 6, "G:" : dictDL.Add 7, "H:" : dictDL.Add 8, "I:"
dictDL.Add 9, "J:" : dictDL.Add 10, "K:" : dictDL.Add 11, "L:"
dictDL.Add 12, "M:" : dictDL.Add 13, "N:" : dictDL.Add 14, "O:"
dictDL.Add 15, "P:" : dictDL.Add 16, "Q:" : dictDL.Add 17, "R:"
dictDL.Add 18, "S:" : dictDL.Add 19, "T:" : dictDL.Add 20, "U:"
dictDL.Add 21, "V:" : dictDL.Add 22, "W:" : dictDL.Add 23, "X:"
dictDL.Add 24, "Y:" : dictDL.Add 25, "Z:"
'HKLM NoDriveTypeAutoRun Fixed Disks Enabled
Public flagHKLM_NDTAR_FDE : flagHKLM_NDTAR_FDE = True
'HKCU NoDriveTypeAutoRun Fixed Disks Enabled
Public flagHKCU_NDTAR_FDE : flagHKCU_NDTAR_FDE = True
'HKLM NoDriveTypeAutoRun value exists
Public flagHKLM_NDTAR : flagHKLM_NDTAR = False
'HKCU NoDriveTypeAutoRun value exists (unused, passed for consistency)
Public flagHKCU_NDTAR : flagHKCU_NDTAR = False
'HKLM NoDriveAutoRun value exists
Public flagHKLM_NDAR : flagHKLM_NDAR = False
'HKCU NoDriveAutoRun value exists (unused, passed for consistency)
Public flagHKCU_NDAR : flagHKCU_NDAR = False
strKey = "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer"
NDTAR HKLM, flagHKLM_NDTAR, flagHKLM_NDTAR_FDE
If Not flagHKLM_NDTAR Then NDTAR HKCU, flagHKCU_NDTAR, flagHKCU_NDTAR_FDE
'if NoDriveTypeAutoRun permits autorun on fixed disks, look at
'individual disks
If flagHKLM_NDTAR_FDE And flagHKCU_NDTAR_FDE Then
'enumerate fixed disks
Dim colDisks : Set colDisks = GetObject("winmgmts:\root\cimv2")._
ExecQuery("SELECT * FROM Win32_LogicalDisk WHERE DriveType = 3")
j = 0
'fmt of DeviceID & Name is "A:"
For Each oDisk in colDisks
'for every dict entry
For i = 0 To 25
'find dictionary element number for drive letter
If dictDL.Item(i) = oDisk.DeviceID Then
'store disk letter, power of two for that letter,
'set autorun flag to True, increment counter
ReDim Preserve arFixedDisks(2,j)
arFixedDisks(0,j) = oDisk.DeviceID
arFixedDisks(1,j) = 2^i
arFixedDisks(2,j) = True
j = j + 1
End If 'dict drive letter located?
Next 'dict entry
Next 'disk in colDisks
NDAR HKLM, flagHKLM_NDAR
If Not flagHKLM_NDAR Then NDAR HKCU, flagHKCU_NDAR
'for every fixed disk
For i = 0 To UBound(arFixedDisks,2)
'if autorun enabled
If arFixedDisks(2,i) Then
'get the drive
Set oDisk = Fso.GetDrive(arFixedDisks(0,i))
'look for AUTORUN.INF in the root
If Fso.FileExists(arFixedDisks(0,i) & "\autorun.inf") Then
'open AUTORUN.INF if found
Set oARI = Fso.OpenTextFile (arFixedDisks(0,i) & "\autorun.inf",1)
'for each line of AUTORUN.INF
Do While Not oARI.AtEndOfStream
'read a line
strLine = oARI.ReadLine
'look for "open" or "shellexecute" statements
IniInfParse strLine, "open", "", "autorun.inf", arFixedDisks(0,i)
IniInfParse strLine, "shellexecute", "", "autorun.inf", arFixedDisks(0,i)
Loop 'next AUTORUN.INF line
oARI.Close 'close AUTORUN.INF
End If 'AUTORUN.INF exists in root?
End If 'autorun enabled on drive?
Next 'fixed disk
End If 'NoDriveTypeAutoRun enables autorun on fixed disks?
If flagTLW Then SkipLine
End If 'not WXP SP2?
'reset title line flags
flagTLW = False
flagSTLW = False
'XII. Enumerate contents of startup directories
'All Users StartUp Folder title string (empty by default)
Dim flagAUSUF : flagAUSUF = False
Dim flagFE : flagFE = True 'folder exists flag
'in W98/WME, see if local-language-specific All Users startup folder location
'appears in registry and form title string if it does
If strOS = "W98" Or strOS = "WME" Then
'look for Common Startup value
strKey = "Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders"
oReg.GetStringValue HKLM,strKey,"Common Startup",strValue
'if Common Startup value exists, extract title string
If Not IsNull(strValue) And strValue <> "" Then flagAUSUF = True
End If
'startup folder short names
If strOS = "W98" Or strOS = "WME" Then
arSUFN = Array("Startup")
Else
arSUFN = Array("Startup","AllUsersStartup")
End If
'form output file section title string
strLine = "Startup items in "
'in W98/WME, omit username & "All Users" folder if absent from registry
If strOS = "W98" Or strOS = "WME" Then
strLine = strLine & Chr(34) & "Startup" & Chr(34)
If flagAUSUF Then
strLine = strLine & " & " & Chr(34) & "All Users...Startup" &_
Chr(34) & " folders:"
Else
strLine = strLine & " folder:"
End If
Else 'all other O/S's
strLine = strLine & Chr(34) & Wshso.ExpandEnvironmentStrings("%USERNAME%") &_
Chr(34)
If flagFW = "SO" Then
strLine = strLine & " & " & Chr(34) & "All Users" & Chr(34) & " startup folders:"
Else 'Echo output -- escape ampersand
strLine = strLine & " ^& " & Chr(34) & "All Users" & Chr(34) & " startup folders:"
End If 'flagFW
End If 'strOS
strTitleLine1 = strLine
strTitleLine2 = String(Len(strLine),"-")
'for each startup folder name
For i = 0 To 1 '0 = user folder, 1 = All Users folder
flagSTLW = False
'get the startup folder
'in W98/WME, set flagFE to False if "All Users" folder doesn't exist
If i = 1 And (strOS = "W98" Or strOS = "WME") Then
If flagAUSUF Then
If Fso.FolderExists(strValue) Then
Set oSUF = Fso.GetFolder(strValue)
Else
flagFE = False 'folder doesn't exist
End If
Else
flagFE = False 'registry key doesn't exist
End If
Else 'all other O/S's at all times
Set oSUF = Fso.GetFolder(Wshso.SpecialFolders(arSUFN(i)))
End If
'if startup folder exists
If flagFE Then
'for each file in the startup folder
For Each oSUFi in oSUF.Files
strLine = "" 'empty the line
'treat file as a shortcut
On Error Resume Next
Set oSUSC = Wshso.CreateShortcut(oSUFi)
intErrNum = Err.Number &#
