'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 : Err.Clear On Error Goto 0 'if file is a shortcut If intErrNum = 0 Then If LCase(Fso.GetExtensionName(oSUFi)) = "url" Then 'shortcut is URL 'prepare the shortcut file base name and the target path & arguments strLine = Chr(34) & Fso.GetBaseName (oSUFi.Path) & Chr(34) & strGT & "URL shortcut to: " &_ Chr(34) & oSUSC.TargetPath Else 'prepare the shortcut file base name and the target path & arguments strLine = Chr(34) & Fso.GetBaseName (oSUFi.Path) & Chr(34) & strGT & "shortcut to: " &_ Chr(34) & oSUSC.TargetPath If oSUSC.Arguments <> "" Then strLine = strLine & " " & oSUSC.Arguments & Chr(34) Else strLine = strLine & Chr(34) End If 'add co-name strLine = strLine & CoName(oSUSC.TargetPath) End If 'URL or shortcut? 'if file is a PIF ElseIf LCase(Fso.GetExtensionName(oSUFi)) = "pif" Then 'write out pif file target strPIFTgt = "" Dim oFi : Set oFi = Fso.OpenTextFile(oSUFi, 1) oFi.Skip(36) 'target starts after 36 bytes 'target size is up to 63 bytes For ii = 1 To 63 bin1C = oFi.Read(1) 'end of target is single "00" byte If AscB(bin1C) = 0 Then Exit For 'otherwise convert binary to ASCII and append to string strPIFTgt = strPIFTgt & Chr(AscB(bin1C)) Next oFi.Close Set oFi=Nothing strLine = Chr(34) & Fso.GetBaseName(oSUFi.Path) & Chr(34) & strGT & "PIF to: " &_ Chr(34) & strPIFTgt & Chr(34) & CoName(strPIFTgt) 'file is neither shortcut nor PIF Else 'file is probably an executable so write out the file name If LCase(Fso.GetFileName(oSUFi)) <> "desktop.ini" Then _ strLine = Chr(34) & oSUFi.Name & Chr(34) & CoName(IDExe(oSUFi.Name)) End If 'file is shortcut Set oSUSC=Nothing 'if there's something to output If strLine <> "" Then 'output the section title line if not already done If Not flagTLW Then SkipLine : WriteOut strTitleLine1 : WriteOut strTitleLine2 : SkipLine flagTLW = True End If 'output the folder title line if not already done If Not flagSTLW Then 'write the path to the file WriteOut oSUF.Path flagSTLW = True End If 'output the line WriteOut strLine End If Next 'file in startup folder End If 'flagFE? If flagSTLW Then SkipLine Next 'startup folder name 'reset title line flags flagTLW = False flagSTLW = False 'recover array memory ReDim arSUFN(0) 'XIII. Enumerate enabled Scheduled Tasks ' Byte Disabled Enabled '00000030: #####1## #####0## <-- 'file in Tasks directory Dim oFi2 'prepare section title lines strTitleLine1 = "Enabled Scheduled Tasks:" strTitleLine2 = String(Len(strTitleLine1),"-") 'if the tasks directory exists in the Windows directory If Fso.FolderExists(Fso.GetSpecialFolder(WinFolder) & "\Tasks") Then 'get the tasks folder Dim oJobF : Set oJobF = Fso.GetFolder(Fso.GetSpecialFolder(WinFolder) & "\Tasks") 'for each file For Each oFi2 in oJobF.Files 'if file in Tasks directory is a task (has a .JOB extension) If LCase(Fso.GetExtensionName(oFi2)) = "job" Then 'try to open the task file On Error Resume Next Dim oJobFi : Set oJobFi = Fso.OpenTextFile(oFi2,1,False,-1) intErrNum = Err.Number : Err.Clear On Error Goto 0 'if file could be opened If intErrNum = 0 Then 'read the file, determine enabled status, extract the executable name JobFileRead oFi2, oJobFi 'close the .JOB file oJobFi.Close Set oJobFi=Nothing Else 'file couldn't be opened 'write titles if not already done If Not flagTLW Then SkipLine : WriteOut strTitleLine1 : WriteOut strTitleLine2 : SkipLine flagTLW = True End If 'write error message WriteOut Chr(34) & oFi2.Name & Chr(34) &_ " -- insufficient permission to read this file!" End If '.JOB file opened successfully? End If '.JOB file extension selected? Next 'file in TASKS directory Else 'Tasks directory can't be found 'write titles and error message SkipLine : WriteOut strTitleLine1 : WriteOut strTitleLine2 : SkipLine WriteOut "** The " & Chr(34) & Wshso.ExpandEnvironmentStrings("%WINDIR%") &_ "\Tasks" & Chr(34) & " directory does not exist. **" flagTLW = True End If 'Tasks directory exists? Set oJobF=Nothing If flagTLW Then SkipLine flagTLW = False 'XIV. Enumerate Started or Non-disabled Services 'for NT-type O/S's If strOS <> "W98" And strOS <> "WME" Then 'Services collection, Service object, Dim colSvce, oSvce 'counter, lowest-sort subscript, lowest-sort name holder, temp variables x 3 Dim intCnt, intLSS, str1stName, strT0, strT1, strT2 Dim flagSM : flagSM = False 'Safe Mode flag 'for W2K/WXP, determine if running in Safe Mode If strOS <> "NT4" Then strKey = "SYSTEM\CurrentControlSet\Control" oReg.GetStringValue HKLM,strKey,"SystemStartOptions",strValue If InStr(LCase(strValue),"safeboot") <> 0 Then flagSM = True End If 'write title lines strLine = "Running Services (Display Name, Service Name, Path {Service DLL}):" If flagSM Then strLine = "All Non-Disabled Services (Display Name, " &_ "Service Name, Path {Service DLL}):" SkipLine : WriteOut strLine : WriteOut String(Len(strLine),"-") : SkipLine 'if in Safe Mode If flagSM Then 'get collection of services with Auto or Manual "Startup type" Set colSvce = GetObject("winmgmts:root\cimv2").ExecQuery("SELECT DisplayName, " &_ "Name, PathName FROM Win32_Service WHERE StartMode = ""Manual"" " &_ "Or StartMode = ""Auto""") 'not in Safe Mode Else 'get collection of started services Set colSvce = GetObject("winmgmts:root\cimv2").ExecQuery("SELECT DisplayName, " &_ "Name, PathName FROM Win32_Service WHERE Started = True") End If 'safe mode? 'sort services by display name 'get the count intCnt = colSvce.Count 'set up two arrays: work array & sorted array Dim arSvces() ReDim arSvces(intCnt-1, 2) 'services array i = 0 'transfer data from collection to array For Each oSvce in colSvce arSvces(i,0) = oSvce.DisplayName : arSvces(i,1) = oSvce.Name : arSvces(i,2) = oSvce.PathName i = i + 1 Next 'service in collection 'for every service in array up to the next to last one For i = 0 To UBound(arSvces,1) - 1 'store array row in temp variables strT0 = arSvces(i,0) strT1 = arSvces(i,1) strT2 = arSvces(i,2) 'initialize the sorted name & lowest-sort subscript str1stName = arSvces(i,0) intLSS = i 'for every subsequent service in array up to the last one For j = i + 1 To UBound(arSvces,1) 'if current array name < saved lowest-sort name, 'reset sorted array data and 'set lowest-sort subscript = current array subscript If LCase(arSvces(j,0)) < LCase(str1stName) Then str1stName = arSvces(j,0) intLSS = j End If Next 'array element 'set current array position = lowest-sort subscript element arSvces(i,0) = arSvces(intLSS,0) arSvces(i,1) = arSvces(intLSS,1) arSvces(i,2) = arSvces(intLSS,2) 'save data formerly in current array position to array position just vacated arSvces(intLSS,0) = strT0 arSvces(intLSS,1) = strT1 arSvces(intLSS,2) = strT2 Next 'sorted name array element 'for every service sorted by display name For i = 0 To UBound(arSvces,1) 'for services with unique file names If InStr(LCase(arSvces(i,2)),"services.exe") = 0 And _ InStr(LCase(arSvces(i,2)),"svchost") = 0 Then 'output display name, service name, path WriteOut arSvces(i,0) & ", " & arSvces(i,1) & ", " & Chr(34) &_ arSvces(i,2) & Chr(34) & CoName(IDExe(arSvces(i,2))) 'shared process -- look for ServiceDLL value in Parameter subkey ElseIf InStr(LCase(arSvces(i,2)),"svchost") > 0 And _ InStr(LCase(arSvces(i,2))," -k") > 0 Then strKey = "System\CurrentControlSet\Services\" oReg.GetExpandedStringValue HKLM,strKey & arSvces(i,1) &_ "\Parameters","ServiceDll",strValue 'prepare output for missing Parameters key or ServiceDLL value strLine = " {(missing data)}" If strValue <> "" Then strLine = " {" & Chr(34) & strValue &_ Chr(34) & CoName(IDExe(strValue)) & "}" 'output display name, service name, path WriteOut arSvces(i,0) & ", " & arSvces(i,1) & ", " & Chr(34) &_ arSvces(i,2) & Chr(34) & strLine 'if ServicesDll value not returned, output error line If strValue <> "" Then CoName strValue Else WriteOut " ** Corrupt registry entry! **" End If 'services.exe Else 'output display name, service name, path WriteOut arSvces(i,0) & ", " & arSvces(i,1) & ", " & Chr(34) &_ arSvces(i,2) & Chr(34) & CoName(arSvces(i,2)) End If 'independent file, svchost, or services? Next 'service file SkipLine 'recover array memory ReDim arSvces(0,0) End If 'NT4-type O/S? 'rename report file if using Echo under W98 If flagFW = "EO" And (strOS = "W98" Or strOS = "WME") Then _ Wshso.Run "%COMSPEC% /c MOVE /y " & strFNS & " " & Chr(34) & strFN & Chr(34),0,TRUE 'inform user that script is complete If flagOut = "W" Then Wshso.PopUp "All Done! The results are in the file:" &_ vbCRLF & vbCRLF & strFN,2,"Silent Runners R" & strRevNo & " Complete",64 Else WScript.Echo "Silent Runners R" & strRevNo & " is done! The results " &_ "are in the file:" & vbCRLF & vbCRLF & strFN End If 'clean up Set oSUF=Nothing If IsObject(oFN) Then On Error Resume Next oFN.Close On Error Goto 0 End If Set oFN=Nothing Set oReg=Nothing Set Fso=Nothing Set Wshso=Nothing 'YYYY-MM-DD Function FmtDate FmtDate = Year(Now) & "-" & Right("0" & Month(Now),2) & "-" & Right("0" & Day(Now),2) End Function 'hh:mm:ss Function FmtTime FmtTime = Right("0" & Hour(Now),2) & ":" & Right("0" & Minute(Now),2) End Function 'enumerate key's entries Function EnumKeyData (hexHive, strHive, strKey, strWarn) Dim arNames, arType, strValue, i, j Dim strMsg : strMsg = strWarn Const REG_SZ = 1 Const REG_EXPAND_SZ = 2 Const REG_BINARY = 3 Const REG_DWORD = 4 Const REG_MULTI_SZ = 7 'find all the names in the key oReg.EnumValues hexHive, strKey, arNames, arType 'enumerate names if present If IsArray(arNames) Then 'in W98, if key has no name/value pairs, arNames is array with UBound of -1 'in W2K, not an array If UBound(arNames) >= 0 Then 'write the full key name WriteOut strHive & "\" & strKey & "\" 'for each data type in the values array For i = LBound(arType) To UBound(arType) 'find the value that corresponds to its type Select Case arType(i) 'string value Case REG_SZ 'return the string-type value oReg.GetStringValue hexHive,strKey,arNames(i),strValue WriteValueData arNames(i), strValue, "REG_SZ", strWarn 'expandable-string value Case REG_EXPAND_SZ 'return the expandable string-type value oReg.GetExpandedStringValue hexHive,strKey,arNames(i),strValue WriteValueData arNames(i), strValue, "REG_EXPAND_SZ", strWarn 'binary value Case REG_BINARY 'return the binary-type value as array oReg.GetBinaryValue hexHive,strKey,arNames(i),strValue 'set name = default if name is empty string If arNames(i) = "" Then strMsg = strMsg & Chr(34) & "Default" & Chr(34) & " = " Else strMsg = strMsg & Chr(34) & arNames(i) & Chr(34) & " = " End If 'delimit every two-bytes by space For j = LBound(strValue) To UBound(strValue) strMsg = strMsg & strValue(j) & Space(1) Next strMsg = Left(strMsg,Len(strMsg)-1) 'lop off trailing space WriteOut strMsg & " (REG_BINARY)" '4-byte value Case REG_DWORD 'return the DWORD-type value oReg.GetDWORDValue hexHive,strKey,arNames(i),strValue WriteValueData arNames(i), Hex(strValue), "REG_DWORD", strWarn 'multiple-string value Case REG_MULTI_SZ 'return the multiple-string-type value oReg.GetMultiStringValue hexHive,strKey,arNames(i),strValue 'set name = default if name is empty string If arNames(i) = "" Then strMsg = strMsg & Chr(34) & "Default" & Chr(34) & " = " Else strMsg = strMsg & Chr(34) & arNames(i) & Chr(34) & " = " End If 'delimit every quote-enclosed string by "|" For j = LBound(strValue) To UBound(strValue) strMsg = strMsg & Chr(34) & strValue(j) & Chr(34) & "|" Next strMsg = Left(strMsg,Len(strMsg)-1) 'lop off trailing "|" WriteOut strMsg & " (REG_MULTI_SZ)" 'any other type Case Else 'admit we don't know what it is WriteOut Chr(34) & arNames(i) & Chr(34) & " = (data in unrecognized format!)" End Select 'data type Next 'arType member SkipLine End If 'UBound > 0 End If 'arNames array exists ReDim arType(0) End Function 'write name/value pair to file Function WriteValueData (strName, strValue, strType, strWarn) Dim strOQEC 'Optionally Quote-Enclosed Comment" If strType = "REG_DWORD" Then strOQEC = strValue & CoName(IDExe(strValue)) Else strOQEC = Chr(34) & strValue & Chr(34) & CoName(IDExe(strValue)) End If 'if name is empty string then output "Default" If strName = "" Then On Error Resume Next 'write the quote-delimited name and value to a file WriteOut strWarn & Chr(34) & "Default" & Chr(34) & " = " & strOQEC If Err.Number <> 0 Then WriteOut strWarn & Chr(34) & "Default" &_ Chr(34) & " = ** WARNING! empty or invalid data **" On Error GoTo 0 Else 'name is non-empty string On Error Resume Next 'write the quote-delimited name and value to a file WriteOut strWarn & Chr(34) & strName & Chr(34) & " = " & strOQEC If Err.Number <> 0 Then WriteOut strWarn & Chr(34) & strName &_ Chr(34) & " = ** WARNING! empty or invalid data **" On Error GoTo 0 End If Err.Clear End Function 'output registry name/value if value <> ref Function RegDataChk (cHive, strKey, strName, strValue, strRef) Dim strHive, strCoName, strValWrk If cHive = HKCU Then strHive = "HKCU" If cHive = HKLM Then strHive = "HKLM" 'if value exists If oReg.GetStringValue (cHive,strKey,strName,strValue) = 0 Then strValWrk = Trim(LCase(strValue)) 'alert if value <> reference and not empty string If strValWrk <> LCase(strRef) And strValWrk <> "" Then If Not flagTLW Then WriteOut strHive & "\" & strKey & "\" flagTLW = True End If If LCase(strName) = "load" Or LCase(strName) = "run" Then strCoName = LRParse(strValue) Else strCoName = CoName(IDExe(strValue)) End If 'write name and value to file On Error Resume Next WriteOut "INFECTION WARNING! " & Chr(34) & strName & Chr(34) &_ " = " & Chr(34) & strValue & Chr(34) & strCoName If Err.Number <> 0 Then WriteOut Chr(34) & strName & Chr(34) &_ " = ** WARNING -- empty or invalid data! **" Err.Clear On Error GoTo 0 End If 'value <> reference End If 'value exists End Function 'set NoDriveTypeAutoRun flag Function NDTAR (cHive, strValueFlag, strFDFlag ) 'DWORD or BINARY value, binary value array Dim hVal, arBVal strKey = "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer" 'if cHive NoDriveTypeAutoRun DWORD value exists If oReg.GetDWORDValue(cHive,strKey,"NoDriveTypeAutoRun",hVal) = 0 Then strValueFlag = True 'if autorun for fixed drives is disabled, set flag If (hVal And 8) = 8 Then strFDFlag = False 'if cHive NoDriveTypeAutoRun BINARY value exists ElseIf oReg.GetBinaryValue(cHive,strKey,"NoDriveTypeAutoRun",arBVal) = 0 Then 'UBound = -1 if value not set (zero-length binary value) If UBound(arBVal) = -1 Then 'if O/S = W2K/WXP SP0/1, "value not set" interpreted as 0 instead of null! If strOS = "W2K" Or strOS = "WXP" Then strValueFlag = True End If 'W2K/WXP? Else 'UBound <> -1, so value set strValueFlag = True : hVal = 0 'binary value retrieved as array in increments of 16^2 For i = 0 To UBound(arBVal) hVal = hVal + arBVal(i) * 256^i Next 'if autorun for fixed drives is disabled, set flag If (hVal And 8) = 8 Then strFDFlag = False End If 'UBound = -1? End If 'NoDriveTypeAutoRun value exists? End Function 'detect if autorun disabled for individual drives Function NDAR (cHive, strValueFlag) 'DWORD or BINARY value, binary value array Dim hVal, arBVal strKey = "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer" 'if cHive NoDriveAutoRun DWORD value exists If oReg.GetDWORDValue(cHive,strKey,"NoDriveAutoRun",hVal) = 0 Then strValueFlag = True 'for every fixed disk For i = 0 To UBound(arFixedDisks,2) 'if autorun for fixed drive is disabled, set flag If (hVal And arFixedDisks(1,i)) = arFixedDisks(1,i) Then arFixedDisks(2,i) = False End If 'autorun disabled for this drive? Next 'fixed disk 'if cHive NoDriveAutoRun BINARY value exists ElseIf oReg.GetBinaryValue(cHive,strKey,"NoDriveAutoRun",arBVal) = 0 Then 'UBound = -1 if value not set (zero-length binary value) If UBound(arBVal) = -1 Then 'if O/S = W2K/WXP SP0/1, "value not set" interpreted as 0 instead of null! If strOS = "W2K" Or strOS = "WXP" Then strValueFlag = True 'set all NDAR flags to True For i = 0 To UBound(arFixedDisks,2) arFixedDisks(2,i) = True Next End If 'W2K/WXP? Else 'UBound <> -1, so value set strValueFlag = True hVal = 0 'binary value retrieved as array in increments of 16^2 For i = 0 To UBound(arBVal) hVal = hVal + arBVal(i) * 256^i Next 'for every fixed disk For i = 0 To UBound(arFixedDisks,2) 'if autorun for the fixed disk is disabled, set flag If (hVal And arFixedDisks(1,i)) = arFixedDisks(1,i) Then arFixedDisks(2,i) = False End If 'autorun disabled for fixed disk? Next 'fixed disk End If 'hive NoDriveAutoRun value set? End If 'hive NoDriveAutoRun value exists? End Function 'INI-file Load/Run/Shell parser Function IniInfParse (strLine, strVerb, strEquiv, strINIFile, strDisk) Dim strExe : strExe = "" 'executable after "=" 'if verb is first non-space chars (if line is populated) If Left(LCase(LTrim(strLine)),Len(strVerb)) = strVerb Then 'find pos'n of equals sign Dim intEqu : intEqu = InStr(strLine,"=") 'find executable statement after equals sign strExe = Trim(Mid(strLine,intEqu+1)) 'if non-space chars to right of equals sign different from argument If LCase(strExe) <> strEquiv Then 'output titles IniInfTitles strINIFile 'write warning & verb line If LCase(strVerb) = "load" Or LCase(strVerb) = "run" Then strLine = "INFECTION WARNING! " & Chr(34) & strLine & Chr(34) & LRParse(strExe) ElseIf LCase(strVerb) = "open" Or LCase(strVerb) = "shellexecute" Then strLine = "INFECTION WARNING! " & strDisk & "\AUTORUN.INF" & strGT &_ Chr(34) & strLine & Chr(34) & CoName(IDExe(strDisk & "\" & strExe)) Else strLine = "INFECTION WARNING! " & Chr(34) & strLine & Chr(34) & CoName(IDExe(strExe)) End If flagTLW = True WriteOut strLine End If 'verb populated? End If 'line populated End Function 'output WIN.INI/SYSTEM.INI/AUTORUN.INF titles Function IniInfTitles (strINIFile) Dim strLine 'write section title line if not already done If Not flagTLW Then SkipLine If LCase(strINIFile) = "autorun.inf" Then strLine = "Autostart via AUTORUN.INF on local fixed drives:" Else strLine = "WIN.INI & SYSTEM.INI launch points:" End If WriteOut strLine : WriteOut String(Len(strLine),"-") : SkipLine End If 'section title line already written? 'write subtitle lines for WIN.INI & SYSTEM.INI If LCase(strINIFile) = "win.ini" And Not flagSTLW Then WriteOut "WIN.INI" : Writeout "[windows]" flagSTLW = True ElseIf LCase(strINIFile) = "system.ini" Then If flagTLW Then SkipLine : WriteOut "SYSTEM.INI" : WriteOut "[boot]" End If End Function 'default executable title lines Function DefExeTitles Dim strLine : strLine = "Default executables:" SkipLine : WriteOut strLine : WriteOut String(Len(strLine),"-") : SkipLine End Function 'trim the parameters from a path to find the executable Function IDExe (strPath) 'work path string 'location of ".exe", location of last backslash, 'location of first space after backslash, 'location of second quote, 'executable id'd from location of ".exe", 'executable id'd btwn final backslash & first space following backslash Dim strPWk, intExeL, intBSL, intSpL, int2Q, strID1, strID2, intErrNum strPWk = LTrim(strPath) 'look for leading double quote If Left(strPWk,1) = Chr(34) Then 'if find it, then look for second quote int2Q = InStr(2, strPWk, """") 'if find it, reset the path string to what was between the quotes If int2Q > 0 Then strPWk = Mid(strPWk, 2, int2Q - 2) End If 'locate .exe intExeL = InStr(LCase(strPWk), ".exe") 'if not an .exe, maybe a .cmd? If intExeL = 0 Then intExeL = InStr(LCase(strPWk), ".cmd") '.bat? If intExeL = 0 Then intExeL = InStr(LCase(strPWk), ".bat") '.pif? If intExeL = 0 Then intExeL = InStr(LCase(strPWk), ".pif") '.dll? If intExeL = 0 Then intExeL = InStr(LCase(strPWk), ".dll") '.com? If intExeL = 0 Then intExeL = InStr(LCase(strPWk), ".com") '.ocx? If intExeL = 0 Then intExeL = InStr(LCase(strPWk), ".ocx") '.vbs? If intExeL = 0 Then intExeL = InStr(LCase(strPWk), ".vbs") 'extract exectable through .ext strID1 = Left(strPWk,intExeL + 3) 'locate final backslash intBSL = InStrRev(strPWk, "\") 'locate first space after final backslash intSpL = InStr(intBSL + 1, strPWk, " ") 'extract executable up to space On Error Resume Next strID2 = Left(strPWk, intSpL -1) intErrNum = Err.Number On Error Goto 0 Err.Clear If intErrNum <> 0 Then strID2 = "" 'compare lengths of extracted strings and return longest string If Len(strID1) > Len(strID2) Then IDExe = strID1 Exit Function Else IDExe = strID2 Exit Function End If End Function 'SCRipts.Ini-file Parser 'file name to open, action for which scripts must be parsed Function ScrIP (strValue, strAction) 'form scripts.ini path\FileName Dim strFN : strFN = strValue & "\scripts.ini" 'default path Dim strDefPath : strDefPath = "" 'error number, line read from file, pos'n of CmdLine & equals sign, 'parameter string, line intro ("arrow") string Dim intErrNum, strLine, intCS, intEq, strParam, strArrow Dim strSC : strSC = "" 'script command Dim intSN : intSN = 0 'script number Dim strCmd : strCmd = "" 'command string Dim flagSection : flagSection = False 'True if in strAction section Dim intActL : intActL = Len(strAction) 'action length (used for spacing of output) 'assume not in right action section flagTLW = False 'open the SCRIPTS.INI file For Reading On Error Resume Next Dim oSI : Set oSI = Fso.OpenTextFile(strFN, 1, False,-1) intErrNum = Err.Number On Error Goto 0 Err.Clear 'if couldn't open file, output a warning & quit If intErrNum <> 0 Then If Not flagTLW Then WriteOut arHives(i,0) & "\" & strKey WriteOut " ** WARNING! Insufficient permission to read " &_ Chr(34) & strFN & Chr(34) & " **" flagTLW = True Exit Function End If 'for every line of file Do Until oSI.AtEndOfStream strLine = oSI.ReadLine 'if know already in right section If flagSection Then 'exit if find beginning of next section If InStr(strLine, "[") Then Exit Do '[Logon] '0CmdLine=path\filename.ext '0Parameters= 'find pos'n of equals sign intEq = InStr(strLine,"=") 'if equals sign found in the line If intEq > 0 Then 'output saved info if the script number has changed If intSN <> FLN(strLine) Then 'write titles if necessary If Not flagTLW Then 'write a title WriteOut arHives(i,0) & "\" & strKey strArrow = strAction & strGT & "launches: " flagTLW = True Else strArrow = Space(intActL) & strGT & "launches: " End If 'output script command, reset script command & saved script number WriteOut strArrow & Chr(34) & strSC & Chr(34) & CoName(IDExe(strCmd)) strSC = "" : strCmd = "" intSN = FLN(strLine) End If 'new script number? 'current line is cmdline If InStr(LCase(strLine), "cmdline") > 0 Then 'if cmdline doesn't contain backslash, form script path from 'function parameters If InStr(strLine,"\") = 0 Then strDefPath = strValue & "\" & strAction & "\" 'add script command to command string strSC = strDefPath & Mid(strLine, intEQ + 1) & strSC strCmd = strDefPath & Mid(strLine, intEQ + 1) 'store cmdline field for co-name id 'if parameters line ElseIf InStr(LCase(strLine), "parameters") > 0 Then 'extract parameters string strParam = Mid(strLine, intEq + 1) 'add non-empty parameters command to command string If Trim(strParam) <> "" Then strSC = strSC & " " & strParam End If 'line is cmdline or parameter End If '"=" in this line End If 'inside action section 'if action found in current line, set flag to True If InStr(LCase(strLine), LCase(strAction)) > 0 Then flagSection = True Loop 'next line in SCRIPTS.INI 'if a script was located, output last script command found If strSC <> "" Then If Not flagTLW Then 'write a title WriteOut arHives(i,0) & "\" & strKey strArrow = strAction & strGT & "launches: " flagTLW = True Else strArrow = Space(intActL) & strGT & "launches: " End If WriteOut strArrow & Chr(34) & strSC & Chr(34) & CoName(strCmd) End If 'script located? End Function 'Find Leading Number Function FLN (strLine) 'save the input in a trimmed work variable Dim strWork : strWork = LTrim(strLine) 'initialize the output number Dim intNumber : intNumber = 0 'counter, single character Dim i, str1C 'find length of work variable Dim intLen : intLen = Len(strWork) 'for the length of the work variable For i = 1 To intLen 'take the left-most chr str1C = Left(strWork,1) 'if it's numeric If IsNumeric(str1C) Then 'concatenate the digit intNumber = intNumber + CInt(str1C) 'remove 1st chr from the work variable strWork = Right(strWork,Len(strWork)-1) Else 'left-most chr isn't numeric FLN = intNumber 'output the leading number & exit Exit For End IF Next 'work variable chr End Function 'find company name in existing file Function CoName (strFN) If IsNull(strFN) Or strFN = "" Then CoName = " [(file not found)]" Exit Function End If 'does the file exists? If Fso.FileExists(strFN) Then CoName = CNCall(strFN) ElseIf Fso.FileExists(strFPWF & "\" & strFN) Then 'use prefixed windows folder CoName = CNCall(strFPWF & "\" & strFN) ElseIf Fso.FileExists(strFPSF & "\" & strFN) Then 'use prefixed system folder CoName = CNCall(strFPSF & "\" & strFN) ElseIf Fso.FileExists(AppPath(strFN)) Then 'trace executable via App Paths key CoName = CNCall(AppPath(strFN)) Else 'say file can't be found CoName = " [file not found]" End If 'file exists? End Function 'find company name in existing file Function CNCall (strFN) 'WMI file object, co-name, error number Dim oFile, strMftr, intErrNum 'if there are already escaped backslashes, unescape them If InStr(strFN,"\\") <> 0 Then strFN = Replace(strFN,"\\","\") 'now reescape all of them strFN = Replace(strFN,"\","\\") 'get the file object with filename delimited by double quotes '(couldn't get single quotes to work with single quote embedded in path) On Error Resume Next Set oFile = GetObject("winmgmts:root\cimv2").Get _ ("CIM_DataFile.Name=""" & strFN & """") intErrNum = Err.Number On Error Goto 0 Err.Clear If intErrNum <> 0 Then CNCall = " [(path error)]" Exit Function End If 'find the co-name strMftr = oFile.Manufacturer Set oFile=Nothing 'if null, say so If IsNull(strMftr) Then CNCall = " [null data]" 'if empty, say so ElseIf strMftr = "" Then CNCall = " [empty string]" 'if some company, say it Else 'if MS, say it with 2 letters If strMftr = "Microsoft Corporation" Then CNCall = " [MS]" 'if some other company, provide all the data, which may take up several lines Else CNCall = " [" & Chr(34) & Replace(strMftr,Chr(13) & Chr(10),Space(1)) & Chr(34) & "]" End If 'MS or not? End If 'null, mt, MS or not? End Function 'look for the App Path default value for an executable Function AppPath (strFN) Dim strKey, strValue strKey = "Software\Microsoft\Windows\CurrentVersion\App Paths" oReg.GetStringValue HKLM,strKey & "\" & strFN,"",strValue 'return the value or an empty string If IsNull(strValue) Then strValue = "" AppPath = strValue End Function 'parse HKCU\Software\Microsoft\Windows NT\CurrentVersion\Windows\load 'HKCU\Software\Microsoft\Windows NT\CurrentVersion\Windows\run for executables 'and return co-name for each executable 'executables are delimited by spaces and/or commas Function LRParse (strLine) Dim i, strLRSeg 'counter, line segment Dim strIn : strIn = Trim(strLine) 'input string Dim intSLLI : intSLLI = Len(strIn) 'Input String Line Length Dim strOut : strOut = "" 'output string Dim arOut() 'dynamic executable output array Dim cntAr : cntAr = -1 'output array UBound Dim cntChr : cntChr = 0 'number of chrs in executable string Dim intStartChr : intStartChr = 1 'start of executable string in input string 'for every chr in input string For i = 1 To intSLLI 'if the chr is a delimiter If Mid(strIn,i,1) = " " Or Mid(strIn,i,1) = "," Then 'if at least one non-delimiter chr has been encountered If cntChr > 0 Then 'extract the executable from the input string strLRSeg = Mid(strIn,intStartChr,cntChr) cntChr = 0 'reset the executable counter cntAr = cntAr + 1 'increment the output array UBound ReDim Preserve arOut(cntAr) 'redim the output array arOut(cntAr) = strLRseg 'add the executable to the output array End If 'non-delimiter chr encountered? intStartChr = i + 1 'reset the executable string start to next chr Else 'chr not a delimiter cntChr = cntChr + 1 'increment the exec string counter End If 'chr a delimiter? Next 'line chr 'check the end-string If cntChr > 0 Then 'extract the executable strLRSeg = Mid(strIn,intStartChr,cntChr) cntAr = cntAr + 1 'increment the output array UBound ReDim Preserve arOut(cntAr) 'redim the output array arOut(cntAr) = strLRSeg 'add the executable to the output array End If 'exec string found at end of line? 'if exec strings found If cntAr >= 0 Then 'for every string For i = 0 To UBound(arOut) 'concatenate a comma & co-name (with leading space) strOut = strOut & "," & CoName(arOut(i)) Next 'trim obligatory leading comma strOut = Right(strOut,Len(strOut)-1) End If 'return delimited string LRParse = strOut End Function 'read JOB file & output error if file corrupt Function JobFileRead (oFile, oJobFi) '# Unicode chrs in Run field executable statements, decimal value of enabled byte, 'command string, error number Dim intUChrCtr, int1C, strCmd, intErrNum Dim strJobExe : strJobExe = "" 'concatenated executable string Dim flagEnStatus : flagEnStatus = False 'task enabled status 'prepare output file title lines Dim strLine Dim strTitleLine1 : strTitleLine1 = "Enabled Scheduled Tasks:" Dim strTitleLine2 : strTitleLine2 = String(Len(strTitleLine1),"-") 'check for minimum length If oFile.Size <= 80 Then JobFileReadError oFile, strTitleLine1, strTitleLine2, " (too small)" : Exit Function End If On Error Resume Next 'determine enabled/disabled status by reading one Unicode chr oJobFi.Skip(24) int1C = AscB(oJobFi.Read(1)) 'for a DISabled task: byte 48 (30h), 0-based-bit 2 (4-bit) = 1 If (int1C And 4) = 0 Then flagEnStatus = True 'if an enabled task If flagEnStatus Then 'write titles if not already done If Not flagTLW Then SkipLine : WriteOut strTitleLine1 : WriteOut strTitleLine2 : SkipLine flagTLW = True End If 'skip to the counter for the number of chrs in the first executable statement oJobFi.Skip(10) '# bytes at unicode chr 35 (byte 70) '# chrs includes final zero chr so subtract one chr intUChrCtr = AscW(oJobFi.Read(1))-1 'check for 0 or negative executable length If intUChrCtr <= 0 Then JobFileReadError oFile, strTitleLine1, strTitleLine2, " (no executable)" Exit Function End If 'read the chrs and convert to ASCII strJobExe = MidB(oJobFi.Read(intUChrCtr),1) intErrNum = Err.Number : Err.Clear 'check for truncated executable If intErrNum <> 0 Then JobFileReadError oFile, strTitleLine1, strTitleLine2, " (truncated executable)" Exit Function End If strCmd = strJobExe 'store executable for co-name ID 'add ".exe" extension to bare executables If Fso.GetExtensionName(strCmd) = "" Then strCmd = strCmd & ".exe" 'skip to parameters counter oJobFi.Skip(1) intErrNum = Err.Number : Err.Clear 'check for truncated file If intErrNum <> 0 Then JobFileReadError oFile, strTitleLine1, strTitleLine2, " (too small)" Exit Function End If 'read the parameters counter intUChrCtr = AscW(oJobFi.Read(1)) intErrNum = Err.Number : Err.Clear 'check for absence of parameters counter If intErrNum <> 0 Then JobFileReadError oFile, strTitleLine1, strTitleLine2, " (parameter string size missing)" Exit Function End If 'if parameters exist, concatenate the executable If intUChrCtr <> 0 Then _ strJobExe = strJobExe & Space(1) & MidB(oJobFi.Read(intUChrCtr-1),1) intErrNum = Err.Number : Err.Clear 'check for truncated parameter string If intErrNum <> 0 Then JobFileReadError oFile, strTitleLine1, strTitleLine2," (truncated parameter string)" Exit Function End If 'write out the .JOB file name & executable string WriteOut Chr(34) & Fso.GetBaseName(oFile.Path) & Chr(34) &_ strGT & "launches: " & Chr(34) & strJobExe & Chr(34) & CoName(strCmd) End If 'enabled task? On Error Goto 0 End Function 'output reason for JOB file corruption Function JobFileReadError (oFile, strTitleLine1, strTitleLine2, strReason) 'write titles if not already done If Not flagTLW Then WriteOut strTitleLine1 : WriteOut strTitleLine2 : SkipLine flagTLW = True End If 'write out the .JOB file name & executable string WriteOut Chr(34) & Fso.GetBaseName(oFile.Path) & Chr(34) &_ strGT & "WARNING -- The file " & Chr(34) & oFile.Name & Chr(34) &_ " is corrupt!" & strReason End Function 'write strOut to the report file Function WriteOut (strOut) 'needed for W98/WME Dim intQ1, intQ2, strOut1, strOutWk Dim strOut2 : strOut2 = "" 'if output via Script Object If flagFW = "SO" Then oFN.WriteLine strOut 'write the line to the file 'in W98/WME, echo to SFN ElseIf strOS = "W98" Or strOS = "WME" Then Wshso.Run "%COMSPEC% /c echo " & strOut & ">> " & strFNS,0,TRUE 'in NT4/W2K/WXP, echo to LFN Else 'use LFN Wshso.Run "%COMSPEC% /c echo " & strOut & ">> " & Chr(34) & strFN & Chr(34),0,TRUE End If 'Script Object or Echo? End Function 'skip a line in the report file Function SkipLine 'if output via Script Object If flagFW = "SO" Then oFN.WriteBlankLines (1) 'if output via Echo in W98/WME ElseIf strOS = "W98" Or strOS = "WME" Then Wshso.Run "%COMSPEC% /c echo.>> " & strFNS,0,TRUE 'if output via Echo in NT4/WS2/WXP Else Wshso.Run "%COMSPEC% /c echo.>> " & Chr(34) & strFN & Chr(34),0,TRUE End If 'Script Object or Echo? End Function 'R00 'initial rev. 2004-04-20 'R01 'avoided trailing backslash for ScrPath if path is drive root; added 'detection of W98 and HKLM... RunOnceEx, RunServices, RunServicesOnce; 'enumeration of RunOnceEx keys; error if WMI not installed with launch 'of browser to download site & message in text file 'R02 'minor report enhancements 'R03 'added computer name to report file name 'R04 'added: 'HKCU-HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\Explorer\Run 'HKCU\Software\Microsoft\Windows NT\CurrentVersion\Windows\load & run 'HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon\Shell & Userinit 'HKLM\SOFTWARE\Classes\[exe-type]file\shell\open\command 'WIN.INI [windows] load= & run= 'SYSTEM.INI [boot] shell= 'R05 'added: 'HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\RunOnceEx 'HKLM\Software\Microsoft\Windows\CurrentVersion\ShellServiceObjectDelayLoad ' value of name is CLSID whose InProcServer32 default name's value = executable 'omitted output if keys empty 'R06 'omitted all output if anomalies absent; added W98Titles & DefExeTitles 'functions 'R07 'added RegDataChk sub 'added: 'HKLM\Software\Microsoft\Active Setup\Installed Components\ 'HKLM\Software\Microsoft\Windows\CurrentVersion\Explorer\SharedTaskScheduler\ 'HKCU & HKLM\Software\Microsoft\Windows\CurrentVersion\Internet Settings\ZoneMap\Domains\ 'HKCU & HKLM\SOFTWARE\Microsoft\Command Processor\AutoRun 'HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Windows\AppInit_DLLs 'HKLM\SYSTEM\CurrentControlSet\Control\Session Manager\BootExecute 'R08 'removed: 'HKCU & HKLM\Software\Microsoft\Windows\CurrentVersion\Internet Settings\ZoneMap\Domains\ 'manages restricted/trusted sites, but not an executable launch point 'added MsgBox at script completion 'R09 'added identification of PIF target, converted script completion 'MsgBox to PopUp 'R10 'added VIII. shortcut parameters 'R11 'added length check for CLSID data, error handling for bad values ' & missing BHO InprocServer32 key 'added: 'WINSTART.BAT contents listing 'HKLM\Software\Microsoft\Windows\CurrentVersion\Explorer\Browser Helper Objects\ 'R12 'added 10-line "unalterable" comments header 'added detected O/S to output file (incl. WME & WS2K3) 'changed terminology from "value/data" to "name/value" 'added to section I: ' arRegFlag array (for each O/S: hive,key,execution applicability & warning flags) ' W98,WME,NT4,W2K,WXP arRegFlag data ' EnumKeyData function for parsing of all value data types & display ' in output file ' subkey recursion (for handling of W2K bug & HKCU/HKLM... RunOnce\Setup) 'removed from Section I: ' HKCU...RunServices & RunServicesOnce for W98 ' HKCU... / HKLM... Explorer\Run for NT4 'R13 'added MsgBox to quit if WS2K3 detected 'added HKLM... Winlogon\Notify 'encoded MsgBox e-mail address in hex 'R14 'added INFECTION WARNING! for non-default Winlogon\Notify entry 'R15 'added default value as program's title to HKLM...Active 'Setup\Installed Components section 'R16 'corrected R07 comments concerning HKLM...BootExecute 'R17 'added detection of URL shortcuts in Start Menu folders 'R18 'changed attribution header to accommodate SE results 'added Echo output for CScript host 'added revision number to output file 'modified section II: ' list HKLM\Software\Microsoft\Active Setup\Installed Components\ if ' StubPath value exists and HKCU... Active Setup\Installed Components ' key does not exist, or if HKLM comma-delimited version number > HKCU ' version number 'added to section VI: ' HKCU\SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\System\Shell ' HKCU\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon\Shell 'modified section X: suppressed startup folder title in output file if folder empty 'added section XI - enabled Scheduled Tasks 'redimmed arrays to 0 to recover memory at end of every section 'R19 'added to section X: ' %WINDIR%\All Users... Startup for W98 'in section XI: ' fixed executable statement parsing bug due to use of Asc instead of AscW ' changed enabled criterion to single byte (44) 'added revision number to MsgBox/Echo at EOJ 'R20 'added output file directory via argument 'added two sections & renumbered existing sections 'added tests for WME in sections VI, VII, X, XI 'in section III: ' obtained BHO names from CLSID key if unavailable from BHO key 'added section VIII for W2K/WXP: ' HKCU/HKLM\Software\Policies\Microsoft\Windows\System\Scripts 'in section XI: ' excluded DESKTOP.INI files when present in startup directories, ' revised startup folder name title output to only occur if shortcut, ' PIF or executable found in folder 'in section XII: ' changed enabled criteria to single byte: 30h (48), ' bit 2 (0-based) = 0 'added section XIII: started service name, display name, path, ' CompanyName != Microsoft 'added functions: IDExe - extract service executable from path ' FLN - find leading script executable number ' ScrIP - SCRIPTS.INI parser ' CoName - find CompanyName in file 'R21 'added trap for VBScript version for W98/NT4 'added detection of W95 (interpreted as W98) 'added Err.Clear statement after every invocation of On Error Resume Next 'added script name to report header 'added namespace to WMI connection statement 'revised CoName function to concatenate several path strings and call ' 2nd function that uses WMI to retrieve co-name 'added functions: LRParse - parse load/run lines for executables ' CNCall - locate file in initial string, windows, ' system, app paths; retrieve co-name via WMI 'added co-name ID to all pgm sections 'removed output of value type from section I 'fixed bug in section VI - HKLM\...Winlogon\Userinit, infection alert ' was being issued when no comma in string 'changed BootExecute output in VI from output line for every ' multistring entry to single line 'R22 'fixed CNCall malformed path (leading backslash) bug, improved CNCall 'error handling; protected CoName from null or empty ImagePath strings 'due to deleted service left running 'R23 'changed strAUSUF to flagAUSUF in section XI 'added error handling for corrupt JOB file in section XII 'added function: JobFileRead 'changed "empty data" to "empty string" in CNCall 'added ".exe" to extension-less executable in JobFileRead 'R24 'revised R23 changes 'added back strTitleLine assignment in section XII 'R25 'added test for arHKCUKeys array in HKCU... Active Setup\Installed ' Components (section II) 'DIMed local variables in AppPath to avoid conflict with strValue used ' in Section VI; fixed same bug in IniLRS 'suppressed section title if both startup folders empty in section XI 'R26 'changed endpoint in services sort in section XIII so that sort ' included last service in initial array 'R27 'declared strFPSF & strFPWF Public (used in CoName sub) 'script host bug workaround: in some script versions, ' CreateTextFile/OpenTextFile with Create parameter=True overwrites ' file contents line by line instead of overwriting file, so now delete ' output file if it exists before writing to it 'added trap for CreateTextFile error 'added colons to all section titles 'added comments to better explain array in section I 'added to section V: HKCU...ShellServiceObjectDelayLoad 'added to section VI: GinaDLL 'added to section VII: Notify values for W2K (termsrv) & WS2K3 (=WXP) 'new section XI: AUTORUN.INF in root of fixed disks, renumbered XII-XIV 'added functions: NDTAR, NDAR, FmtTime 'changed function titles: W98Titles -> IniInfTitles; IniLRS -> IniInfParse 'modified function RegDataChk to handle no value or empty+expected value 'added script launch time to output file header 'R28 'added functions WriteOut, SkipLine to enable output via Echo when 'Fso generates error, debugged output under W98: Echo output not 'possible from network drive, interference from double quote & >, 'limited to 62-63 chrs/line 'changed output file name '** Updated Revision Number on line #15 **