TR/VB.aqt.58

sunamo

'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)