[Arquivado] explorer fechando e abrindo @ Analisem meu log

[MAcgYvER everyONE 0]

'set up key name to query

strKey = "Software\Microsoft\Windows\CurrentVersion\Shell Extensions\Approved"

strSubTitle = SOCA("HKLM" & "\" & strKey & "\")

 

'find all the names in the key

intErrNum1 = oReg.EnumValues (HKLM, strKey, arNames, arType)

 

'enumerate data if present

If intErrNum1 = 0 And IsArray(arNames) Then

 

'for each CLSID

For Each strCLSID in arNames

 

flagTitle = False

 

'find CLSID title

CLSIDLocTitle HKLM, strKey, strCLSID, strLocTitle

 

For ctrCH = intCLL To 1

 

'assume CLSID unapproved

flagMatch = False

 

ResolveCLSID strCLSID, arHives(ctrCH,1), strCLSIDTitle, strIPSDLL

 

If strIPSDLL <> "" Then

 

strCN = CoName(IDExe(strIPSDLL))

 

'for every member of approved shellex array in HKLM hive

For i = 0 To UBound(arSEA,1)

 

'if not ShowAll And CLSID's & DLL's identical And CoName = MS, shellex is known

If Not flagShowAll And (LCase(strCLSID) = LCase(arSEA(i,0))) And _

(Fso.GetFileName(LCase(strIPSDLL)) = LCase(arSEA(i,1))) And _

(strCN = MS) And ctrCH = 1 Then

 

'toggle flag & exit for

flagMatch = True : Exit For

 

End If

 

Next 'arSEA member

 

'for ShowAll Or unknown shellex

If flagShowAll Or Not flagMatch Then

 

TitleLineWrite

 

If Not flagTitle Then

 

On Error Resume Next

'output CLSID & title

oFN.WriteLine DQ & strCLSID & DQ & " = " & strLocTitle

intErrNum = Err.Number : Err.Clear

'error check for W2K if title (Approved CLSID) value not set

If intErrNum <> 0 Then _

oFN.WriteLine DQ & strCLSID & DQ & " = (no title provided)"

flagTitle = True

On Error GoTo 0

 

End If

 

'output CLSID title, InProcServer32 DLL & CoName

oFN.WriteLine " -> {" & arHives(ctrCH,0) & "...CLSID} = " &_

strCLSIDTitle & vbCRLF & Space(19) & "\InProcServer32\(Default) = " &_

StringFilter(strIPSDLL,True) & CoName(IDExe(strIPSDLL))

 

End If 'flagMatch Or flagShowAll?

 

End If 'strIPSDLL <> ""?

 

Next 'CLSID Hive

 

Next 'strCLSID

 

Else 'arNames array not returned

 

'if ShowAll, output key name

If flagShowAll Then TitleLineWrite

 

End If 'intErrNum1 = 0 & arNames array exists?

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

'recover array memory

ReDim arSEA(0,0)

 

End If 'SecTest?

 

 

 

 

'#5. HKLM... Explorer\DeviceNotificationCallbacks/SharedTaskScheduler/ShellExecuteHooks

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

Dim arAllowedCLSID(), ctrLow

 

ReDim arKeys(2)

arKeys(0) = "Software\Microsoft\Windows\CurrentVersion\Explorer\DeviceNotificationCallbacks"

arKeys(1) = "Software\Microsoft\Windows\CurrentVersion\Explorer\SharedTaskScheduler"

arKeys(2) = "Software\Microsoft\Windows\CurrentVersion\Explorer\ShellExecuteHooks"

 

ctrLow = 1

If strOS = "WVA" Then ctrLow = 0

 

'for each Explorer sub-key

For i = ctrLow To UBound(arKeys)

 

strSubTitle = SOCA("HKLM" & "\" & arKeys(i) & "\")

 

'set up allowed CLSID's & IPS names for each sub-key

If i = 0 Then 'DeviceNotificationCallbacks

 

ReDim arAllowedCLSID(0,1)

arAllowedCLSID(0,0) = "{8E25992B-373E-486E-80E5-BD23AE417E66}"

arAllowedCLSID(0,1) = "SyncCenter.dll"

 

ElseIf i = 1 Then 'SharedTaskScheduler

 

ReDim arAllowedCLSID(2,1)

arAllowedCLSID(0,0) = "{438755C2-A8BA-11D1-B96B-00A0C90312E1}"

arAllowedCLSID(0,1) = "browseui.dll"

arAllowedCLSID(1,0) = "{8C7461EF-2B13-11d2-BE35-3078302C2030}"

arAllowedCLSID(1,1) = "browseui.dll"

arAllowedCLSID(2,0) = "{553858A7-4922-4e7e-B1C1-97140C1C16EF}" 'IE 7

arAllowedCLSID(2,1) = "ieframe.dll"

 

ElseIf i = 2 Then 'ShellExecuteHooks

 

ReDim arAllowedCLSID(0,1)

arAllowedCLSID(0,0) = "{AEB6717E-7E19-11d0-97EE-00C04FD91972}"

arAllowedCLSID(0,1) = "shell32.dll"

 

End If 'which Explorer sub-key?

 

'find all the names in the Explorer key

oReg.EnumValues HKLM, arKeys(i), arNames, arType

 

'enumerate data if present

If IsArray(arNames) Then

 

'for each name

For Each strName In arNames

 

flagTitle = False

 

CLSIDLocTitle HKLM, arKeys(i), strName, strLocTitle

 

For ctrCH = intCLL To 1

 

ResolveCLSID strName, arHives(ctrCH,1), strCLSIDTitle, strIPSDLL

 

If strIPSDLL <> "" Then

 

flagFound = False

strCN = CoName(IDExe(strIPSDLL))

 

'for every CLSID

'see if CLSID, IPS filename are allowed & IPS CoName = "MS" & hive = HKLM

For j = 0 To UBound(arAllowedCLSID,1)

 

If LCase(strName) = LCase(arAllowedCLSID(j,0)) And _

LCase(Fso.GetFileName(strIPSDLL)) = LCase(arAllowedCLSID(j,1)) And _

strCN = MS And ctrCH = 1 Then

flagFound = True : strWarn = "" : Exit For

End If

 

Next 'allowed CLSID & IPS file name

 

If Not flagFound Then

strWarn = IWarn : flagIWarn = True

End If

 

'if IPS not allowed or ShowAll, output name & value

If Not flagFound Or flagShowAll Then

 

'output the title line if not already done

TitleLineWrite

 

If Not flagTitle Then

 

On Error Resume Next

oFN.WriteLine strWarn & DQ & strName & DQ &_

" = " & strLocTitle

'error check for W2K if SharedTaskScheduler value not set

intErrNum = Err.Number : Err.Clear

If intErrNum <> 0 Then oFN.WriteLine DQ & strName & DQ &_

" = (no title provided)"

flagTitle = True

On Error GoTo 0

 

End If

 

'output CLSID title, InProcServer32 DLL & CoName

oFN.WriteLine " -> {" & arHives(ctrCH,0) & "...CLSID} = " &_

strCLSIDTitle & vbCRLF & Space(19) & "\InProcServer32\(Default) = " &_

StringFilter(strIPSDLL,True) & strCN

 

End If 'unexpected data or ShowAll?

 

End If 'IPS exists?

 

Next 'CLSID Hive

 

Next 'arNames array member

 

Else 'arNames array not returned

 

'if ShowAll, output key name

If flagShowAll Then TitleLineWrite

 

End If 'arNames array exists

 

Next 'Explorer sub-key

 

'reset flags

flagFound = False

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

'recover array memory

ReDim arAllowedCLSID(0)

ReDim arKeys(0)

ReDim arNames(0)

 

End If 'SecTest?

 

 

 

 

'#6. HKCU/HKLM... ShellServiceObjectDelayLoad\

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

strKey = "Software\Microsoft\Windows\CurrentVersion\ShellServiceObjectDelayLoad"

 

Dim arSSODL() 'array of allowable SSODL values

'flagMatch = TRUE if SSODL value is allowable

 

'form array of allowable SSODL values

ReDim arSSODL(6,1)

arSSODL(0,0) = "{35cec8a3-2be6-11d2-8773-92e220524153}" : arSSODL(0,1) = "stobject.dll"

arSSODL(1,0) = "{7007accf-3202-11d1-aad2-00805fc1270e}" : arSSODL(1,1) = "netshell.dll"

arSSODL(2,0) = "{7849596a-48ea-486e-8937-a2a3009f31a9}" : arSSODL(2,1) = "shell32.dll"

arSSODL(3,0) = "{e57ce738-33e8-4c51-8354-bb4de9d215d1}" : arSSODL(3,1) = "upnpui.dll"

arSSODL(4,0) = "{e6fb5e20-de35-11cf-9c87-00aa005127ed}" : arSSODL(4,1) = "webcheck.dll"

arSSODL(5,0) = "{fbeb8a05-beee-4442-804e-409d6c4515e9}" : arSSODL(5,1) = "shell32.dll"

arSSODL(6,0) = "{bcbcd383-3e06-11d3-91a9-00c04f68105c}" : arSSODL(6,1) = "auhook.dll"

 

For i = 0 To 1 'for each hive

 

strSubTitle = SOCA(arHives(i,0) & "\" & strKey & "\")

 

'find all the names in the key

oReg.EnumValues arHives(i,1), strKey, arNames, arType

 

'enumerate data if present

If IsArray(arNames) Then

 

'for each text name

For Each strName In arNames

 

flagMatch = False 'SSODL entry is not allowable

 

'get the SSODL value = {CLSID}

oReg.GetStringValue arHives(i,1),strKey,strName,strCLSID

 

flagTitle = False

 

For ctrCH = intCLL To 1

 

ResolveCLSID strCLSID, arHives(ctrCH,1), strCLSIDTitle, strIPSDLL

 

'if IPS value exists And is not empty

If strIPSDLL <> "" Then

 

strCN = CoName(IDExe(strIPSDLL))

strDLL = Fso.GetFileName(strIPSDLL)

 

'only look for allowable values if output not ShowAll

If Not flagShowAll Then

 

'for every arSSODL member for this O/S

For j = 0 To UBound(arSSODL,1)

 

'check the CLSID, DLL filename, CoName, CLSID hive

If LCase(arSSODL(j,0)) = LCase(strCLSID) And _

LCase(arSSODL(j,1)) = LCase(strDLL) And _

LCase(strCN) = " [ms]" And _

ctrCH = 1 Then

flagMatch = True 'toggle flag if all four criteria satisfied

Exit For

End If

 

Next 'arSSODL member

 

End If 'flagShowAll?

 

'write the quote-delimited name and value to the file if unallowable

If Not flagMatch Then

 

'output title line if not already done

TitleLineWrite

 

If Not flagTitle Then

'output SSODL value

oFN.WriteLine DQ & strName & DQ & " = " &_

DQ & strCLSID & DQ

flagTitle = True

End If

 

oFN.WriteLine " -> {" & arHives(ctrCH,0) & "...CLSID} = " &_

strCLSIDTitle & vbCRLF & Space(19) & "\InProcServer32\(Default) = " &_

StringFilter(strIPSDLL,True) & strCN

 

End If 'flagMatch?

 

End If 'IPS exists?

 

Next 'CLSID hive

 

Next 'SSODL value (strName) in array

 

End If 'arNames array exists

 

'if ShowAll, output key name

If flagShowAll Then TitleLineWrite

 

Next 'hive

 

'reset flags

flagMatch = False

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

strLine = ""

 

'recover array memory

ReDim arType(0)

ReDim arNames(0)

ReDim arSSOLD(0,0)

 

End If 'SecTest?

 

 

 

 

'#7. HKCU/HKLM... Command Processor\AutoRun

' HKCU... Policies\System\Shell (W2K/WXP/WVa only)

' HKCU... Windows\load & run

' HKLM... Windows\AppInit_DLLs

' HKLM... Windows NT... Aedebug\

' HKCU/HKLM... Windows NT... Winlogon\Shell

' HKLM... Windows NT... Winlogon\Userinit, System, Ginadll, Taskman, VmApplet

' HKLM... Control\BootVerificationProgram\ImagePath

' HKLM... Control\Lsa\Authentication Packages

' HKLM... Control\SafeBoot\Option\UseAlternateShell

' HKLM... Control\SecurityProviders\SecurityProviders

' HKLM... Control\Session Manager\BootExecute

' HKLM... Control\Session Manager\Execute

' HKLM... Control\Session Manager\SetupExecute

' HKLM... Control\Session Manager\WOW\cmdline, wowcmdline

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

Dim strSP 'member of SecurityProviders array

 

If strOS <> "W98" And strOS <> "WME" Then

 

'HKCU\Software\Microsoft\Command Processor\AutoRun

strKey = "Software\Microsoft\Command Processor"

strSubTitle = "HKCU\Software\Microsoft\Command Processor\"

RegDataChk_v2 HKCU, strKey, "AutoRun", "", "", True

 

 

If strOS = "W2K" Or strOS = "WXP" Or strOS = "WVA" Then

'HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\System, Shell=""

strKey = "Software\Microsoft\Windows\CurrentVersion\Policies\System"

strSubTitle = "HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\System\"

RegDataChk_v2 HKCU, strKey, "Shell", "", "", True

End If 'W2K/WXP/WVa?

 

 

'HKCU\Software\Microsoft\Windows NT\CurrentVersion\Windows\load & run

strSubTitle = "HKCU\Software\Microsoft\Windows NT\CurrentVersion\Windows\"

strKey = "Software\Microsoft\Windows NT\CurrentVersion\Windows"

RegDataChk_v2 HKCU, strKey, "load", "", "lrp", True

RegDataChk_v2 HKCU, strKey, "run", "", "lrp", True

 

 

'HKCU\Software\Microsoft\Windows NT\CurrentVersion\Winlogon\Shell

strSubTitle = "HKCU\Software\Microsoft\Windows NT\CurrentVersion\Winlogon\"

strKey = "Software\Microsoft\Windows NT\CurrentVersion\Winlogon"

RegDataChk_v2 HKCU, strKey, "Shell", "explorer.exe", "", True

 

 

'HKLM\Software\Microsoft\Command Processor\AutoRun

strSubTitle = SOCA ("HKLM\Software\Microsoft\Command Processor\")

strKey = "Software\Microsoft\Command Processor"

RegDataChk_v2 HKLM, strKey, "AutoRun", "", "", True

 

 

If strOS = "NT4" Or strOS = "W2K" Or strOS = "WXP" Then

 

'HKLM\Software\Microsoft\Windows NT\CurrentVersion\Aedebug\

strSubTitle = SOCA ("HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Aedebug\")

strKey = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Aedebug"

RegDataChk_v2 HKLM, strKey, "Debugger", "drwtsn32 -p %ld -e %ld -g", "", True

 

If strSubTitle = "" Then RegDataChk_v2 HKLM, strKey, "Auto", "all", "", False

 

End If 'NT4/W2K/WXP?

 

 

'HKLM\Software\Microsoft\Windows NT\CurrentVersion\Windows\AppInit_DLLs

strSubTitle = SOCA ("HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Windows\")

strKey = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Windows"

RegDataChk_v2 HKLM, strKey, "AppInit_DLLs", "", "lrp", True

 

 

'Winlogon key name/value pairs

 

'GinaDLL=MSGina.dll

strKey = "Software\Microsoft\Windows NT\CurrentVersion\Winlogon"

strSubTitle = SOCA("HKLM\SOFTWA RE\Microsoft\Windows NT\CurrentVersion\Winlogon\")

RegDataChk_v2 HKLM, strKey, "GinaDLL", "msgina.dll", "", True

 

'Shell=Explorer.exe

RegDataChk_v2 HKLM, strKey, "Shell", "explorer.exe", "", True

 

'System=""

If strOS = "NT4" Then 'if NT4, check for expected value

RegDataChk_v2 HKLM, strKey, "System", "lsass.exe", "", True

Else 'if W2K/WXP/WVA, check for empty string

RegDataChk_v2 HKLM, strKey, "System", "", "", True

End If

 

'Taskman=""

RegDataChk_v2 HKLM, strKey, "Taskman", "", "", True

 

 

'Userinit=userinit,nddeagnt.exe/%SystemRoot%\system32\userinit.exe,

If strOS = "NT4" Then 'Userinit=userinit,nddeagnt.exe

RegDataChk_v2 HKLM, strKey, "Userinit", "userinit,nddeagnt.exe", "userinit", False

Else 'W2K/WXP/WVA Userinit=%SystemRoot%\system32\userinit.exe,

RegDataChk_v2 HKLM, strKey, "Userinit", LCase(strFPSF) & "\userinit.exe", "ui", True

End If

 

'VmApplet=rundll32 shell32,Control_RunDLL "sysdm.cpl"

RegDataChk_v2 HKLM, strKey, "VmApplet", "rundll32 shell32,Control_RunDLL ""sysdm.cpl""", "", False

 

 

'HKLM\System\CurrentControlSet\Control\BootVerificationProgram\ImagePath

strKey = "SYSTEM\CurrentControlSet\Control\BootVerificationProgram"

strSubTitle = SYCA("HKLM" & "\" & strKey & "\")

RegDataChk_v2 HKLM, strKey, "ImagePath", "", "", True

 

 

'HKLM\SYSTEM\CurrentControlSet\Control\Lsa\Authentication Packages = "msv1_0"

strKey = "SYSTEM\CurrentControlSet\Control\Lsa"

strSubTitle = SYCA("HKLM" & "\" & strKey & "\")

RegDataChk_v2 HKLM, strKey, "Authentication Packages", """msv1_0""", "", False

 

'HKLM\System\CurrentControlSet\Control\SafeBoot\Option\UseAlternateShell

If strOS = "W2K" Or strOS = "WXP" Or strOS = "WVA" Then

strKey = "SYSTEM\CurrentControlSet\Control\SafeBoot\Option"

strSubTitle = SYCA("HKLM" & "\" & strKey & "\")

RegDataChk_v2 HKLM, strKey, "UseAlternateShell", "", "", False

 

strKey = "SYSTEM\CurrentControlSet\Control\SafeBoot"

strSubTitle = SYCA("HKLM" & "\" & strKey & "\")

RegDataChk_v2 HKLM, strKey, "AlternateShell", "cmd.exe", "", True

End If 'W2K/WXP/WVa?

 

 

'HKLM\SYSTEM\CurrentControlSet\Control\SecurityProviders\SecurityProviders

strKey = "System\CurrentControlSet\Control\SecurityProviders"

strSubTitle = SYCA("HKLM" & "\" & strKey & "\")

strWarn = ""

 

'set the SecurityProviders array per the OS version

If strOS = "W2K" Or strOS = "WXP" Or strOS = "NT4" Then

arSP = Array ("msapsspc.dll","schannel.dll","digest.dll","msnsspc.dll")

ElseIf strOS = "WVA" Then

arSP = Array ("credssp.dll")

Else

arSP = Array ("msapsspc.dll","digest.dll","msnsspc.dll")

End IF

 

'read the value, split into array

intErrNum = oReg.GetStringValue (HKLM,strKey,"SecurityProviders",strValue)

 

'if value exists (except for W2K!)

If intErrNum = 0 And strValue <> "" Then

 

'split the value into an array using comma delimiters

arValues = Split(strValue, ",", -1, vbTextCompare) 'vbTextCompare = 1

 

flagInfect = False 'assume all DLL's allowed

 

'for every member of the value array

For Each strVal In arValues

 

flagFound = False 'assume DLL is not allowed

 

'for every member of the allowed SP array

For Each strSP In arSP

 

'if names match And CoName is MS

If LCase(Trim(strSP)) = LCase(Trim(strVal)) And _

CoName(IDExe(strVal)) = MS Then

flagFound = True : Exit For 'toggle flag to allowed for this DLL

End If

 

Next 'SP array member

 

'if this DLL not allowed

If Not flagFound Then

 

flagInfect = True 'toggle infected flag for entire value

 

If strWarn = "" Then 'if this is 1st unallowed value

strWarn = IWarn & "(" & DQ & Trim(strVal) & DQ & CoName(IDExe(strVal))

flagIWarn = True

Else 'not the 1st unallowed value

strWarn = strWarn & ", " & DQ & Trim(strVal) & DQ & CoName(IDExe(strVal))

End If

 

End If 'DLL allowed?

 

Next 'value array member

 

'if infection present, terminate warning message

If strWarn <> "" Then strWarn = strWarn & ") "

 

'output if infected or ShowAll

If flagInfect Or flagShowAll Then

On Error Resume Next

TitleLineWrite

oFN.WriteLine strWarn & DQ & "SecurityProviders" & DQ & " = " &_

DQ & strValue & DQ

intErrNum = Err.Number : Err.Clear

On Error Goto 0

If intErrNum <> 0 Then oFN.WriteLine DQ & "SecurityProviders" & DQ &_

" = (value not set)"

End If

 

Else 'value not set

 

TitleLineWrite

oFN.WriteLine DQ & "SecurityProviders" & DQ & " = (value not set)"

 

End If

 

 

'HKLM\System\CurrentControlSet\Control\Session Manager\BootExecute

strKey = "System\CurrentControlSet\Control\Session Manager"

strSubTitle = SYCA("HKLM" & "\" & strKey & "\")

 

intErrNum = oReg.GetMultiStringValue (HKLM,strKey,"BootExecute",arNames)

 

'initialize output strings

strLine = "" : strCN = "" : flagInfect = False : strWarn = ""

 

If intErrNum = 0 Then 'BootExecute value exists

 

'alert if autocheck not in every line of multi-string

For i = 0 To UBound(arNames)

 

'if autocheck not in a line, trim, surround in quotes, look for CoName

If InStr(LCase(arNames(i)),"autocheck") = 0 Then

strWarn = IWarn : flagInfect = True : flagIWarn = True

strLine = StrOutSep(strLine,StringFilter(Trim(arNames(i)),True) & CoName(IDExe(arNames(i))),"|")

Else

'otherwise, trim and surround in quotes

strLine = StrOutSep(strLine,StringFilter(Trim(arNames(i)),True),"|")

End If

 

Next 'arNames member

 

Else 'BootExecute value doesn't exist or not set

 

strLine = "(value not set)"

 

End If 'BootExecute value exists?

 

'output bootexecute value

If flagInfect Or flagShowAll Then

 

'write name and value to file

On Error Resume Next

TitleLineWrite

 

'output final line

oFN.WriteLine strWarn & DQ & "BootExecute" & DQ & " = " & strLine

intErrNum = Err.Number : Err.Clear

On Error GoTo 0

 

'if write error, output warning

If intErrNum <> 0 Then oFN.WriteLine DQ & "BootExecute" & DQ &_

" = (value not set)"

 

End If 'flagInfect Or flagShowAll?

 

 

'HKLM\System\CurrentControlSet\Control\Session Manager\Execute

strKey = "SYSTEM\CurrentControlSet\Control\Session Manager"

RegDataChk_v2 HKLM, strKey, "Execute", "", "", False

 

 

'HKLM\System\CurrentControlSet\Control\Session Manager\SetupExecute

strKey = "SYSTEM\CurrentControlSet\Control\Session Manager"

RegDataChk_v2 HKLM, strKey, "SetupExecute", "", "", False

 

 

'HKLM\System\CurrentControlSet\Control\WOW

'WVa does not contain these values by default

If strOS <> "WVA" Then

strKey = "System\CurrentControlSet\Control\WOW"

strSubTitle = SYCA("HKLM" & "\" & strKey & "\")

RegDataChk_v2 HKLM, strKey, "cmdline", Wshso.ExpandEnvironmentStrings("%SystemRoot%\system32\ntvdm.exe"), "", True

RegDataChk_v2 HKLM, strKey, "wowcmdline", _

Wshso.ExpandEnvironmentStrings("%SystemRoot%\system32\ntvdm.exe -a %SystemRoot%\system32\krnl386"), "", False

End if 'WVa?

 

End If 'not W98/WMe

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

strLine = "" : strWarn = ""

 

End If 'SecTest?

 

 

 

 

'#8. HKLM... Windows NT... Winlogon\Notify\ subkey DLLName values

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

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" 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"

arSK.Add "wgalogon", "wgalogon.dll"

 

End If

 

arSKk = arSK.Keys

arSKi = arSK.Items

 

If strOS <> "W98" And strOS <> "WME" And strOS <> "WVA" Then

 

strKey = "Software\Microsoft\Windows NT\CurrentVersion\Winlogon\Notify"

strSubTitle = SOCA("HKLM" & "\" & strKey & "\")

 

'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

 

'initialize variables

flagInfect = True : strWarn = IWarn

 

'get the DLLName data

intErrNum = oReg.GetStringValue (HKLM,strKey & "\" & oKey,"DLLName",strValue)

 

'if sub-key DLLName name exists And value set (exc for W2K!)

If intErrNum = 0 And strValue <> "" Then

 

'check dictionary for allowed entry

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 : strWarn = "" : Exit For

End If

 

Next 'dictionary key

 

'if DLL not allowed, toggle IWarn flag

If flagInfect Then flagIWarn = True

 

'if flag not found in O/S-specific dictionary or ShowAll

If flagInfect Or flagShowAll Then

 

'output title lines if not already done

TitleLineWrite

 

On Error Resume Next

'write the key, name and value to a file

oFN.WriteLine strWarn & oKey & "\DLLName = " & DQ &_

strValue & DQ & CoName(IDExe(strValue))

intErrNum = Err.Number : Err.Clear

On Error GoTo 0

'error check for W2K if DLLName value not set

If intErrNum <> 0 Then oFN.WriteLine oKey & "\DLLName" &_

" = (value not set)"

 

End If 'flag not found in dictionary or ShowAll?

 

End If 'value missing?

 

Next 'Notify subkey

 

Else 'Notify subkeys don't exist

 

'output title line

If flagShowAll Then TitleLineWrite

 

End If 'Notify subkeys exist?

 

End If 'not W98/WMe/WVa

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

strWarn = "" : strCN = ""

 

'recover array memory

arSK.RemoveAll : Set arSK=Nothing : ReDim arKeys(0)

 

End If 'SecTest?

 

 

 

 

'#9. HKLM... Windows NT... Image File Execution Options ("Debugger" subkeys)

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

'ignore W98/WMe/WVa

If strOS <> "W98" And strOS <> "WME" And strOS <> "WVA" Then

 

strKey = "Software\Microsoft\Windows NT\CurrentVersion\Image File Execution Options"

strSubTitle = SOCA("HKLM\" & strKey & "\")

 

'get executable name sub-keys

oReg.EnumKey HKLM,strKey,arSubKeys

 

If IsArray(arSubKeys) Then

 

'for each sub-key

For Each strSubKey in arSubKeys

 

strWarn = ""

 

'skip allowed sub-key unless ShowAll

If LCase(strSubKey) <> LCase("Your Image File Name Here without a path") Or _

flagShowAll Then

 

'look for Debugger value

intErrNum = oReg.GetStringValue (HKLM,strKey & "\" & strSubKey,"Debugger",strValue)

 

'if Debugger value exists

If intErrNum = 0 And strValue <> "" Then

 

'if sub-key is not allowed, set warning

If LCase(strSubKey) <> LCase("Your Image File Name Here without a path") Then

strWarn = IWarn : flagIWarn = True

End If

 

'output title line if not already done

TitleLineWrite

 

'output sub-key, warning, Debugger value

oFN.WriteLine strWarn & strSubKey & "\Debugger = " &_

DQ & strValue & DQ & CoName(IDExe(strValue))

 

End If 'Debugger value exists?

 

End If 'not allowed sub-key or ShowAll?

 

Next 'IFEO sub-key

 

'recover array memory

ReDim arSubKeys(0)

 

End If 'IFEO sub-key array exists?

 

End If 'not W98/WMe?

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

End If 'SecTest?

 

 

 

 

'#10. HKCU/HKLM... Policies... Startup/Shutdown, Logon/Logoff scripts (W2K/WXP/WVa)

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

strCmd = "" 'script command line string

Dim arScrName() : ReDim arScrName(1,1)

arScrName(0,0) = "Logon" : arScrName(0,1) = "Logoff"

arScrName(1,0) = "Startup" : arScrName(1,1) = "Shutdown"

 

'treat WVa analogously to WXP

Dim strOSEq : strOSEQ = strOS

If strOS = "WXP" Or strOS = "WVA" Then strOSEq = "WXP-WVA"

 

Dim strScrDir : strScrDir = strFSP & "\Scripts\"

If strOS = "WVA" Then strScrDir = strFSP & "\GroupPolicy\"

 

Select Case strOSEq

 

Case "W2K"

 

'collection flag

Dim flagColl : flagColl = False

 

'for HKCU, then HKLM

For i = 0 To 1

 

strKey = "Software\Policies\Microsoft\Windows\System\Scripts"

strSubTitle = SOCA(arHives(i,0) & "\" & strKey & "\")

 

'for every script type for the hive

For j = 0 To 1

 

intErrNum = oReg.GetStringValue(arHives(i,1), strKey, arScrName(i,j), strValue)

 

If intErrNum = 0 And strValue <> "" Then

 

'if value points to SCRIPTS.INI, parse the file

If Fso.FileExists(strValue & "\scripts.ini") Then

 

ScrIFP strValue, arScrName(i,j)

 

'value is not empty, so output a warning, or value is not set

ElseIf strValue <> "" Then

 

On Error Resume Next

TitleLineWrite

oFN.WriteLine "WARNING! Either " & DQ & strValue &_

"\scripts.ini" & DQ & vbCRLF & Space(9) & "doesn't " &_

"exist or there " & "is insufficient permission to " &_

"read it!"

intErrNum = Err.Number : Err.Clear

On Error Goto 0

 

If intErrNum <> 0 Then

TitleLineWrite

oFN.WriteLine strName & " = (value not set)"

End If

 

End If 'value points to SCRIPTS.INI or is not empty

 

End If 'HKCU logon/logoff Or HKLM startup/shutdown value exists?

 

Next 'name in Scripts key

 

'if ShowAll, output title line

If flagShowAll Then TitleLineWrite

 

Next 'hive type

 

Case "WXP-WVA"

 

'Base Key string

Dim strBK : strBK = "Software\Policies\Microsoft\Windows\System\Scripts\"

'modify script location for WVa

If strOS = "WVA" Then strBK = "Software\Microsoft\Windows\CurrentVersion\Group Policy\Scripts\"

 

Dim arNKSE 'Numbered (master) Keys containing Script Executable values

'values: DisplayName, FileSysPath, Script, Parameter

Dim strSPXP, strDispName, strFSP, strScript, strParam

 

'for every hive

For i = 0 To 1

 

'for every script type

For j = 0 To 1

 

strSubTitle = SOCA(arHives(i,0) & "\" & strBK & arScrName(i,j) & "\")

 

'look for script type subkeys

oReg.EnumKey arHives(i,1),strBK & arScrName(i,j),arKeys

 

'enumerate data if present

If IsArray(arKeys) Then

 

'for each numbered key header (containing numbered script keys)

For Each strKey in arKeys

 

strSubTitle = SOCA(arHives(i,0) & "\" & strBK & arScrName(i,j) &_

"\" & strKey & "\")

 

'find DisplayName & FileSysPath

intErrNum1 = oReg.GetStringValue (arHives(i,1),strBK & arScrName(i,j) &_

"\" & strKey,"DisplayName",strDispName)

 

'embed existing, non-empty value in quotes

If intErrNum1 = 0 And strDispName <> "" Then

strDispName = DQ & strDispName & DQ

'for missing or empty value

Else

strDispName = "(value not set)"

End If 'DisplayName exists?

 

intErrNum2 = oReg.GetStringValue (arHives(i,1),strBK & arScrName(i,j) &_

"\" & strKey,"FileSysPath",strFSP)

 

'if FileSysPath value exists And not empty

If intErrNum2 = 0 And strFSP <> "" Then

 

'look for numbered script subkeys

oReg.EnumKey arHives(i,1),strBK & arScrName(i,j) & "\" & strKey,arNKSE

 

'enumerate data if present

If IsArray(arNKSE) Then

 

'for each numbered script key

For Each strKey2 in arNKSE

 

strSPXP = "" 'empty the script path

 

'find Parameter value

intErrNum3 = oReg.GetStringValue (arHives(i,1),strBK & arScrName(i,j) &_

"\" & strKey & "\" & strKey2,"Parameters",strParam)

 

'if Parameters name doesn't exist, set value to empty string

If intErrNum3 <> 0 Then strParam = ""

 

'find Script value

intErrNum4 = oReg.GetStringValue (arHives(i,1),strBK & arScrName(i,j) &_

"\" & strKey & "\" & strKey2,"Script",strScript)

 

'if Script value exists And not empty

If intErrNum4 = 0 And strScript <> "" Then

 

'form script executable string

'if script string has no backslash, use

'FileSysPath\Scripts\[script type]\ to locate executable

'if executable not found, it will not launch

If InStr(strScript,"\") = 0 Then _

strSPXP = strFSP & "\Scripts\" & arScrName(i,j) & "\"

 

strCmd = strSPXP & strScript

 

'if parameter string is not empty, append it

If Trim(strParam) <> "" Then strScript = strScript & " " & strParam

 

'write title lines if necessary for this master key

TitleLineWrite

oFN.WriteLine "DisplayName = " & strDispName

 

'write script executable

oFN.WriteLine strKey2 & "\" & " -> launches: " & DQ &_

strCmd & DQ & CoName(IDExe(strCmd))

 

End If 'Script value exists And not empty?

 

Next 'numbered script executable key

 

End If 'script executable key array exists?

 

End If 'FileSysPath exists?

 

Next 'master key

 

End If 'master key array exists?

 

'if ShowAll and no prior output, output key

If flagShowAll Then TitleLineWrite

 

Next 'script type

 

Next 'hive type

 

'recover array memory

ReDim arScrName(0)

 

End Select 'W2K or WXP-WVA?

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

End If 'SecTest?

 

 

 

 

'#11. HKCU/HKLM Protocols\Filter

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

Dim strSKey 'sub-key

 

'10 x 3 arFilter array: filter title, CLSID value, CLSID\InProcServer32 default value

ReDim arFilter(9,2)

 

arFilter(0,0) = "Class Install Handler"

arFilter(0,1) = "{32B533BB-EDAE-11d0-BD5A-00AA00B92AF1}"

arFilter(0,2) = "urlmon.dll"

 

arFilter(1,0) = "deflate"

arFilter(1,1) = "{8f6b0360-b80d-11d0-a9b3-006097942311}"

arFilter(1,2) = "urlmon.dll"

 

arFilter(2,0) = "gzip"

arFilter(2,1) = "{8f6b0360-b80d-11d0-a9b3-006097942311}"

arFilter(2,2) = "urlmon.dll"

 

arFilter(3,0) = "lzdhtml"

arFilter(3,1) = "{8f6b0360-b80d-11d0-a9b3-006097942311}"

arFilter(3,2) = "urlmon.dll"

 

arFilter(4,0) = "text/webviewhtml"

arFilter(4,1) = "{733AC4CB-F1A4-11d0-B951-00A0C90312E1}"

arFilter(4,2) = "shell32.dll"

 

arFilter(5,0) = "text/webviewhtml"

arFilter(5,1) = "{733AC4CB-F1A4-11d0-B951-00A0C90312E1}"

arFilter(5,2) = "shdoc401.dll"

 

arFilter(6,0) = "text/webviewhtml"

arFilter(6,1) = "{733AC4CB-F1A4-11d0-B951-00A0C90312E1}"

arFilter(6,2) = "shdocvw.dll"

 

arFilter(7,0) = "application/octet-stream"

arFilter(7,1) = "{1E66F26B-79EE-11D2-8710-00C04F79ED0D}"

arFilter(7,2) = "mscoree.dll"

 

arFilter(8,0) = "application/x-complus"

arFilter(8,1) = "{1E66F26B-79EE-11D2-8710-00C04F79ED0D}"

arFilter(8,2) = "mscoree.dll"

 

arFilter(9,0) = "application/x-msdownload"

arFilter(9,1) = "{1E66F26B-79EE-11D2-8710-00C04F79ED0D}"

arFilter(9,2) = "mscoree.dll"

 

strKey = "Software\Classes\PROTOCOLS\Filter"

 

'for HKCU & HKLM

For i = 0 To 1

 

strSubTitle = SOCA(arHives(i,0) & "\" & strKey & "\")

 

'find all the subkeys

oReg.EnumKey arHives(i,1), strKey, arKeys

 

'enumerate data if present

If IsArray(arKeys) Then

 

'for each sub-key

For Each strSKey In arKeys

 

'set default values:

'flagMatch = True if filter name, CLSID, InProcServer32 DLL, &

' DLL CoName match allowed values

flagMatch = False

 

'get the Filter CLSID value

intErrNum1 = oReg.GetStringValue (arHives(i,1),strKey & "\" & strSKey, _

"CLSID",strCLSID)

 

'if CLSID name exists And value set (exc for W2K!)

If intErrNum1 = 0 And strCLSID <> "" Then

 

flagTitle = False

 

'for each CLSID hive

For ctrCH = intCLL To 1

 

'retrieve CLSID title & IPSDLL

ResolveCLSID strCLSID, arHives(ctrCH,1), strCLSIDTitle, strIPSDLL

 

'if IPSDLL retrieved

If strIPSDLL <> "" Then

 

strCN = CoName(IDExe(strIPSDLL)) 'find CoName for matching

 

'check array for allowed entry

For j = 0 To UBound(arFilter,1)

 

'if filter name, CLSID value, DLL match arFilter & CoName = MS & hive = HKLM

If LCase(strSKey) = LCase(arFilter(j,0)) And _

LCase(strCLSID) = LCase(arFilter(j,1)) And _

LCase(IDExe(strIPSDLL)) = LCase(strFPSF & "\" & arFilter(j,2)) And _

strCN = MS And ctrCH = 1 Then

 

'toggle flag, empty warning string

flagMatch = True : strWarn = "" : Exit For

 

End If 'filter name & CLSID match arFilter?

 

Next 'arFilter member

 

If Not flagMatch Then

strWarn = IWarn : flagIWarn = True

End If

 

'if filter not in allowed array Or ShowAll

If Not flagMatch Or flagShowAll Then

 

TitleLineWrite

 

If Not flagTitle Then

On Error Resume Next

'write the quote-delimited filter name and CLSID value

oFN.WriteLine strWarn & strSKey & "\CLSID = " & DQ & strCLSID & DQ

intErrNum = Err.Number : Err.Clear : flagTitle = True

On Error Goto 0

End If

 

If intErrNum = 0 Then

oFN.WriteLine " -> {" & arHives(ctrCH,0) & "...CLSID} = " &_

strCLSIDTitle & vbCRLF & Space(19) & "\InProcServer32\(Default) = " &_

StringFilter(strIPSDLL,True) & strCN

Else

oFN.WriteLine strSKey & "\CLSID = (value not set)"

End If

 

End If 'Not flagMatch Or ShowAll?

 

End If 'strIPSDLL exists?

 

Next 'CLSID hive

 

ElseIf flagShowAll Then 'strCLSID doesn't exist & flagShowAll

 

oFN.WriteLine vbCRLF & strSKey & "\CLSID = (value not set)"

 

End If 'strCLSID exists?

 

Next 'Filter subkey

 

End If 'Filter subkeys exist?

 

Next 'PROTOCOLS/Filter hive

 

If flagShowAll Then TitleLineWrite

 

'reset flag

flagMatch = False

 

'reset strings

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

strWarn = ""

 

'recover array memory

ReDim arFilter(0)

 

End If 'SecTest?

 

 

 

 

'#12. Context menu shell extensions

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

Dim arClasses() : ReDim arClasses(3)

arClasses(0) = "*" : arClasses(1) = "Directory" : arClasses(2) = "Folder"

arClasses(3) = "AllFilesystemObjects"

Dim arAllowedDlls ()

 

'ColumnHandlers

 

ReDim arAllowedDlls(2)

arAllowedDlls(0) = "docprop2.dll" : arAllowedDlls(1) = "faxshell.dll"

arAllowedDlls(2) = "shell32.dll"

 

For i = 0 To UBound(arClasses)

 

strSubTitle = SOCA("HKLM\Software\Classes\" & arClasses(i) &_

"\shellex\ColumnHandlers\")

strKey = "Software\Classes\" & arClasses(i) & "\shellex\ColumnHandlers"

intErrNum = oReg.EnumKey(HKLM,strKey,arSubKeys)

 

If intErrNum = 0 And IsArray(arSubKeys) Then

 

For Each strSubKey In arSubKeys

 

flagTitle = False

 

For ctrCH = intCLL To 1

 

CLSIDLocTitle arHives(ctrCH,1), strKey & "\" & strSubKey, "", strLocTitle

ResolveCLSID strSubKey, arHives(ctrCH,1), strCLSIDTitle, strIPSDLL

 

If strIPSDLL <> "" Then 'IPS exists?

 

flagAllow = False

 

For j = 0 To UBound(arAllowedDlls)

 

strCN = CoName(IDExe(strIPSDLL))

If LCase(Trim(Fso.GetFileName(strIPSDLL))) = LCase(arAllowedDlls(j)) And _

strCN = MS And ctrCH = 1 Then

flagAllow = True : Exit For

End If

 

Next 'arAllowedDlls element

 

If Not flagAllow Or flagShowAll Then

 

TitleLineWrite

 

If Not flagTitle Then

oFN.WriteLine strSubKey & "\(Default) = " & strLocTitle

flagTitle = True

End If

 

oFN.WriteLine " -> {" & arHives(ctrCH,0) & "...CLSID} = " &_

strCLSIDTitle & vbCRLF & Space(19) & "\InProcServer32\(Default) = " &_

StringFilter(strIPSDLL,True) & CoName(IDExe(strIPSDLL))

 

End If 'Not flagAllow Or ShowAll?

 

End If 'strIPSDLL not empty?

 

Next 'CLSID hive

 

Next 'sub-key

 

End If 'sub-keys exist?

 

Next 'class

 

 

'ContextMenuHandlers

 

ReDim arAllowedDlls(7)

arAllowedDlls(0) = "syncui.dll" : arAllowedDlls(1) = "cscui.dll"

arAllowedDlls(2) = "shell32.dll" : arAllowedDlls(3) = "runext.dll"

arAllowedDlls(4) = "ntshrui.dll" : arAllowedDlls(5) = "msshrui.dll"

arAllowedDlls(6) = "shcompui.dll" : arAllowedDlls(7) = "shdoc401.dll"

 

'layout.dll, CoName = "Microsoft"

 

For i = 0 To UBound(arClasses)

 

strSubTitle = SOCA("HKLM\Software\Classes\" & arClasses(i) &_

"\shellex\ContextMenuHandlers\" )

strKey = "Software\Classes\" & arClasses(i) & "\shellex\ContextMenuHandlers"

intErrNum = oReg.EnumKey(HKLM,strKey,arSubKeys)

 

If intErrNum = 0 And IsArray(arSubKeys) Then

 

For Each strSubKey In arSubKeys

 

intErrNum2 = oReg.GetStringValue(HKLM,strKey & "\" & strSubKey,"",strCLSID)

If intErrNum2 = 0 And strCLSID <> "" Then

 

flagTitle = False

 

For ctrCH = intCLL To 1

 

ResolveCLSID strCLSID, arHives(ctrCH,1), strCLSIDTitle, strIPSDLL

 

If strIPSDLL <> "" Then 'IPS exists?

 

flagAllow = False

 

For j = 0 To UBound(arAllowedDlls)

 

strCN = CoName(IDExe(strIPSDLL))

If LCase(Trim(Fso.GetFileName(strIPSDLL))) = LCase(arAllowedDlls(j)) And _

strCN = MS And ctrCH = 1 Then

flagAllow = True : Exit For

End If

 

Next 'arAllowedDlls element

 

If Not flagAllow Or flagShowAll Then

 

TitleLineWrite

 

If Not flagTitle Then

oFN.WriteLine strSubKey & "\(Default) = " & DQ & strCLSID & DQ

flagTitle = True

End If

 

oFN.WriteLine " -> {" & arHives(ctrCH,0) & "...CLSID} = " &_

strCLSIDTitle & vbCRLF & Space(19) & "\InProcServer32\(Default) = " &_

StringFilter(strIPSDLL,True) & CoName(IDExe(strIPSDLL))

 

End If 'Not flagAllow Or ShowAll?

 

End If 'strIPSDLL exists?

 

Next 'CLSID hive

 

End If 'CLSID exists?

 

Next 'sub-key

 

End If 'sub-keys exist?

 

Next 'class

 

'recover array memory

ReDim arClasses(0)

 

'reset strings

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

End If 'SecTest?

[MAcgYvER everyONE 0]

'#13. HKCU/HKLM executable file type (bat/cmd/com/exe/hta/pif/scr)

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

'this section does *not* output what executes -- it only outputs

'what's different from default

 

'set up executables/executable file type/expected value arrays, counter

Dim arExeExt, arExeFT, arExpVal, intLC

 

If strOS = "W98" Or strOS = "WME" Then

arExeExt = Array("bat","com","exe","hta","pif","scr")

arExeFT = Array("batfile","comfile","exefile","htafile","piffile","scrfile")

arExpVal = Array("""%1"" %*","""%1"" %*","""%1"" %*", _

LCase(Fso.GetSpecialFolder(1)) & "\mshta.exe ""%1"" %*", _

"""%1"" %*","""%1"" /s")

Else

arExeExt = Array("bat","cmd","com","exe","hta","pif","scr")

arExeFT = Array("batfile","cmdfile","comfile","exefile","htafile","piffile","scrfile")

arExpVal = Array("""%1"" %*","""%1"" %*","""%1"" %*","""%1"" %*", _

LCase(Fso.GetSpecialFolder(1)) & "\mshta.exe ""%1"" %*", _

"""%1"" %*","""%1"" /s")

End If

 

Dim arFileExtNames 'array of Explorer\FileExt names

Dim arFileExtClass 'array of Class loc'ns for Explorer\FileExt names

 

If strOS = "W2K" Or strOS = "WME" Then

arFileExtNames = Array ("Application")

arFileExtClass = Array ("Applications\")

ElseIf strOs = "WXP" Then

arFileExtNames = Array("ProgID", "Application")

arFileExtClass = Array ("", "Applications\")

End if

 

'alternate hive counter, file type, SOC expected value

Dim ctrCH2, strFileType, strSOCExpVal

 

strTitle = "Default executables:"

 

 

'FileExts loop

 

'WME/W2K/WXP only

If strOS = "WME" Or strOS = "W2K" Or strOS = "WXP" Then

 

'for each ext

For i = 0 To UBound(arExeExt)

 

strKey = "Software\Microsoft\Windows\CurrentVersion\Explorer\FileExts\." & arExeExt(i)

strSubTitle = "HKCU\" & strKey

 

'for Application/ProgID names (per O/S)

For j = 0 To UBound(arFileExtNames)

 

'look for FileExts App/ProgID value

intErrNum = oReg.GetStringValue (HKCU,strKey,arFileExtNames(j),strValue)

 

'output if FileExts App/ProgID value exists

If intErrNum = 0 And strValue <> "" Then

 

strSubTitle = IWarn & "HKCU\" & strKey & "\" & vbCRLF & DQ & arFileExtNames(j) &_

DQ & " = " & StringFilter(strValue,True)

TitleLineWrite

 

'look in both hives except for WMe, which does not use HKCU...Classes\Applications

intLC = intCLL : If strOS = "WME" Then intLC = 1

 

'look for App/ProgID value

For ctrCH2 = intLC to 1

 

strOut = ""

 

'look for App/ProgID value in Classes\Applications

SOCValue arFileExtClass(j) & strValue, ctrCH2, "", False

 

'output if found

If strOut <> "" Then

TitleLineWrite : oFN.WriteLine vbCRLF & strOut

End If

 

'if App/ProgID name is "Application" And value (may be) filename,

'add ".exe" to value and try to find it again

If strOut = "" And arFileExtNames(j) = "Application" Then

 

SOCValue arFileExtClass(j) & strValue & ".exe",ctrCH2,"",False

 

'output if found

If strOut <> "" Then

TitleLineWrite : oFN.WriteLine vbCRLF & strOut

End If

 

End If 'strOut empty & value (may be) filename?

 

Next 'hive

 

End If 'FileExts App/ProgID value found?

 

Next 'possible FileExt value (App/ProgID)

 

'if ShowAll, output FileExts key if not already done

If flagShowAll Then TitleLineWrite

 

Next 'ext

 

'clean up

strSubTitle = "" : strOut = ""

 

End If 'WMe/W2K/WXP?

 

 

'main Classes\.ext loop

 

'for each ext

For i = 0 To UBound(arExeExt)

 

'for each hive

For ctrCH = intCLL To 1

 

'reset variables

strSubTitle = "" : strOut = ""

 

'construct ext key

strKey = "Software\Classes\." & arExeExt(i)

 

'look for ext key default value (file type)

intErrNum = oReg.GetStringValue (arHives(ctrCH,1),strKey,"",strValue)

 

'if ext key file type exists

If intErrNum = 0 And strValue <> "" Then

 

'form subtitle .ext=filetype

strSubTitle = SOCA(arHives(ctrCH,0) & "\" & strKey &_

"\(Default) = " & StringFilter(strValue,True))

 

'output subtitle with warning if in HKCU or value unexpected

If ctrCH = 0 Or strValue <> arExeFT(i) Then

strSubTitle = IWarn & strSubTitle : TitleLineWrite

 

End If

 

'save file type for this hive

strFileType = strValue

 

'search for filetype in each hive

For ctrCH2 = intCLL To 1

 

'prepare expected SOC value for HKLM

strSOCExpVal = ""

If ctrCH2 = 1 Then strSOCExpVal = arExpVal(i)

 

'find file type SOC value in each hive

SOCValue strFileType,ctrCH2,strSOCExpVal,False

 

Next 'hive

 

'look for SOC value/key at ext

SOCValue "." & arExeExt(i), ctrCH, "", False

 

'ext key default value (file type) not set

Else

 

'look for ext key

intErrNum = oReg.EnumValues (arHives(ctrCH,1),strKey,arNames,arType)

 

'if ext key exists

If intErrNum = 0 Then

 

'output ext key

strSubTitle = StrOutSep(strOut,SOCA(arHives(ctrCH,0) & "\" & strKey) &_

"\(Default) = (value not set)",vbCRLF)

 

'look for ext key SOC value/key

SOCValue "." & arExeExt(i), ctrCH, "", False

 

Else 'ext key doesn't exist

 

If ctrCH = 1 Then strSubTitle = StrOutSep(strOut,SOCA(arHives(ctrCH,0) &_

"\" & strKey) & "\ = (key not found)",vbCRLF)

 

End If 'ext key?

 

End If 'ext key file type exists?

 

'write output

If strOut <> "" Or flagShowAll Then

TitleLineWrite

If strOut <> "" Then oFN.WriteLine strOut

End If

 

Next 'Class hive

 

Next 'ext

 

strTitle = "" : strSubTitle = "" : strOut = ""

 

'recover array memory

ReDim arExeExt(0) : ReDim arExtFT(0) : ReDim arExpVal(0)

 

If strOS = "WME" Or strOS = "W2K" Or strOS = "WXP" Then

ReDim arFileExtNames(0) : ReDim arFileExtClass(0)

End If

 

End If 'SecTest?

 

 

 

 

'#14. System/Group Policies

 

' Checked Keys:

'

' HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\ActiveDesktop

' HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\Assocations

' HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\Attachments

' HKCU/HKLM\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer

' HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\DisallowCpl

' HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\System

' HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\WindowsUpdate

' HKCU/HKLM\Software\Policies\Microsoft\Internet Explorer\Control Panel

' HKCU/HKLM\Software\Policies\Microsoft\Internet Explorer\Download

' HKCU/HKLM\Software\Policies\Microsoft\Internet Explorer\Infodelivery\Restrictions

' HKCU/HKLM\Software\Policies\Microsoft\Internet Explorer\Main

' HKCU/HKLM\Software\Policies\Microsoft\Internet Explorer\Main\FeatureControl\FEATURE_WINDOW_RESTRICTIONS

' HKCU/HKLM\Software\Policies\Microsoft\Internet Explorer\PhishingFilter

' HKCU/HKLM\Software\Policies\Microsoft\Internet Explorer\Restrictions

' HKCU/HKLM\Software\Policies\Microsoft\Internet Explorer\Security

' HKCU\Software\Policies\Microsoft\MMC\{8FC0B734-A0E1-11D1-A7D3-0000F87571E3}

' HKCU/HKLM\Software\Policies\Microsoft\Windows\CurrentVersion\Internet Settings\Lockdown_Zones\2

' HKCU/HKLM\Software\Policies\Microsoft\Windows\CurrentVersion\Internet Settings\Lockdown_Zones\3

' HKCU/HKLM\Software\Policies\Microsoft\Windows\CurrentVersion\Internet Settings\Lockdown_Zones\4

' HKCU/HKLM\Software\Policies\Microsoft\Windows\CurrentVersion\Internet Settings\Zones\2

' HKCU/HKLM\Software\Policies\Microsoft\Windows\CurrentVersion\Internet Settings\Zones\3

' HKCU/HKLM\Software\Policies\Microsoft\Windows\CurrentVersion\Internet Settings\Zones\4

' HKCU\Software\Policies\Microsoft\Windows\Network Connections

' HKCU\Software\Policies\Microsoft\Windows\System

' HKCU\Software\Policies\Microsoft\Windows\Task Scheduler5.0

' HKLM\Software\Microsoft\Windows\CurrentVersion\Policies\System

' HKLM\Software\Policies\Microsoft\Windows NT\SystemRestore

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

Const ATPL = "Administrative Templates|"

Const WSSSLP = "Windows Settings|Security Settings|Local Policies|"

Const WC = "Windows Components|"

Const IEX = "Internet Explorer|"

Const MMC = "Microsoft Management Console|"

Const WEX = "Windows Explorer|"

Const SMTB = "Start Menu and Taskbar|"

Const DT = "Desktop|"

Const DAD = "Desktop / Active Desktop|"

Const CP = "Control Panel|"

Const NWK = "Network|"

Const SYS = "System|"

 

'assign System or Group Policy name

Dim strPolName : strPolName = "System "

If strOS = "W2K" Or strOS = "WXP" Or strOS = "WVA" Then strPolName = "Group "

 

Dim arDisCplNames, strDisCplName, strDisCplValue

 

 

'set title line

strTitle = strPolName & "Policies {policy setting}:"

'add GPEdit location to title if GP used (W2K, WXP Pro, WVa)

If flagGP Then strTitle = "Group Policies {GPedit.msc branch and setting}:"

strSubTitle = "Note: detected settings may not have any effect."

 

 

strKey = "Software\Microsoft\Windows\CurrentVersion\Policies\ActiveDesktop"

 

ReDim arRecNames(3,2)

 

arRecNames(0,0) = "NoChangingWallPaper" : arRecNames(0,1) = ATPL & CP & "Display|"

arRecNames(0,2) = "Disable changing wallpaper}"

If strOS = "WXP" Or strOS = "WVA" Then arRecNames(0,2) = "Prevent changing wallpaper}"

 

arRecNames(1,0) = "NoClosingComponents" : arRecNames(1,1) = ATPL & DT & DAD

arRecNames(1,2) = "Prohibit closing items}"

 

arRecNames(2,0) = "NoDeletingComponents" : arRecNames(2,1) = ATPL & DT & DAD

arRecNames(2,2) = "Prohibit deleting items}"

 

arRecNames(3,0) = "NoEditingComponents" : arRecNames(3,1) = ATPL & DT & DAD

arRecNames(3,2) = "Prohibit editing items}"

 

GPRecognizer HKCU, strKey : ReDimGPOArrays

 

 

strKey = "Software\Microsoft\Windows\CurrentVersion\Policies\Associations"

 

ReDim arRecNames(0,2)

 

arRecNames(0,0) = "DefaultFileTypeRisk"

arRecNames(0,1) = ATPL & WC & "Attachment Manager|"

arRecNames(0,2) = "Default risk level for file attachments}"

 

GPRecognizer HKCU, strKey : ReDimGPOArrays

 

 

strKey = "Software\Microsoft\Windows\CurrentVersion\Policies\Attachments"

 

ReDim arRecNames(0,2)

 

arRecNames(0,0) = "ScanWithAntiVirus"

arRecNames(0,1) = ATPL & WC & "Attachment Manager|"

arRecNames(0,2) = "Notify antivirus programs when opening attachments}"

 

GPRecognizer HKCU, strKey : ReDimGPOArrays

 

 

strKey = "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer"

 

ReDim arRecNames(27,2)

 

arRecNames(0,0) = "ClassicShell" : arRecNames(0,1) = ATPL & WC & WEX

arRecNames(0,2) = "Enable Classic Shell / Turn on Classic Shell}"

 

arRecNames(1,0) = "ForceActiveDesktopOn"

arRecNames(1,1) = ATPL & DT & DAD : arRecNames(1,2) = "Enable Active Desktop}"

If strOS = "W98" Or strOS = "NT4" Then

arRecNames(1,1) = "" : arRecNames(1,2) = "unrecognized setting}"

End If

 

arRecNames(2,0) = "NoActiveDesktop" : arRecNames(2,1) = ATPL & DT & DAD

arRecNames(2,2) = "Disable Active Desktop}"

 

arRecNames(3,0) = "NoActiveDesktopChanges" : arRecNames(3,1) = ATPL & DT & DAD

arRecNames(3,2) = "Prohibit changes}"

 

'added by GP, but ignored in practice, presence of DisallowCpl subkey name/value pairs

'sufficient to hide applets, even if this DWORD = 0 or absent

arRecNames(4,0) = "DisallowCpl" : arRecNames(4,1) = ATPL & CP

arRecNames(4,2) = "Hide specified control panel applets / items}"

 

arRecNames(5,0) = "NoToolbarCustomize" : arRecNames(5,1) = ATPL & WC & IEX & "Toolbars|"

arRecNames(5,2) = "Disable customizing browser toolbar buttons}"

 

arRecNames(6,0) = "NoBandCustomize" : arRecNames(6,1) = ATPL & WC & IEX & "Toolbars|"

arRecNames(6,2) = "Disable customizing browser toolbars}"

 

arRecNames(7,0) = "NoFolderOptions" : arRecNames(7,1) = ATPL & WC & WEX

arRecNames(7,2) = "Removes the Folder Options menu item from the Tools menu}"

 

arRecNames(8,0) = "NoWindowsUpdate" : arRecNames(8,1) = ATPL & SMTB

arRecNames(8,2) = "Remove links and access to Windows Update}"

 

arRecNames(9,0) = "NoTrayItemsDisplay" : arRecNames(9,1) = ATPL & SMTB

arRecNames(9,2) = "Hide the notification area}"

 

arRecNames(10,0) = "NoSetTaskbar" : arRecNames(10,1) = ATPL & SMTB

arRecNames(10,2) = "Prevent changes to Taskbar and Start Menu Settings}"

 

arRecNames(11,0) = "TaskbarLockAll" : arRecNames(11,1) = ATPL & SMTB

arRecNames(11,2) = "Lock all taskbar settings}"

 

arRecNames(12,0) = "TaskbarNoAddRemoveToolbar" : arRecNames(12,1) = ATPL & SMTB

arRecNames(12,2) = "Prevent users from adding or removing toolbars}"

 

arRecNames(13,0) = "TaskbarNoDragToolbar" : arRecNames(13,1) = ATPL & SMTB

arRecNames(13,2) = "Prevent users from rearranging toolbars}"

 

arRecNames(14,0) = "NoStartMenuMorePrograms" : arRecNames(14,1) = ATPL & SMTB

arRecNames(14,2) = "Remove All Programs list from the Start menu}"

 

arRecNames(15,0) = "NoSMHelp" : arRecNames(15,1) = ATPL & SMTB

arRecNames(15,2) = "Remove Help menu from Start Menu}"

 

arRecNames(16,0) = "NoAutoUpdate" : arRecNames(16,1) = ATPL & SYS

arRecNames(16,2) = "Windows Automatic Updates}"

 

arRecNames(17,0) = "NoSecurityTab" : arRecNames(17,1) = ATPL & WC & WEX

arRecNames(17,2) = "Remove Security tab}"

 

arRecNames(18,0) = "NoSaveSettings" : arRecNames(18,1) = ATPL & DT

arRecNames(18,2) = "Don't save settings at exit}"

 

arRecNames(19,0) = "NoStartBanner" : arRecNames(19,1) = ""

arRecNames(19,2) = "Remove " & DQ & "Click here to begin" & DQ & " from Start button}"

 

arRecNames(20,0) = "NoFavoritesMenu" : arRecNames(20,1) = ATPL & SMTB

arRecNames(20,2) = "Remove Favorites menu from Start Menu}"

 

arRecNames(21,0) = "NoWinKeys" : arRecNames(21,1) = ""

arRecNames(21,2) = "Disable Windows+X hotkeys}"

 

arRecNames(22,0) = "NoSMMyDocs" : arRecNames(22,1) = ATPL & SMTB

arRecNames(22,2) = "Remove Documents menu from Start Menu}"

 

arRecNames(23,0) = "NoSMMyPictures" : arRecNames(23,1) = ATPL & SMTB

arRecNames(23,2) = "Remove My Pictures icon from Start Menu}"

 

arRecNames(24,0) = "NoNetworkConnections" : arRecNames(24,1) = ATPL & SMTB

arRecNames(24,2) = "Remove Network & Dial-up Connections from Start Menu}"

If strOS = "WXP" Then arRecNames(24,2) = "Remove Network Connections from Start Menu}"

 

arRecNames(25,0) = "NoSharedDocuments" : arRecNames(25,1) = ATPL & WC & WEX

arRecNames(25,2) = "Remove Shared Documents from My Computer}"

 

arRecNames(26,0) = "NoLogoff" : arRecNames(26,1) = ATPL & SYS & "Logon/Logoff|"

arRecNames(26,2) = "Disable Logoff}"

 

arRecNames(27,0) = "NoInternetIcon" : arRecNames(27,1) = ATPL & DT

arRecNames(27,2) = "Hide Internet Explorer icon on desktop}"

 

ReDim arAllowedNames(2,3)

 

arAllowedNames(0,0) = "NoDriveTypeAutoRun" : arAllowedNames(0,1) = ATPL & WC & "AutoPlay Policies|"

arAllowedNames(0,2) = "Turn off Autoplay}"

arAllowedNames(0,3) = "***"

 

arAllowedNames(1,0) = "NoDriveAutoRun" : arAllowedNames(1,1) = ""

arAllowedNames(1,2) = "Turn off autoplay for drive letter}"

arAllowedNames(1,3) = "***"

 

arAllowedNames(2,0) = "MaxRecentDocs" : arAllowedNames(2,1) = ATPL & WC & WEX

arAllowedNames(2,2) = "Maximum number of recent documents}"

arAllowedNames(2,3) = "***"

 

GPRecognizer HKCU, strKey : ReDimGPOArrays

 

 

ReDim arAllowedNames(1,3)

 

arAllowedNames(0,0) = "NoDriveTypeAutoRun" : arAllowedNames(0,1) = ATPL & WC & "AutoPlay Policies|"

arAllowedNames(0,2) = "Turn off Autoplay}"

arAllowedNames(0,3) = "***"

 

arAllowedNames(1,0) = "NoDriveAutoRun" : arAllowedNames(1,1) = ""

arAllowedNames(1,2) = "Turn off autoplay for drive letter}"

arAllowedNames(1,3) = "***"

 

GPRecognizer HKLM, strKey : ReDimGPOArrays

 

'omitted Control Panel applets

strKey = "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\DisallowCpl"

 

GPRecognizer HKCU, strKey : ReDimGPOArrays

 

 

strKey = "Software\Microsoft\Windows\CurrentVersion\Policies\System"

 

ReDim arRecNames(5,2)

 

arRecNames(0,0) = "DisableRegistryTools" : arRecNames(0,1) = ATPL & SYS

arRecNames(0,2) = "Disable registry editing tools}"

If strOS = "WXP" Or strOS = "WVA" Then arRecNames(0,2) = "Prevent access to " &_

"registry editing tools}"

 

arRecNames(1,0) = "NoDispBackgroundPage" : arRecNames(1,1) = ATPL & CP & "Display|"

arRecNames(1,2) = "Hide Background tab}"

If strOS = "WXP" Or strOS = "WVA" Then arRecNames(1,2) = "Hide Desktop tab}"

 

arRecNames(2,0) = "NoDispCpl"

arRecNames(2,1) = ATPL & CP & "Display|"

arRecNames(2,2) = "Disable Display in Control Panel}"

If strOS = "WXP" Or strOS = "WVA" Then arRecNames(2,2) = "Remove Display in Control Panel}"

 

arRecNames(3,0) = "Wallpaper" : arRecNames(3,1) = ATPL & DT & DAD

arRecNames(3,2) = "Active Desktop Wallpaper|Wallpaper Name:}"

If strOS = "WVA" Then arRecNames(3,2) = "Desktop Wallpaper|Wallpaper Name:}"

 

arRecNames(4,0) = "WallpaperStyle" : arRecNames(4,1) = ATPL & DT & DAD

arRecNames(4,2) = "Active Desktop Wallpaper|Wallpaper Style:}"

If strOS = "WVA" Then arRecNames(4,2) = "Desktop Wallpaper|Wallpaper Style:}"

 

arRecNames(5,0) = "DisableTaskMgr"

arRecNames(5,1) = ATPL & SYS & "Ctrl+Alt+Del Options|"

If strOS = "W2K" Then arRecNames(5,1) = ATPL & SYS & "Logon/Logoff|"

arRecNames(5,2) = "Remove Task Manager}"

 

GPRecognizer HKCU, strKey : ReDimGPOArrays

 

 

strKey = "Software\Microsoft\Windows\CurrentVersion\Policies\WindowsUpdate"

 

ReDim arRecNames(0,2)

 

arRecNames(0,0) = "DisableWindowsUpdateAccess"

arRecNames(0,1) = ATPL & WC & "Windows Update|"

arRecNames(0,2) = "Remove access to use all Windows Update features}"

 

GPRecognizer HKCU, strKey : ReDimGPOArrays

 

 

strKey = "Software\Policies\Microsoft\Internet Explorer\Control Panel"

 

ReDim arRecNames(13,2)

 

arRecNames(1,0) = "Advanced" : arRecNames(1,1) = ATPL & WC & IEX

arRecNames(1,2) = "Disable changing Advanced page settings}"

 

arRecNames(2,0) = "AdvancedTab" 'HKLM

arRecNames(2,1) = ATPL & WC & IEX & "Internet Control Panel|"

arRecNames(2,2) = "Disable the Advanced page}"

 

arRecNames(3,0) = "Connection Settings" 'HKLM

arRecNames(3,1) = ATPL & WC & IEX

arRecNames(3,2) = "Disable changing connection settings}"

 

arRecNames(4,0) = "ConnectionsTab" 'HKLM

arRecNames(4,1) = ATPL & WC & IEX & "Internet Control Panel|"

arRecNames(4,2) = "Disable the Connections page}"

 

arRecNames(5,0) = "ContentTab" 'HKLM

arRecNames(5,1) = ATPL & WC & IEX & "Internet Control Panel|"

arRecNames(5,2) = "Disable the Content page}"

 

arRecNames(6,0) = "DisableRIED" 'HKLM

arRecNames(6,1) = ATPL & WC & IEX & "Internet Control Panel|Advanced Page|"

arRecNames(6,2) = "Do not allow resetting Internet Explorer settings}"

 

arRecNames(7,0) = "GeneralTab" 'HKLM

arRecNames(7,1) = ATPL & WC & IEX & "Internet Control Panel|"

arRecNames(7,2) = "Disable the General page}"

 

arRecNames(8,0) = "HomePage" : arRecNames(8,1) = ATPL & WC & IEX

arRecNames(8,2) = "Disable changing home page settings}"

 

arRecNames(9,0) = "PrivacyTab" 'HKLM

arRecNames(9,1) = ATPL & WC & IEX & "Internet Control Panel|"

arRecNames(9,2) = "Disable the Privacy page}"

 

arRecNames(10,0) = "Proxy" 'HKLM

arRecNames(10,1) = ATPL & WC & IEX

arRecNames(10,2) = "Disable changing proxy settings}"

 

arRecNames(11,0) = "ResetWebSettings" : arRecNames(11,1) = ATPL & WC & IEX

arRecNames(11,2) = "Disable the Reset Web Settings feature}"

 

arRecNames(12,0) = "SecurityTab" 'HKLM

arRecNames(12,1) = ATPL & WC & IEX & "Internet Control Panel|"

arRecNames(12,2) = "Disable the Security page}"

 

arRecNames(13,0) = "Settings" : arRecNames(13,1) = ATPL & WC & IEX

arRecNames(13,2) = "Prevent the deletion of temporary Internet files and cookies}"

 

GPRecognizer HKCU, strKey : GPRecognizer HKLM, strKey : ReDimGPOArrays

 

 

strKey = "Software\Policies\Microsoft\Internet Explorer\Download"

 

ReDim arRecNames(1,2)

 

arRecNames(0,0) = "RunInvalidSignatures" 'HKLM

arRecNames(0,1) = ATPL & WC & IEX & "Internet Control Panel|Advanced Page|"

arRecNames(0,2) = "Allow software to run or install even if the signature is invalid}"

 

arRecNames(1,0) = "CheckExeSignatures" 'HKLM

arRecNames(1,1) = ATPL & WC & IEX & "Internet Control Panel|Advanced Page|"

arRecNames(1,2) = "Check for signatures on downloaded programs}"

 

GPRecognizer HKCU, strKey : GPRecognizer HKLM, strKey : ReDimGPOArrays

 

 

strKey = "Software\Policies\Microsoft\Internet Explorer\Infodelivery\Restrictions"

 

ReDim arRecNames(1,2)

 

arRecNames(0,0) = "NoChangeDefaultSearchProvider" 'HKLM

arRecNames(0,1) = ATPL & WC & IEX

arRecNames(0,2) = "Restrict changing the default search provider}"

 

arRecNames(1,0) = "NoSearchCustomization"

arRecNames(1,1) = ATPL & WC & IEX

arRecNames(1,2) = "Search: Disable Search Customization}"

 

GPRecognizer HKCU, strKey : GPRecognizer HKLM, strKey : ReDimGPOArrays

 

 

strKey = "Software\Policies\Microsoft\Internet Explorer\Main"

 

ReDim arRecNames(1,2)

 

arRecNames(0,0) = "Enable Browser Extensions" 'HKLM

arRecNames(0,1) = ATPL & WC & IEX & "Internet Control Panel|Advanced Page|"

arRecNames(0,2) = "Allow third-party browser extensions}"

 

arRecNames(1,0) = "Start Page"

arRecNames(1,1) = ATPL & WC & IEX

arRecNames(1,2) = "Disable changing home page settings -- Home Page imposed by this setting}"

 

GPRecognizer HKCU, strKey : GPRecognizer HKLM, strKey : ReDimGPOArrays

 

 

strKey = "Software\Policies\Microsoft\Internet Explorer\Main\FeatureControl\FEATURE_WINDOW_RESTRICTIONS"

 

ReDim arRecNames(0,2)

 

arRecNames(0,0) = "*" 'HKLM

arRecNames(0,1) = ATPL & WC & IEX & "Security Features|Scripted Window Security Restrictions|"

arRecNames(0,2) = "Internet Explorer Processes}"

 

GPRecognizer HKCU, strKey : GPRecognizer HKLM, strKey : ReDimGPOArrays

 

 

strKey = "Software\Policies\Microsoft\Internet Explorer\PhishingFilter"

 

ReDim arRecNames(0,2)

 

arRecNames(0,0) = "Enabled" 'HKLM

arRecNames(0,1) = ATPL & WC & IEX

arRecNames(0,2) = "Turn off Managing Phishing filter}"

 

GPRecognizer HKCU, strKey : GPRecognizer HKLM, strKey : ReDimGPOArrays

 

 

strKey = "Software\Policies\Microsoft\Internet Explorer\Restrictions"

 

ReDim arRecNames(2,2)

 

arRecNames(0,0) = "NoExtensionManagement" 'HKLM

arRecNames(0,1) = ATPL & WC & IEX

arRecNames(0,2) = "Do not allow users to enable or disable add-ons}"

 

arRecNames(1,0) = "NoPopupManagement" 'HKLM

arRecNames(1,1) = ATPL & WC & IEX

arRecNames(1,2) = "Turn off pop-up management}"

 

arRecNames(2,0) = "NoBrowserOptions"

arRecNames(2,1) = ATPL & WC & IEX & "Browser Menus|"

arRecNames(2,2) = "Tools menu: Disable Internet Options... menu option}"

 

GPRecognizer HKCU, strKey : GPRecognizer HKLM, strKey : ReDimGPOArrays

 

 

strKey = "Software\Policies\Microsoft\Internet Explorer\Security"

 

ReDim arRecNames(1,2)

 

arRecNames(0,0) = "DisableFixSecuritySettings" 'HKLM

arRecNames(0,1) = ATPL & WC & IEX

arRecNames(0,2) = "Do not allow users to enable or disable add-ons}"

 

arRecNames(1,0) = "DisableSecuritySettingsCheck" 'HKLM

arRecNames(1,1) = ATPL & WC & IEX

arRecNames(1,2) = "Turn off the Security Settings Check feature}"

 

GPRecognizer HKCU, strKey : GPRecognizer HKLM, strKey : ReDimGPOArrays

 

 

strKey = "Software\Policies\Microsoft\MMC\{8FC0B734-A0E1-11D1-A7D3-0000F87571E3}"

 

ReDim arRecNames(0,2)

 

arRecNames(0,0) = "Restrict_Run"

arRecNames(0,1) = ATPL & WC & MMC & "Restricted/Permitted snap-ins|Group Policy|"

arRecNames(0,2) = "Group Policy Object Editor}"

 

GPRecognizer HKCU, strKey : ReDimGPOArrays

 

 

strKey = "Software\Policies\Microsoft\Windows\CurrentVersion\Internet Settings\Lockdown_Zones\2"

 

ReDim arRecNames(1,2)

 

arRecNames(0,0) = "1004" 'HKLM

arRecNames(0,1) = ATPL & WC & IEX & "Internet Control Panel|Security Page|Locked-Down Trusted Sites Zone|"

arRecNames(0,2) = "Download unsigned ActiveX controls}"

 

arRecNames(1,0) = "1201" 'HKLM

arRecNames(1,1) = ATPL & WC & IEX & "Internet Control Panel|Security Page|Locked-Down Trusted Sites Zone|"

arRecNames(1,2) = "Initialize and script ActiveX controls not marked as safe}"

 

GPRecognizer HKCU, strKey : GPRecognizer HKLM, strKey : ReDimGPOArrays

 

 

strKey = "Software\Policies\Microsoft\Windows\CurrentVersion\Internet Settings\Lockdown_Zones\3"

 

ReDim arRecNames(1,2)

 

arRecNames(0,0) = "1004" 'HKLM

arRecNames(0,1) = ATPL & WC & IEX & "Internet Control Panel|Security Page|Locked-Down Internet Zone|"

arRecNames(0,2) = "Download unsigned ActiveX controls}"

 

arRecNames(1,0) = "1201" 'HKLM

arRecNames(1,1) = ATPL & WC & IEX & "Internet Control Panel|Security Page|Locked-Down Internet Zone|"

arRecNames(1,2) = "Initialize and script ActiveX controls not marked as safe}"

 

GPRecognizer HKCU, strKey : GPRecognizer HKLM, strKey : ReDimGPOArrays

 

 

strKey = "Software\Policies\Microsoft\Windows\CurrentVersion\Internet Settings\Lockdown_Zones\4"

 

ReDim arRecNames(1,2)

 

arRecNames(0,0) = "1004" 'HKLM

arRecNames(0,1) = ATPL & WC & IEX & "Internet Control Panel|Security Page|Locked-Down Restricted Sites Zone|"

arRecNames(0,2) = "Download unsigned ActiveX controls}"

 

arRecNames(1,0) = "1201" 'HKLM

arRecNames(1,1) = ATPL & WC & IEX & "Internet Control Panel|Security Page|Locked-Down Restricted Sites Zone|"

arRecNames(1,2) = "Initialize and script ActiveX controls not marked as safe}"

 

GPRecognizer HKCU, strKey : GPRecognizer HKLM, strKey : ReDimGPOArrays

 

 

strKey = "Software\Policies\Microsoft\Windows\CurrentVersion\Internet Settings\Zones\2"

 

ReDim arRecNames(1,2)

 

arRecNames(0,0) = "1004" 'HKLM

arRecNames(0,1) = ATPL & WC & IEX & "Internet Control Panel|Security Page|Trusted Sites Zone|"

arRecNames(0,2) = "Download unsigned ActiveX controls}"

 

arRecNames(1,0) = "1201" 'HKLM

arRecNames(1,1) = ATPL & WC & IEX & "Internet Control Panel|Security Page|Trusted Sites Zone|"

arRecNames(1,2) = "Initialize and script ActiveX controls not marked as safe}"

 

GPRecognizer HKCU, strKey : GPRecognizer HKLM, strKey : ReDimGPOArrays

 

 

strKey = "Software\Policies\Microsoft\Windows\CurrentVersion\Internet Settings\Zones\3"

 

ReDim arRecNames(1,2)

 

arRecNames(0,0) = "1004" 'HKLM

arRecNames(0,1) = ATPL & WC & IEX & "Internet Control Panel|Security Page|Internet Zone|"

arRecNames(0,2) = "Download unsigned ActiveX controls}"

 

arRecNames(1,0) = "1201" 'HKLM

arRecNames(1,1) = ATPL & WC & IEX & "Internet Control Panel|Security Page|Internet Zone|"

arRecNames(1,2) = "Initialize and script ActiveX controls not marked as safe}"

 

GPRecognizer HKCU, strKey : GPRecognizer HKLM, strKey : ReDimGPOArrays

 

 

strKey = "Software\Policies\Microsoft\Windows\CurrentVersion\Internet Settings\Zones\4"

 

ReDim arRecNames(1,2)

 

arRecNames(0,0) = "1004" 'HKLM

arRecNames(0,1) = ATPL & WC & IEX & "Internet Control Panel|Security Page|Restricted Sites Zone|"

arRecNames(0,2) = "Download unsigned ActiveX controls}"

 

arRecNames(1,0) = "1201" 'HKLM

arRecNames(1,1) = ATPL & WC & IEX & "Internet Control Panel|Security Page|Restricted Sites Zone|"

arRecNames(1,2) = "Initialize and script ActiveX controls not marked as safe}"

 

GPRecognizer HKCU, strKey : GPRecognizer HKLM, strKey : ReDimGPOArrays

 

 

strKey = "Software\Policies\Microsoft\Windows\Network Connections"

 

ReDim arRecNames(5,2)

 

arRecNames(0,0) = "NC_LanProperties"

arRecNames(0,1) = ATPL & NWK & "Network and Dial-up Connections|"

If strOS = "WVA" Then arRecNames(0,1) = ATPL & NWK & "Network Connections|"

arRecNames(0,2) = "Prohibit access to properties of a LAN connection}"

 

arRecNames(1,0) = "NC_LanChangeProperties"

arRecNames(1,1) = ATPL & NWK & "Network and Dial-up Connections|"

If strOS = "WVA" Then arRecNames(1,1) = ATPL & NWK & "Network Connections|"

arRecNames(1,2) = "Prohibit access to properties of components of a LAN connection}"

 

arRecNames(2,0) = "NC_RasChangeProperties"

arRecNames(2,1) = ATPL & NWK & "Network and Dial-up Connections|"

If strOS = "WVA" Then arRecNames(2,1) = ATPL & NWK & "Network Connections|"

arRecNames(2,2) = "Prohibit access to properties of components of a remote access connection}"

 

arRecNames(3,0) = "NC_AddRemoveComponents"

arRecNames(3,1) = ATPL & NWK & "Network and Dial-up Connections|"

If strOS = "WVA" Then arRecNames(3,1) = ATPL & NWK & "Network Connections|"

arRecNames(3,2) = "Prohibit adding and removing components for a LAN or remote access connection}"

 

arRecNames(4,0) = "NC_DeleteConnection"

arRecNames(4,1) = ATPL & NWK & "Network and Dial-up Connections|"

If strOS = "WVA" Then arRecNames(4,1) = ATPL & NWK & "Network Connections|"

arRecNames(4,2) = "Prohibit deletion of remote access connections}"

 

arRecNames(5,0) = "NC_Statistics"

arRecNames(5,1) = ATPL & NWK & "Network and Dial-up Connections|"

If strOS = "WVA" Then arRecNames(5,1) = ATPL & NWK & "Network Connections|"

arRecNames(5,2) = "Prohibit viewing of status for an active connection}"

 

GPRecognizer HKCU, strKey : ReDimGPOArrays

 

 

strKey = "Software\Policies\Microsoft\Windows\System"

 

ReDim arRecNames(0,2)

 

arRecNames(0,0) = "DisableCMD"

arRecNames(0,1) = ATPL & SYS

arRecNames(0,2) = "Disable the command prompt}"

If strOS = "WVA" Then arRecNames(0,2) = "Prevent access to the command prompt}"

 

GPRecognizer HKCU, strKey : ReDimGPOArrays

 

 

strKey = "Software\Policies\Microsoft\Windows\Task Scheduler5.0"

 

ReDim arRecNames(0,2)

 

arRecNames(0,0) = "Task Deletion" 'HKLM

arRecNames(0,1) = ATPL & WC & "Task Scheduler|"

arRecNames(0,2) = "Prohibit Task deletion}"

 

GPRecognizer HKCU, strKey : GPRecognizer HKLM, strKey : ReDimGPOArrays

 

 

strKey = "Software\Microsoft\Windows\CurrentVersion\Policies\System"

 

ReDim arAllowedNames(15,3)

 

arAllowedNames(0,0) = "ConsentPromptBehaviorAdmin" : arAllowedNames(0,1) = WSSSLP & "Security Options|"

arAllowedNames(0,2) = "User Account Control: Behavior Of The Elevation " &_

"Prompt For Administrators In Admin Approval Mode}" : arAllowedNames(0,3) = "2"

 

arAllowedNames(1,0) = "ConsentPromptBehaviorUser" : arAllowedNames(1,1) = WSSSLP & "Security Options|"

arAllowedNames(1,2) = "User Account Control: Behavior Of The Elevation " &_

"Prompt For Standard Users}" : arAllowedNames(1,3) = "1"

 

arAllowedNames(2,0) = "dontdisplaylastusername" : arAllowedNames(2,1) = WSSSLP & "Security Options|"

arAllowedNames(2,2) = "Interactive logon: Do not display last user name}" : arAllowedNames(2,3) = "***"

 

arAllowedNames(3,0) = "EnableInstallerDetection" : arAllowedNames(3,1) = WSSSLP & "Security Options|"

arAllowedNames(3,2) = "User Account Control: Detect Application " &_

"Installations And Prompt For Elevation}" : arAllowedNames(3,3) = "1"

 

arAllowedNames(4,0) = "EnableLUA" : arAllowedNames(4,1) = WSSSLP & "Security Options|"

arAllowedNames(4,2) = "User Account Control: Run All Administrators " &_

"In Admin Approval Mode}" : arAllowedNames(4,3) = "1"

 

arAllowedNames(5,0) = "EnableSecureUIAPaths" : arAllowedNames(5,1) = WSSSLP & "Security Options|"

arAllowedNames(5,2) = "User Account Control: Only elevate UIAccess " &_

"applications that are installed in secure locations}" : arAllowedNames(5,3) = "1"

 

arAllowedNames(6,0) = "EnableVirtualization" : arAllowedNames(6,1) = WSSSLP & "Security Options|"

arAllowedNames(6,2) = "User Account Control: Virtualize file and registry " &_

"write failures to per-user locations}" : arAllowedNames(6,3) = "1"

 

arAllowedNames(7,0) = "FilterAdministratorToken" : arAllowedNames(7,1) = WSSSLP & "Security Options|"

arAllowedNames(7,2) = "User Account Control: Admin Approval Mode for " &_

"the Built-in Administrator Account}" : arAllowedNames(7,3) = "1"

 

arAllowedNames(8,0) = "legalnoticecaption" : arAllowedNames(8,1) = WSSSLP & "Security Options|"

arAllowedNames(8,2) = "Interactive logon: Message title for users " &_

"attempting to log on}" : arAllowedNames(8,3) = "***"

 

arAllowedNames(9,0) = "legalnoticetext" : arAllowedNames(9,1) = WSSSLP & "Security Options|"

arAllowedNames(9,2) = "Interactive logon: Message text for users " &_

"attempting to log on}" : arAllowedNames(9,3) = "***"

 

arAllowedNames(10,0) = "PromptOnSecureDesktop" : arAllowedNames(10,1) = WSSSLP & "Security Options|"

arAllowedNames(10,2) = "User Account Control: Switch to the secure " & _

"desktop when prompting for elevation}" : arAllowedNames(10,3) = "1"

 

arAllowedNames(11,0) = "scforceoption" : arAllowedNames(11,1) = WSSSLP & "Security Options|"

arAllowedNames(11,2) = "Interactive logon: Require smart card}" : arAllowedNames(11,3) = "***"

 

arAllowedNames(12,0) = "shutdownwithoutlogon" : arAllowedNames(12,1) = WSSSLP & "Security Options|"

arAllowedNames(12,2) = "Shutdown: Allow system to be shut down without " &_

"having to log on}" : arAllowedNames(12,3) = "1"

 

arAllowedNames(13,0) = "undockwithoutlogon" : arAllowedNames(13,1) = WSSSLP & "Security Options|"

arAllowedNames(13,2) = "Devices: Allow undock without having to log on}" : arAllowedNames(13,3) = "1"

 

arAllowedNames(14,0) = "ValidateAdminCodeSignatures" : arAllowedNames(14,1) = WSSSLP & "Security Options|"

arAllowedNames(14,2) = "User Account Control: Only elevate executables " &_

"that are signed and validated}" : arAllowedNames(14,3) = "***"

 

GPRecognizer HKLM, strKey : ReDimGPOArrays

 

 

'has no effect in WMe

If strOS = "WXP" Or strOS = "WVA" Then

 

strKey = "Software\Policies\Microsoft\Windows NT\SystemRestore"

 

ReDim arRecNames(1,2)

 

arRecNames(0,0) = "DisableSR" : arRecNames(0,1) = ATPL & SYS & "System Restore|"

arRecNames(0,2) = "Turn off System Restore}"

 

arRecNames(1,0) = "DisableConfig" : arRecNames(1,1) = ATPL & SYS & "System Restore|"

arRecNames(1,2) = "Turn off Configuration}"

 

GPRecognizer HKLM, strKey : ReDimGPOArrays

 

End If 'WXP/WVa?

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

End If 'SecTest?

 

 

 

 

'#15. Enabled Wallpaper & Screen Saver

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

Dim arBValue()

 

'title line string

strTitle = "Active Desktop and Wallpaper:"

 

 

'Active Desktop

 

'Active Desktop flag key

strKey = "Software\Microsoft\Windows\CurrentVersion\Explorer"

 

'get the ShellState binary array

intErrNum = oReg.GetBinaryValue (HKCU,strKey,"ShellState",arBValue)

 

'if array returned

If intErrNum = 0 And IsArray(arBValue) Then

 

'if array contains Active Desktop flag

If UBound(arBValue) >= 4 Then

 

'if 0-based 4th array element contains 64 (AD flag set)

If (arBValue(4) And 64) = 64 Then

ReDim arBValue(0) 'recover array memory

TitleLineWrite

oFN.WriteLine vbCRLF & "Active Desktop may be enabled at this entry:" &_

vbCRLF & "HKCU\" & strKey & "\ShellState"

Else

TitleLineWrite

oFN.WriteLine vbCRLF & "Active Desktop may be disabled at this entry:" &_

vbCRLF & "HKCU\" & strKey & "\ShellState"

End If 'AD enabled?

 

End If 'UBound>=4?

 

Else 'binary value not found

 

If flagShowAll Then

TitleLineWrite : oFN.WriteLine vbCRLF & "Active Desktop is not enabled."

End If

 

End If 'binary value exists?

 

 

'Wallpaper

 

'check for AD wallpaper

strKey = "Software\Microsoft\Internet Explorer\Desktop\General"

strSubTitle = "Displayed if Active Desktop enabled and wallpaper not set by " &_

strPolName & "Policy:" & vbCRLF & "HKCU\" & strKey & "\"

 

intErrNum = oReg.GetStringValue (HKCU,strKey,"Wallpaper",strValue)

 

'if AD wallpaper value set

If intErrNum = 0 And strValue <> "" Then 'exc for W2K!

 

'write value

On Error Resume Next

TitleLineWrite

oFN.WriteLine DQ & "Wallpaper" & DQ & " = " &_

DQ & strValue & DQ

intErrNum1 = Err.Number : Err.Clear

On Error Goto 0

If intErrNum1 <> 0 Then oFN.WriteLine DQ & "Wallpaper" &_

DQ & " = (value not set)"

 

End If 'AD wallpaper value set?

 

 

'retrieve Wallpaper value

strKey = "Control Panel\Desktop"

strSubTitle = "Displayed if Active Desktop disabled and wallpaper not set by " &_

strPolName & "Policy:" & vbCRLF & "HKCU\" & strKey & "\"

 

intErrNum = oReg.GetStringValue (HKCU,strKey,"Wallpaper",strValue)

 

'if value set (exc for W2K!)

If intErrNum = 0 And strValue <> "" Then 'exc for W2K!

 

TitleLineWrite

'output wallpaper value

On Error Resume Next

oFN.WriteLine DQ & "Wallpaper" & DQ & " = " &_

DQ & strValue & DQ

intErrNum2 = Err.Number : Err.Clear

On Error Goto 0

If intErrNum2 <> 0 Then oFN.WriteLine DQ & "Wallpaper" &_

DQ & " = (value not set)"

 

Else 'WP value not present

 

If flagShowAll Then

TitleLineWrite

oFN.WriteLine DQ & "Wallpaper" & DQ & " = (value not set)"

End If

 

End If 'wallpaper value set?

 

 

'web content

 

'look for web content

strKey = "Software\Microsoft\Internet Explorer\Desktop\Components"

intErrNum = oReg.EnumKey(HKCU,strKey,arKeys)

 

'if sub-keys exist

If IsArray(arKeys) Then

 

strSubTitle = "Active Desktop web content (hidden if disabled):"

 

'for each subkey

For Each oKey in arKeys

 

strSubSubTitle = "HKCU\" & strKey & "\" & oKey & "\"

 

'retrieve DWORD containing web content activation flag

intErrNum1 = oReg.GetDWORDValue (HKCU,strKey & "\" & oKey,"Flags",intValue)

 

'if DWORD value set

If intErrNum = 0 And intValue <> 0 Then

 

'if DWORD contains 8192 (web content activation flag set)

If (intValue And 8192) = 8192 Then

 

'get web content descriptive values

oReg.GetStringValue HKCU,strKey & "\" & oKey,"FriendlyName",strValue1

oReg.GetStringValue HKCU,strKey & "\" & oKey,"Source",strValue2

oReg.GetStringValue HKCU,strKey & "\" & oKey,"SubscribedURL",strValue3

 

TitleLineWrite

 

'write web content descriptive values

On Error Resume Next

oFN.WriteLine DQ & "FriendlyName" & DQ & " = " &_

DQ & strValue1 & DQ

intErrNum2 = Err.Number : Err.Clear

If intErrNum2 <> 0 Then oFN.WriteLine DQ & "FriendlyName" &_

DQ & " = (value not set)"

 

oFN.WriteLine DQ & "Source" & DQ & " = " &_

DQ & strValue2 & DQ

intErrNum2 = Err.Number : Err.Clear

If intErrNum2 <> 0 Then oFN.WriteLine DQ & "Source" &_

DQ & " = (value not set)"

 

oFN.WriteLine DQ & "SubscribedURL" & DQ & " = " &_

DQ & strValue3 & DQ

intErrNum2 = Err.Number : Err.Clear

If intErrNum2 <> 0 Then oFN.WriteLine DQ & "SubscribedURL" &_

DQ & " = (value not set)"

On Error Goto 0

 

End If 'web content active?

 

End If 'web content DWORD value set?

 

Next 'web content subkey

 

End If 'web content subkeys exist

 

strSubTitle = "" : strSubSubTitle = ""

 

 

'Screen Saver

 

If strOS <> "W98" And strOS <> "WME" Then

 

Dim strLFN : strLFN = "" 'screen saver LFN

Dim strExt : strExt = "" 'wallpaper file extension

strWarn = ""

 

strTitle = "Enabled Screen Saver:"

 

strKey = "Control Panel\Desktop"

strSubTitle = "HKCU\" & strKey & "\"

 

'get the screen saver name

intErrNum = oReg.GetStringValue (HKCU,strKey,"Scrnsave.exe",strValue)

 

'if Scrnsave.exe value exists And value set (exc for W2K!)

' And value <> "(NONE)" (NT4 default)

If intErrNum = 0 And strValue <> "" And LCase(strValue) <> "(none)" Then

 

'get screen saver LFN if file exists

If Fso.FileExists(strValue) Then

 

'create (but don't save) shortcut

Dim oSC : Set oSC = Wshso.CreateShortcut("getLFN.lnk")

'set & retrieve target path

oSC.TargetPath = strValue

strLFN = Fso.GetFile(oSC.TargetPath).Name

Set oSC=Nothing

 

'set up LFN string if SFN <> LFN

If LCase(strLFN) = LCase(Fso.GetFileName(strValue)) Then

strLFN = ""

Else

strLFN = " (" & strLFN & ")"

End If

 

End If 'screen saver file exists?

 

TitleLineWrite

 

On Error Resume Next

oFN.WriteLine DQ & "SCRNSAVE.EXE" & DQ & " = " &_

DQ & strValue & DQ & strLFN & CoName(IDExe(strValue))

intErrNum = Err.Number : Err.Clear

On Error Goto 0

 

If intErrNum <> 0 Then oFN.WriteLine DQ & "SCRNSAVE.EXE" &_

DQ & " = (value not set)"

 

Else 'Scrnsave.exe value doesn't exist

 

'if ShowAll, output title line

If flagShowAll Then

 

TitleLineWrite

oFN.WriteLine DQ & "SCRNSAVE.EXE" & DQ & " = (value not set)"

 

End If 'flagShowAll

 

End If 'Scrnsave.exe value exists?

 

End If 'strOS <> W98/WME?

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

End If 'SecTest?

 

 

 

 

'#16. WIN.INI load/run, SYSTEM.INI shell/scrnsave.exe, WINSTART.BAT, IniFileMapping

' W98/WMe - check inside WIN.INI (load=, run=), SYSTEM.INI (shell=, scrnsave.exe=)

' W98 - list contents of non-empty WINSTART.BAT

' NT4+ - check for non-default IniFileMapping values

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

If strOS = "W98" Or strOS = "WME" Then

 

strTitle = "WIN.INI & SYSTEM.INI launch points:"

 

Dim oSCF 'System Configuration File

'true if in INI-file section containing targeted lines

Dim flagSection : flagSection = False

 

strSubTitle = "WIN.INI" & vbCRLF & "[windows]"

 

'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 not a blank/comment line And inside [windows] section

If Trim(strLine) <> "" And Left(LTrim(strLine),1) <> ";" Then

 

If flagSection Then

 

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

 

'input line, verb, expected contents, disk

IniInfParse strLine, "load", "", ""

IniInfParse strLine, "run", "", ""

 

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

 

End If 'blank/comment line?

 

Loop 'next line of WIN.INI

 

oSCF.Close 'close WIN.INI

flagSection = False

 

strSubTitle = "SYSTEM.INI" & vbCRLF & "[boot]"

 

'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 not a blank/comment line And inside [windows] section

If Trim(strLine) <> "" And Left(LTrim(strLine),1) <> ";" Then

 

'if inside [boot] section

If flagSection Then

 

If Left(LTrim(strLine),1) = "[" Then

'toggle flagSection and exit

flagSection = False : Exit Do

End If 'shell line?

 

IniInfParse strLine, "shell", "explorer.exe", ""

IniInfParse strLine, "scrnsave.exe", "anything", ""

 

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

 

End If 'blank/comment line?

 

Loop

 

oSCF.Close

 

strSubTitle = ""

 

'for W98 only

If strOS = "W98" Then

 

strTitle = "WINSTART.BAT contents:"

 

'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 strTitle <> "" Then

TitleLineWrite : oFN.WriteBlankLines(1)

End If

oFN.WriteLine strLine

End If

 

Else 'len 1-2

 

TitleLineWrite : oFN.WriteLine strLine

 

End If 'len < 3?

 

End If 'carriage return?

 

Loop 'WINSTART.BAT lines

 

oSCF.Close : Set oSCF=Nothing

 

Else 'WINSTART.BAT doesn't exist

 

'if ShowAll, write title lines

If flagShowAll Then

TitleLineWrite : oFN.WriteLine vbCRLF & "(file not found)"

End If

 

End If 'WINSTART.BAT exists?

 

End If 'W98?

 

Else 'NT4+

 

strTitle = "IniFileMapping Pointers to .INI Files:"

strSubTitle = "HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\IniFileMapping\"

 

'Allowed INI-File Sections & Registry Locations

Dim dictAIFSRL : Set dictAIFSRL = CreateObject("Scripting.Dictionary")

 

strSubSubTitle = "ImageFileExecutionOptions.ini\"

strKey = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\IniFileMapping\ImageFileExecutionOptions.ini"

strValue = "SYS:Microsoft\Windows NT\CurrentVersion\Image File Execution Options"

 

ChkDefaultValue strKey, strValue 'compare default value to strValue

 

strSubSubTitle = "System.ini\"

strKey = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\IniFileMapping\system.ini"

 

If strOS = "WVA" Then 'Vista exception

dictAIFSRL.Add "drivers","SYS:Microsoft\Windows NT\CurrentVersion\Drivers"

Else

dictAIFSRL.Add "drivers","#SYS:Microsoft\Windows NT\CurrentVersion\drivers"

End If

dictAIFSRL.Add "drivers32","SYS:Microsoft\Windows NT\CurrentVersion\Drivers32"

dictAIFSRL.Add "NonWindowsApp","SYS:Microsoft\Windows NT\CurrentVersion\WOW\NonWindowsApp"

dictAIFSRL.Add "standard","SYS:Microsoft\Windows NT\CurrentVersion\WOW\standard"

 

ChkNameValues strKey, dictAIFSRL, False 'compare name/value pairs to allowed

 

dictAIFSRL.RemoveAll

 

strSubSubTitle = "system.ini\boot\"

strKey = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\IniFileMapping\system.ini\boot"

strValue = "SYS:Microsoft\Windows NT\CurrentVersion\WOW\boot"

 

ChkDefaultValue strKey, strValue 'compare default value to strValue

 

dictAIFSRL.Add "SCRNSAVE.EXE","USR:Control Panel\Desktop"

dictAIFSRL.Add "Shell","SYS:Microsoft\Windows NT\CurrentVersion\Winlogon"

 

ChkNameValues strKey, dictAIFSRL, True 'compare name/value pairs to allowed

'resolve unallowed value

 

dictAIFSRL.RemoveAll

 

strSubSubTitle = "win.ini\"

strKey = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\IniFileMapping\win.ini"

 

dictAIFSRL.Add "AeDebug","SYS:Microsoft\Windows NT\CurrentVersion\AeDebug"

dictAIFSRL.Add "Devices","USR:Software\Microsoft\Windows NT\CurrentVersion\Devices"

dictAIFSRL.Add "Winlogon","SYS:Microsoft\Windows NT\CurrentVersion\Winlogon"

 

ChkNameValues strKey, dictAIFSRL, False 'compare name/value pairs to allowed

 

dictAIFSRL.RemoveAll

 

strSubSubTitle = "win.ini\Windows\"

strKey = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\IniFileMapping\win.ini\Windows"

strValue = "USR:Software\Microsoft\Windows NT\CurrentVersion\Windows"

 

ChkDefaultValue strKey, strValue 'compare default value to strValue

 

If strOS = "WVA" Then 'Vista typo

dictAIFSRL.Add "AppInit_DLLs","SYS:MICROSOFT\\WINDOWS NT\\CURRENTVERSION\\WINDOWS"

Else

dictAIFSRL.Add "AppInit_DLLs","SYS:Microsoft\Windows NT\CurrentVersion\Windows"

End If

 

ChkNameValues strKey, dictAIFSRL, True 'compare name/value pairs to allowed

'resolve unallowed value

 

dictAIFSRL.RemoveAll

 

End If 'strOS = W98/WME

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

strWarn = "" : strOut = ""

 

End If 'SecTest?

 

 

 

 

'#17. AUTORUN.INF in root directory of local fixed disks

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

'WMe & WXP SP2 do not launch AUTORUN.INF on local fixed disks

If strOS <> "WME" And strOSLong <> "Windows XP SP2" Then

 

'fixed disk, DWORD value, binary value array, AutoRun.Inf file,

Dim oDisk, hVal, arBVal, oARI

 

strTitle = "Autostart via AUTORUN.INF on local fixed drives:"

 

'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:"

 

'assume HKLM NoDriveTypeAutoRun Fixed Disks Enabled

Public flagHKLM_NDTAR_FDE : flagHKLM_NDTAR_FDE = True

'assume HKCU NoDriveTypeAutoRun Fixed Disks Enabled

Public flagHKCU_NDTAR_FDE : flagHKCU_NDTAR_FDE = True

 

'assume HKLM NoDriveTypeAutoRun value does NOT exist

Public flagHKLM_NDTAR : flagHKLM_NDTAR = False

'assume HKCU NoDriveTypeAutoRun value does NOT exist (unused, passed for consistency)

Public flagHKCU_NDTAR : flagHKCU_NDTAR = False

 

'assume HKLM NoDriveAutoRun value does NOT exist

Public flagHKLM_NDAR : flagHKLM_NDAR = False

'assume HKCU NoDriveAutoRun value does NOT exist (unused, passed for consistency)

Public flagHKCU_NDAR : flagHKCU_NDAR = False

 

strKey = "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer"

 

'WVa RC1 ignores NDTAR/NDAR values in HKCU/HKLM

If strOS <> "WVA" Then

 

'check NDTAR/NDTAR_FDE values in HKLM, toggle flag if needed

NDTAR HKLM, flagHKLM_NDTAR, flagHKLM_NDTAR_FDE

'if HKLM NDTAR value not found, check NDTAR/NDTAR_FDE values in HKCU

If Not flagHKLM_NDTAR Then NDTAR HKCU, flagHKCU_NDTAR, flagHKCU_NDTAR_FDE

 

Else 'strOS = "WVA"

 

flagHKLM_NDTAR = True : flagHKCU_NDTAR = True

flagHKLM_NDTAR_FDE = True : flagHKCU_NDTAR_FDE = True

 

End If

 

'if NoDriveTypeAutoRun permits autorun on fixed disks, look at

'individual disks

If flagHKLM_NDTAR_FDE And flagHKCU_NDTAR_FDE Then

 

'enumerate fixed disks

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

 

'WVa RC1 ignores NDAR values

If strOS <> "WVA" Then

NDAR HKLM, flagHKLM_NDAR

Else

flagHKLM_NDAR = True : flagHKCU_NDAR = True

End if

 

If Not flagHKLM_NDAR Then NDAR HKCU, flagHKCU_NDAR

 

'for every fixed disk

For i = 0 To UBound(arFixedDisks,2)

 

strSubTitle = arFixedDisks(0,i) & "\"

 

'if autorun enabled

If arFixedDisks(2,i) Then

 

'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", "", arFixedDisks(0,i)

IniInfParse strLine, "shellexecute", "", arFixedDisks(0,i)

 

Loop 'next AUTORUN.INF line

 

oARI.Close : Set oARI=Nothing 'close AUTORUN.INF

 

'if no verbs found And ShowAll

If strSubTitle <> "" And flagShowAll Then

 

TitleLineWrite

 

oFN.WriteLine "AUTORUN.INF -> (" & DQ & "open" & DQ &_

" & " & DQ & "shellexecute" & DQ & " lines not found)"

 

End If 'ShowAll?

 

Else 'AUTORUN.INF not found in root

 

'if ShowAll

If flagShowAll Then

 

TitleLineWrite

 

'output file not found message

oFN.WriteLine "AUTORUN.INF -> (file not found)"

 

End If 'ShowAll?

 

End If 'AUTORUN.INF exists in root?

 

End If 'autorun enabled on drive?

 

Next 'fixed disk

 

End If 'NoDriveTypeAutoRun enables autorun on fixed disks?

 

dictDL.RemoveAll : Set dictDL=Nothing

 

End If 'strOS <> WME/WXP SP2?

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

End If 'SecTest?

 

 

 

 

'#18. HKLM... Explorer\AutoplayHandlers\Handlers

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

' And OS = WXP or WVA

If (Not flagTest Or (flagTest And SecTest)) And (strOS = "WXP" Or strOS = "WVA") Then

 

'InvokeProgID, InvokeVerb, Command/DropTarget subverbs, found subverbs,

'path from HKLM\SOFTWARE\Classes to shell\verb

Dim strHandlerSubKey, strProgID, strVerb, arSubVerbs, strSubVerb, strClass2Verb, strHive, strCLSIDVerb, flagSUBAllow

Dim strCLSIDSubKey 'path to one of four CLSID verbs

 

Dim strCLSIDVerbValue

 

Dim strProvider 'Provider value

'2 row x 3 col array, col 0: subverb; col 1: value; col 2: found?

Dim arAllowedSubVerbs (1,2)

arAllowedSubVerbs(0,0) = "Command"

arAllowedSubVerbs(0,1) = ""

arAllowedSubVerbs(1,0) = "DropTarget"

arAllowedSubVerbs(1,1) = "CLSID"

'four possible CLSID verbs

Dim arCLSIDVerbs : arCLSIDVerbs = Array("InProcServer32","LocalServer32","ProgID","VersionIndependentProgID")

'are Provider/InitCmdLine/CLSID/InvokeProgID executables default?

Dim flagAllowProvider, flagAllowICL, flagAllowCLSIDServer, flagAllowInvokeProgID

 

'mix of Provider, ICL, CLSID Server values that cover all executables referred by Handler names

Dim arAllowedHandlerGrammar()

ReDim arAllowedHandlerGrammar(65)

 

'WXP Home

arAllowedHandlerGrammar(0) = "@%SystemRoot%\system32\SHELL32.dll,-17170"

arAllowedHandlerGrammar(1) = strWinDir & "\Explorer.exe /idlist,%I,%L"

arAllowedHandlerGrammar(2) = "@%SystemRoot%\system32\SHELL32.dll,-17155"

arAllowedHandlerGrammar(3) = DQ & strPgmFilesDir & "\Windows Media Player\wmplayer.exe" &_

DQ & " /prefetch:3 /device:AudioCD " & DQ & "%L" & DQ

arAllowedHandlerGrammar(4) = DQ & strPgmFilesDir & "\Windows Media Player\wmplayer.exe" &_

DQ & " /prefetch:4 /device:DVD " & DQ & "%L" & DQ

arAllowedHandlerGrammar(5) = strWinDir & "\system32\wmpshell.dll"

arAllowedHandlerGrammar(6) = "@%SystemRoot%\system32\SHELL32.dll,-17159"

arAllowedHandlerGrammar(7) = "rundll32.exe " & strWinDir & "\system32\shimgvw.dll," &_

"ImageView_Fullscreen %1"

arAllowedHandlerGrammar(8) = strWinDir & "\System32\photowiz.dll"

arAllowedHandlerGrammar(9) = "Windows Explorer"

arAllowedHandlerGrammar(10) = "PromptEachTime"

arAllowedHandlerGrammar(11) = "rundll32.exe shell32.dll,SHCreateLocalServerRunDll " &_

"{995C996E-D918-4a8c-A302-45719A6F4EA7}"

arAllowedHandlerGrammar(12) = "PromptEachTimeNoContent"

arAllowedHandlerGrammar(13) = DQ & strPgmFilesDir & "\Windows Media Player\wmplayer.exe" &_

DQ & " /prefetch:3 /RipAudioCD " & DQ & "%L" & DQ

arAllowedHandlerGrammar(14) = "@%SystemRoot%\system32\SHELL32.dll,-17157"

arAllowedHandlerGrammar(15) = "rundll32.exe " & strWinDir & "\system32\shimgvw.dll," &_

"ImageView_COMServer {00E7B358-F65B-4dcf-83DF-CD026B94BFD4}"

arAllowedHandlerGrammar(16) = "@" & strPgmFilesDir & "\Movie Maker\wmmres.dll,-61424"

arAllowedHandlerGrammar(17) = DQ & strPgmFilesDir & "\Movie Maker\moviemk.exe" & DQ & " /RECORD"

arAllowedHandlerGrammar(18) = "rundll32.exe shell32.dll,SHCreateLocalServerRunDll " &_

"{FFB8655F-81B9-4fce-B89C-9A6BA76D13E7}"

arAllowedHandlerGrammar(19) = strWinDir & "\System32\wiadefui.dll"

arAllowedHandlerGrammar(20) = DQ & strPgmFilesDir & "\Windows Media Player\wmplayer.exe" &_

DQ & " /prefetch:3 /task:PortableDevice"

arAllowedHandlerGrammar(21) = "@" & strPgmFilesDir & "\Movie Maker\wmmres.dll,-61424"

arAllowedHandlerGrammar(22) = "@wmploc.dll,-6502"

arAllowedHandlerGrammar(23) = DQ & strPgmFilesDir & "\Windows Media Player\wmplayer.exe" &_

DQ & " /prefetch:3 /Task:PortableDevice /Device:" & DQ & "%L" & DQ

 

'WVA

arAllowedHandlerGrammar(24) = "@" & strWinDir & "\eHome\ehdrop.dll,-115"

arAllowedHandlerGrammar(25) = strWinDir & "\eHome\ehdrop.dll"

arAllowedHandlerGrammar(26) = "@" & strWinDir & "\system32\shell32.dll,-17417"

arAllowedHandlerGrammar(27) = strWinDir & "\system32\shell32.dll,PrepareDiscForBurnRunDll %L"

arAllowedHandlerGrammar(28) = "@emdmgmt.dll,-200"

arAllowedHandlerGrammar(29) = "rundll32.exe emdmgmt.dll,EMDMgmtLaunchProperties %L"

arAllowedHandlerGrammar(30) = DQ & strPgmFilesDir & "\Movie Maker\dvdmaker.exe" &_

DQ & " -drive:%L" & DQ

arAllowedHandlerGrammar(31) = strWinDir & "\Explorer.exe /separate,/idlist,%I,%L"

arAllowedHandlerGrammar(32) = "@" & strPgmFilesDir & "\Windows Photo Gallery\PhotoAcq.dll,-401"

arAllowedHandlerGrammar(33) = DQ & strWinDir & "\System32\rundll32.exe" & DQ &_

" " & DQ & strPgmFilesDir & "\Windows Photo Gallery\PhotoAcq.dll" & DQ &_

",AutoplayComServerW {00f2b433-44e4-4d88-b2b0-2698a0a91dba}"

arAllowedHandlerGrammar(34) = strWinDir & "\system32\rundll32.exe " & strWinDir &_

"\system32\shell32.dll,PrepareDiscForBurnRunDll %L"

arAllowedHandlerGrammar(35) = "@" & strPgmFilesDir & "\movie maker\dvdmaker.exe,-61403"

arAllowedHandlerGrammar(36) = DQ & strPgmFilesDir & "\Movie Maker\dvdmaker.exe" &_

DQ & " -drive:%L"

arAllowedHandlerGrammar(37) = strPgmFilesDir & "\Windows Photo Gallery\PhotoAcq.dll"

arAllowedHandlerGrammar(38) = DQ & strPgmFilesDir & "\Windows Media Player\wmplayer.exe" &_

DQ & " /prefetch:4 /device:VCD " & DQ & "%L" & DQ

arAllowedHandlerGrammar(39) = "@" & strWinDir & "\system32\shell32.dll,-17411"

arAllowedHandlerGrammar(40) = strWinDir & "\System32\rundll32.exe shell32.dll," &_

"SHCreateLocalServerRunDll {995C996E-D918-4a8c-A302-45719A6F4EA7}"

arAllowedHandlerGrammar(41) = DQ & strPgmFilesDir & "\Windows Media Player\wmplayer.exe" &_

DQ & " /prefetch:3 /RipAudioCD " & DQ & "%L" & DQ

arAllowedHandlerGrammar(42) = "@%SystemRoot%\system32\audiodev.dll,-501"

arAllowedHandlerGrammar(43) = "::{21EC2020-3AEA-1069-A2DD-08002B30309D}\" &_

"::{640167b4-59b0-47a6-b335-a6b3c0695aea}"

arAllowedHandlerGrammar(44) = strWinDir & "\System32\rundll32.exe shell32.dll," &_

"SHCreateLocalServerRunDll {FFB8655F-81B9-4fce-B89C-9A6BA76D13E7}"

arAllowedHandlerGrammar(45) = "@" & strPgmFilesDir & "\Windows Photo Gallery\PhotoViewer.dll,-3067"

arAllowedHandlerGrammar(46) = DQ & strWinDir & "\System32\rundll32.exe" & DQ &_

" " & DQ & strPgmFilesDir & "\Windows Photo Gallery\PhotoViewer.dll" & DQ &_

",ImageView_COMServer {9D687A4C-1404-41ef-A089-883B6FBECDE6}"

arAllowedHandlerGrammar(47) = "@" & strPgmFilesDir & "\Movie Maker\CaptureWizard.exe,-61403"

arAllowedHandlerGrammar(48) = "CaptureWizard"

arAllowedHandlerGrammar(49) = DQ & strPgmFilesDir & "\Movie Maker\VideoCameraAutoPlayManager.exe" & DQ

arAllowedHandlerGrammar(50) = DQ & strPgmFilesDir & "\Windows Media Player\wmplayer.exe" &_

DQ & " /prefetch:3 /Task:CDWrite /Device:" & DQ & "%L" & DQ

arAllowedHandlerGrammar(51) = DQ & strPgmFilesDir & "\Windows Media Player\wmplayer.exe" &_

DQ & " /prefetch:3 /Task:DVDWrite /Device:" & DQ & "%L" & DQ

arAllowedHandlerGrammar(52) = "@%windir%\system32\migwiz\MIGUIRes.dll,-12095"

arAllowedHandlerGrammar(53) = "MigAutoPlay.exe"

arAllowedHandlerGrammar(54) = "/NetworkConfig;rundll32;xwizards.dll,RunWizard {34c219bd-85c1-4338-95e8-788a36901dc2} /z %s"

arAllowedHandlerGrammar(55) = "@" & strWinDir & "\system32\wpdshext.dll,-503"

arAllowedHandlerGrammar(56) = "@" & strWinDir & "\system32\wpdshext.dll,-501"

arAllowedHandlerGrammar(57) = strWinDir & "\system32\WPDShextAutoplay.exe"

arAllowedHandlerGrammar(58) = "/NetworkConfig;rundll32;xwizards.dll," &_

"RunWizard {34c219bd-85c1-4338-95e8-788a36901dc2} /z %s"

 

'WXP Pro

arAllowedHandlerGrammar(59) = "::{20D04FE0-3AEA-1069-A2D8-08002B30309D}\" &_

"::{21EC2020-3AEA-1069-A2DD-08002B30309D}\::{640167b4-59b0-47a6-b335-a6b3c0695aea}"

arAllowedHandlerGrammar(60) = "@" & strPgmFilesDir & "\Movie Maker\wmm2res.dll,-100"

'language-specific!

arAllowedHandlerGrammar(61) = "@" & strPgmFilesDir & "\Movie Maker\1033\wmm2res.dll,-100"

arAllowedHandlerGrammar(62) = DQ & strPgmFilesDir & "\Movie Maker\moviemk.exe" &_

DQ & " /RECORD"

arAllowedHandlerGrammar(63) = DQ & strPgmFilesDir &_

"\Windows Media Player\wmlaunch.exe" & DQ

arAllowedHandlerGrammar(64) = "@%systemroot%\System32\wiaacmgr.exe,-101"

arAllowedHandlerGrammar(65) = strWinDir & "\system32\svchost.exe"

[MAcgYvER everyONE 0]

strTitle = "Windows Portable Device AutoPlay Handlers"

 

strKey = "SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\AutoplayHandlers\Handlers"

strSubTitle = "HKLM\" & strKey & "\"

 

'find all the Handlers

intErrNum = oReg.EnumKey (HKLM,strKey,arKeys)

 

'if Handlers found

If intErrNum = 0 And IsArray(arKeys) Then

 

'for each Handler

For Each strHandlerSubKey In arKeys

 

flagFound = False : flagAllow = False

 

' InvokeProgID & InvokeVerb

' -------------------------

 

'Shell\verb\Command/DropValue values not found

arAllowedSubVerbs(0,2) = False : arAllowedSubVerbs(1,2) = False

 

'look for InvokeProgID & InvokeVerb

intErrNum1 = oReg.GetStringValue (HKLM,strKey & "\" & strHandlerSubKey,"InvokeProgID",strProgID)

intErrNum2 = oReg.GetStringValue (HKLM,strKey & "\" & strHandlerSubKey,"InvokeVerb",strVerb)

 

'if InvokeProgID & InvokeVerb both found

If intErrNum1 = 0 And intErrNum2 = 0 Then

 

'intialize variables & flag

strValue = "" : strCLSIDVerb = "" : strCLSIDVerbValue = "" : strCLSIDTitle = ""

strProvider = ""

 

flagAllowProvider = True 'start out with Handler Provider is default

 

'set up SubSubTitle

strSubSubTitle = strHandlerSubKey & "\" & vbCRLF &_

DQ & "InvokeProgID" & DQ & " = " & DQ & strProgID & DQ & vbCRLF &_

DQ & "InvokeVerb" & DQ & " = " & DQ & strVerb & DQ

 

'look for Provider

intErrNum5 = oReg.GetStringValue (HKLM,strKey & "\" & strHandlerSubKey,"Provider",strProvider)

 

'if Provider found

If intErrNum5 = 0 And strProvider <> "" Then

 

'modify SubSubTitle

strSubSubTitle = strHandlerSubKey & "\" & vbCRLF &_

DQ & "Provider" & DQ & " = " & DQ & strProvider & DQ & vbCRLF &_

DQ & "InvokeProgID" & DQ & " = " & DQ & strProgID & DQ & vbCRLF &_

DQ & "InvokeVerb" & DQ & " = " & DQ & strVerb & DQ

 

flagAllowProvider = False 'assume Handler Provider is not default

 

'check to see if Provider value is default

For nn = 0 To UBound(arAllowedHandlerGrammar)

 

If LCase(Trim(strProvider)) = LCase(arAllowedHandlerGrammar(nn)) Then

flagAllowProvider = True : Exit For

End If

 

Next 'arAllowedHandlerGrammar member

 

End If 'strProvider found?

 

'assemble InvokeProgID + Verb phrase

strClass2Verb = "SOFTWARE\Classes\" & strProgID & "\shell\" & strVerb

 

'look for phrase in each hive

For ii = 0 To 1

 

'look for phrase subverbs

intErrNum3 = oReg.EnumKey (arHives(ii,1),strClass2Verb,arSubVerbs)

 

'if subverbs found

If intErrNum3 = 0 And IsArray(arSubVerbs) Then

 

'for each subverb found

For Each strSubVerb In arSubVerbs

 

'intialize flags

flagAllowCLSIDServer = False 'Handler action not default

flagAllowInvokeProgID = False 'Handler action not default

flagAllow = False 'TRUE if Provider & CLSIDServer are default

 

'check if subverb either Command or DropTarget

For jj = 0 To UBound(arAllowedSubVerbs,1)

 

'since this For _must_ be traversed for all index values, an

'Exit for a subverb already found cannot be placed here

 

'if command or droptarget found

If LCase(strSubVerb) = LCase(arAllowedSubVerbs(jj,0)) Then

 

'exit if subverb already found

If arAllowedSubVerbs(jj,2) Then Exit For

 

'retrieve the Command default value or DropTarget CLSID value

intErrNum4 = oReg.GetStringValue (arHives(ii,1),strClass2Verb &_

"\" & strSubVerb,arAllowedSubVerbs(jj,1),strValue)

 

'if the value exists

If intErrNum4 = 0 And strValue <> "" Then

 

'toggle flagFound flag to avoid subsequent sections

flagFound = True

 

'if value is a CLSID

If IsCLSID(strValue) Then

 

'resolve the CLSID & set Allow flag

CLSIDPop strValue, UBound(arCLSIDVerbs), flagAllowCLSIDServer, _

strHive, strCLSIDVerb, strCLSIDVerbValue, strCLSIDTitle

 

If strCLSIDVerbValue <> "" Then

 

arAllowedSubVerbs(jj,2) = True

 

'toggle flagAllow if Provider & CLSIDServer are default

If flagAllowCLSIDServer And flagAllowProvider Then _

flagAllow = True

 

'output required if not default Or ShowAll

If Not flagAllow Or flagShowAll Then

 

TitleLineWrite

oFN.WriteLine SOCA(arHives(ii,0) & "\" & strClass2Verb) & "\" &_

strSubVerb & "\" & arAllowedSubVerbs(jj,1) & " = " &_

DQ & strValue & DQ

oFN.WriteLine " -> {" & strHive & "...CLSID} = " & strCLSIDTitle

oFN.WriteLine Space(19) & "\" & strCLSIDVerb & "\(Default) = " &_

StringFilter(strCLSIDVerbValue,True) & CoName(IDExe(strCLSIDVerbValue))

 

'toggle Command/DropTarget found flag

arAllowedSubVerbs(jj,2) = True : Exit For

 

End If 'output required?

 

End If 'strCLSIDVerbValue not empty?

 

Else 'IsCLSID = False, so this is a Command verb

 

'check to see if Command value is default

For nn = 0 To UBound(arAllowedHandlerGrammar)

 

If arAllowedSubVerbs(jj,2) = True Then Exit For

 

'if default, toggle Command/DropTarget found flag & default flag

If LCase(Trim(strValue)) = LCase(arAllowedHandlerGrammar(nn)) Then

arAllowedSubVerbs(jj,2) = True : flagAllowInvokeProgID = True : Exit For

End If

 

Next

 

'toggle flagAllow if Provider & CLSIDServer are default

If flagAllowInvokeProgID And flagAllowProvider Then _

flagAllow = True

 

'output required if not default or ShowAll

If Not flagAllow Or flagShowAll Then

 

TitleLineWrite

oFN.WriteLine SOCA(arHives(ii,0) & "\" & strClass2Verb) &_

"\" & strSubVerb & "\" & arAllowedSubVerbs(jj,1) &_

"(Default) = " & DQ & strValue & DQ & CoName(IDExe(strValue))

arAllowedSubVerbs(jj,2) = True : Exit For

 

End If 'output required?

 

End If 'IsCLSID?

 

End If 'Command\(Default)/DropTarget\CLSID value exists?

 

End If 'Command/DropTarget verb exists?

 

Next 'jj arAllowedSubVerb

 

Next 'arSubVerb

 

End If 'arSubVerbs exists?

 

Next 'ii hive

 

End If 'InvokeProgID & Invoke Verb (intErrNum1/2) both found?

 

 

 

' ProgID & Provider

' -----------------

 

'if Handler action not defined by InvokeProgID & InvokeVerb,

'try ProgID & Provider

If Not flagFound Then

 

'look for ProgID & Provider

intErrNum1 = oReg.GetStringValue (HKLM,strKey & "\" & strHandlerSubKey,"ProgID",strProgID)

intErrNum2 = oReg.GetStringValue (HKLM,strKey & "\" & strHandlerSubKey,"Provider",strProvider)

 

'if ProgID & Provider both found

If intErrNum1 = 0 And intErrNum2 = 0 Then

 

'intialize variables & flags

strValue = "" : strValue3 = "" : strCLSIDVerb = "" : strCLSIDVerbValue = ""

strCLSIDTitle = ""

 

flagAllowCLSIDServer = False 'Handler action not permitted/default

flagAllowProvider = False 'Handler Provider is not permitted/default

flagAllowICL = True 'Handler InitCmdLine is permitted/default

flagAllow = False 'Handler is not permitted/default

 

'check to see if Provider value is default

For nn = 0 To UBound(arAllowedHandlerGrammar)

 

If LCase(Trim(strProvider)) = LCase(arAllowedHandlerGrammar(nn)) Then

flagAllowProvider = True : Exit For

End If

 

Next 'arAllowedHandlerGrammar member

 

strSubSubTitle = strHandlerSubKey & "\" & vbCRLF &_

DQ & "Provider" & DQ & " = " & DQ & strProvider & DQ & vbCRLF &_

DQ & "ProgID" & DQ & " = " & DQ & strProgID & DQ

 

'assemble ProgID\CLSID key

strClass2Verb = "SOFTWARE\Classes\" & strProgID & "\CLSID"

 

'look in each hive

For ii = 0 To 1

 

'exit if CLSID server already found

If flagFound Then Exit For

 

'look for ProgID\CLSID default value

intErrNum2 = oReg.GetStringValue (arHives(ii,1),strClass2Verb,"",strValue)

 

'if ProgID\CLSID default value exists

If intErrNum2 = 0 And strValue <> "" Then

 

flagFound = True 'skip remaining sections

 

If IsCLSID(strValue) Then

 

CLSIDPop strValue, 1, flagAllowCLSIDServer, strHive, strCLSIDVerb, _

strCLSIDVerbValue, strCLSIDTitle

 

If strCLSIDVerbValue <> "" Then

 

'look for InitCmdLine value

flagAllowICL = True 'Handler InitCmdLine is (permitted) default

intErrNum6 = oReg.GetStringValue (HKLM,strKey & "\" &_

strHandlerSubKey,"InitCmdLine",strValue3)

 

'if ICL value found

If intErrNum6 = 0 And strValue3 <> "" Then

 

flagAllowICL = False 'since ICL was found, it may not be a default

 

'if ICL is default, toggle ICL flag

For nn = 0 To UBound(arAllowedHandlerGrammar)

 

If LCase(Trim(strValue3)) = LCase(arAllowedHandlerGrammar(nn)) Then

flagAllowICL = True : Exit For

End If

 

Next 'arAllowedHandlerGrammar member

 

End If 'ICL found?

 

'if three flags are all default, toggle Allow flag

If flagAllowProvider And flagAllowCLSIDServer And _

flagAllowICL Then flagAllow = True

 

'output if required

If Not flagAllow Or flagShowAll Then

 

TitleLineWrite

If intErrNum6 = 0 And strValue3 <> "" Then oFN.WriteLine DQ &_

"InitCmdLine" & DQ & " = " & DQ & strValue3 & DQ

oFN.WriteLine SOCA(arHives(ii,0) & "\" & strClass2Verb) &_

"\(Default) = " & DQ & strValue & DQ

oFN.WriteLine " -> {" & strHive & "...CLSID} = " & strCLSIDTitle

oFN.WriteLine Space(19) & "\" & strCLSIDVerb & "\(Default) = " &_

StringFilter(strCLSIDVerbValue,True) & CoName(IDExe(strCLSIDVerbValue))

 

Exit For

 

End If 'Not flagAllow?

 

End If 'strCLSIDVerbValue not empty?

 

End If 'IsCLSID?

 

End If 'CLSID exists?

 

Next 'ii hive

 

End If 'ProgID & Provider values found?

 

End If 'flagFound?

 

 

' CLSID

' -----

 

'if Handler action not defined by InvokeProgID & InvokeVerb,

'or by ProgID & Provider, try CLSID

If Not flagFound Then

 

strValue = "" 'intialize empty

 

'look for CLSID

intErrNum1 = oReg.GetStringValue (HKLM,strKey & "\" & strHandlerSubKey,"CLSID",strValue)

 

'if CLSID value found

If intErrNum1 = 0 And strValue <> "" Then

 

'intialize variables & flags

strValue3 = "" : strCLSIDVerb = "" : strCLSIDVerbValue = ""

strCLSIDTitle = "" : strProvider = ""

 

flagAllowCLSIDServer = False 'Handler CLSID Server is not permitted/default

flagAllowProvider = True 'Handler Provider is permitted/default

flagAllowICL = True 'Handler InitCmdLine is permitted/default

flagAllow = False 'Handler is not permitted/default

 

If IsCLSID(strValue) Then

 

strSubSubTitle = strHandlerSubKey & "\" & vbCRLF &_

DQ & "CLSID" & DQ & " = " & DQ & strValue & DQ

 

'look for Provider

intErrNum5 = oReg.GetStringValue (HKLM,strKey & "\" &_

strHandlerSubKey,"Provider",strProvider)

 

'if Provider found

If intErrNum5 = 0 And strProvider <> "" Then

 

'modify SubSubTitle

strSubSubTitle = strHandlerSubKey & "\" & vbCRLF &_

DQ & "Provider" & DQ & " = " & DQ & strProvider & DQ & vbCRLF &_

DQ & "CLSID" & DQ & " = " & DQ & strValue & DQ

 

flagAllowProvider = False 'Handler Provider is not default

 

'check to see if Provider value is default

For nn = 0 To UBound(arAllowedHandlerGrammar)

 

If LCase(Trim(strProvider)) = LCase(arAllowedHandlerGrammar(nn)) Then

flagAllowProvider = True : Exit For

End If

 

Next 'arAllowedHandlerGrammar member

 

End If 'strProvider found?

 

CLSIDPop strValue, 1, flagAllowCLSIDServer, strHive, strCLSIDVerb, _

strCLSIDVerbValue, strCLSIDTitle

 

If strCLSIDVerbValue <> "" Then

 

'look for InitCmdLine value

intErrNum6 = oReg.GetStringValue (HKLM,strKey & "\" &_

strHandlerSubKey,"InitCmdLine",strValue3)

 

'if ICL value found

If intErrNum6 = 0 And strValue3 <> "" Then

 

flagAllowICL = False 'since ICL was found, it may not be a default

 

'if ICL is default, toggle ICL flag

For nn = 0 To UBound(arAllowedHandlerGrammar)

 

If LCase(Trim(strValue3)) = LCase(arAllowedHandlerGrammar(nn)) Then

flagAllowICL = True : Exit For

End If

 

Next 'arAllowedHandlerGrammar member

 

End If 'ICL found?

 

'if all three flags are default, toggle Allow flag

If flagAllowProvider And flagAllowCLSIDServer And flagAllowICL Then _

flagAllow = True

 

'output if required

If Not flagAllow Or flagShowAll Then

 

TitleLineWrite

If intErrNum6 = 0 And strValue3 <> "" Then oFN.WriteLine DQ &_

"InitCmdLine" & DQ & " = " & DQ & strValue3 & DQ

oFN.WriteLine " -> {" & strHive & "...CLSID} = " & strCLSIDTitle

oFN.WriteLine Space(19) & "\" & strCLSIDVerb & "\(Default) = " &_

StringFilter(strCLSIDVerbValue,True) & CoName(IDExe(strCLSIDVerbValue))

 

End If 'output required?

 

End If 'strCLSIDVerbValue not empty?

 

End If 'CLSID?

 

End If 'CLSID value found?

 

End If 'flagFound?

 

Next 'Handler subkey

 

End If 'Handler array returned?

 

'clean up

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

flagFound = False : flagAllow = False

ReDim arAllowedHandlerGrammar(0)

 

End If 'SecTest And WXP/WVA?

 

 

 

 

'#19. DESKTOP.INI in any local fixed disk directory (section skipped by default)

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

'skip unless -supp or -all command line parameters used

If flagShowAll Or flagSupp Then

 

Dim datDTIStart : datDTIStart = Now

Public strDTITime

 

'array of allowed CLSID DLLs

Dim arOKDLLs : arOKDLLs = Array("shdocvw.dll", "occache.dll", _

"mstask.dll", "cdfview.dll", "shell32.dll", "fontext.dll", _

"mscoree.dll", "ieframe.dll")

 

strTitle = "DESKTOP.INI DLL launch in local fixed drive directories:"

 

'enumerate fixed disks

Set colDisks = GetObject("winmgmts:\root\cimv2")._

ExecQuery("SELECT * FROM Win32_LogicalDisk WHERE DriveType = 3")

 

For Each oDisk in colDisks

 

'initialize DeskTop.Ini output & error arrays & counters

ReDim arSDDTI(0) : ctrArDTI = 0

ReDim arSDErr(0) : ctrArErr = 0

 

'check for unreadable partition

On Error Resume Next

'root format: C:\

Set oRoot = Fso.GetDrive(oDisk.DeviceID).RootFolder

intErrNum = Err.Number : Err.Clear

On Error Goto 0

 

If intErrNum = 0 Then 'if partition readable

 

'find directories with System attribute containing DESKTOP.INI

'with .ShellClassInfo section and CLSID statement

'fill arSDDTI array with output & arSDErr with (permission) errors

DirSysAtt oRoot

 

'output DLL launch points if found

If ctrArDTI > 0 Then

TitleLineWrite

'output array contents

For i = 0 To UBound(arSDDTI) : oFN.WriteLine arSDDTI(i) : Next

ElseIf flagShowAll Then

TitleLineWrite : oFN.WriteLine vbCRLF & oRoot.Drive & " (no DLL launch points found)"

End If

 

'output errors if ShowAll

If ctrArErr > 0 And flagShowAll Then

 

strSubTitle = "Permission Errors on " & oRoot.Drive : TitleLineWrite : strOut = ""

 

For i = 0 To UBound(arSDErr)

 

'limit line length to 100

If strOut <> "" Then

 

If Len(strOut & arSDErr(i)) >= 100 Then

oFN.WriteLine strOut : strOut = arSDErr(i)

Else

strOut = strOut & ", " & arSDErr(i)

End If 'this error & prev errors>100?

 

Else 'strOut empty

 

If Len(arSDErr(i)) >= 100 Then

oFN.WriteLine arSDErr(i)

Else

strOut = arSDErr(i)

End If 'this error>100?

 

End If 'strOut empty?

 

Next 'arSDErr member

 

'write out final error string

If strOut <> "" Then oFN.WriteLine strOut : strOut = ""

 

End If

 

Set oRoot=Nothing

 

Else 'partition not readable (may be Linux)

 

TitleLineWrite

oFN.WriteLine vbCRLF & "WARNING! " & oDisk.DeviceID & " is an unreadable partition!"

 

End If 'partition readable?

 

Next 'disk in colDisks

 

'determine -supp seconds used

strDTITime = DateDiff("s",datDTIStart,Now) & " seconds"

 

Set colDisks=Nothing

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

'recover array memory

ReDim arSDDTI(0) : ReDim arSDErr(0)

 

End If 'flagShowAll Or flagSupp?

 

End If 'SecTest?

 

 

 

 

'#20. Startup Directories

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

'All Users StartUp Folder (AUSFP title string (empty by default)

Dim flagAUSUF : flagAUSUF = False 'true if entry for AUSF loc'n in registry

Dim flagFE : flagFE = False 'true if AUSF exists

 

'in W98/WMe, see if local-language-specific All Users startup folder location

'appears in registry and set flag 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 name exists and value not empty, toggle flag

If Not IsNull(strValue) And strValue <> "" Then flagAUSUF = True

 

End If

 

'assign startup folder short names

If strOS = "W98" Or strOS = "WME" Then

arSUFN = Array("Startup")

arSUFDN = Array("Startup")

Else

arSUFN = Array("Startup","AllUsersStartup")

arSUFDN = Array("Startup","All Users")

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 & DQ & "Startup" & DQ

 

If flagAUSUF Then

strLine = strLine & " & " & DQ & "All Users...Startup" & DQ & " folders:"

Else

strLine = strLine & " folder:"

End If

 

Else 'all other O/S's

 

strLine = strLine & DQ & Wshso.ExpandEnvironmentStrings("%USERNAME%") &_

DQ & " & " & DQ & "All Users" & DQ & " startup folders:"

arSUFDN(0) = Wshso.ExpandEnvironmentStrings("%USERNAME%")

 

End If

 

strTitle = strLine

 

'for each startup folder name

For i = 0 To 1 '0 = user folder, 1 = All Users folder

 

strSubTitle = "" : flagFE = 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)

strSubTitle = oSUF.Path : flagFE = True

Else

strSubTitle = "WARNING! " & DQ & "All Users" & DQ &_

" startup folder not found!"

TitleLineWrite

End If 'FolderExists?

End If 'flagAUSUF?

 

Else 'all other O/S's at all times

 

On Error Resume Next

Set oSUF = Fso.GetFolder(Wshso.SpecialFolders(arSUFN(i)))

intErrNum = Err.Number : Err.Clear

On Error Goto 0

 

If intErrNum = 0 Then

strSubTitle = oSUF.Path : flagFE = True

Else 'assign title for Startup folder not found

If strOS = "W98" Or strOS = "WME" Then

strSubTitle = "WARNING! " & DQ & arSUFDN(i) & DQ &_

" folder not found!"

Else

strSubTitle = "WARNING! " & DQ & arSUFDN(i) & DQ &_

" startup folder not found!"

End If

TitleLineWrite

End If 'intErrNum=0?

 

End If 'i=1 & W98/WME?

 

'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 = DQ & Fso.GetBaseName (oSUFi.Path) & DQ & " -> URL shortcut to: " &_

DQ & oSUSC.TargetPath

 

Else

 

'prepare the shortcut file base name and the target path & arguments

strLine = DQ & Fso.GetBaseName (oSUFi.Path) & DQ & " -> shortcut to: " &_

DQ & oSUSC.TargetPath

 

If oSUSC.Arguments <> "" Then

strLine = strLine & " " & oSUSC.Arguments & DQ

Else

strLine = strLine & DQ

End If

 

'add co-name

strLine = strLine & CoName(IDExe(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 = DQ & Fso.GetBaseName(oSUFi.Path) & DQ &_

" -> PIF to: " & DQ & strPIFTgt & DQ &_

CoName(IDExe(strPIFTgt))

 

'file is neither shortcut nor PIF

Else

 

'file is probably an executable so include an IWarn and

' the file name, using the full path as IDExe argument

If LCase(Fso.GetFileName(oSUFi)) <> "desktop.ini" Then

strLine = IWarn & DQ & oSUFi.Name & DQ & CoName(IDExe(oSUFi.Path))

flagIWarn = True

End If

 

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

TitleLineWrite

 

'output the line

oFN.WriteLine strLine

 

End If

 

Next 'file in startup folder

 

Set oSUF=Nothing

 

'if ShowAll

If flagShowAll Then TitleLineWrite

 

End If 'flagFE?

 

Next 'startup folder name

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = "" : strWarn = ""

 

'recover array memory

ReDim arSUFN(0)

 

End If 'SecTest?

 

 

 

 

'#21. Enabled Scheduled Tasks

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

'Enabled Scheduled Tasks Directory/Folder object

Dim strESTDir, oESTFo

 

'prepare section title lines

strTitle = "Enabled Scheduled Tasks:"

If strOS = "WVA" Then strTitle = "Non-disabled Scheduled Tasks:"

 

If strOS <> "WVA" Then

 

' Byte Disabled Enabled

'00000030: #####1## #####0## <--

 

'file in Tasks directory

Dim oFi2

 

'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

 

TitleLineWrite

 

'write error message

oFN.WriteLine vbCRLF & DQ & oFi2.Name & DQ &_

" -- insufficient permission to read this file!"

 

End If '.JOB file opened successfully?

 

End If '.JOB file extension selected?

 

Next 'file in TASKS directory

 

'if ShowAll, output title line if not already done

If flagShowAll Then TitleLineWrite

 

Else 'Tasks directory can't be found

 

'write titles and error message

TitleLineWrite

oFN.WriteLine vbCRLF & "WARNING! The " & DQ &_

strWinDir & "\Tasks" & DQ &_

" directory cannot be found."

 

End If 'Tasks directory exists?

 

Set oJobF=Nothing

 

Else 'WVa -- Non-Disabled Scheduled Tasks

 

'initialize error array & counter

ReDim arErr(0) : ctrErr = 0 : strOut = ""

 

'fill strOut with output & arErr with (permission) errors

 

strESTDir = Wshso.ExpandEnvironmentStrings("%WINDIR%\system32\Tasks")

 

Set oESTFo = Fso.GetFolder(strESTDir)

 

'initiate recursion into ST folder to find enabled XML-format tasks

DirEST oESTFo

 

'output EST's if found

If strOut <> "" Then

TitleLineWrite : oFN.WriteLine strOut

ElseIf flagShowAll Then

TitleLineWrite

oFN.WriteLine vbCRLF & "(no enabled scheduled tasks found)"

End If

 

'output directory permission errors if ShowAll

If ctrErr > 0 And flagShowAll Then

 

strSubTitle = "Directory Permission Errors:" & vbCRLF

TitleLineWrite : strOut = ""

 

For i = 0 To UBound(arErr)

 

'limit line length to 100

If strOut <> "" Then

 

If Len(strOut & arErr(i)) >= 100 Then

oFN.WriteLine strOut : strOut = arErr(i)

Else

strOut = strOut & ", " & arErr(i)

End If 'this error & prev errors>100?

 

Else 'strOut empty

 

If Len(arErr(i)) >= 100 Then

oFN.WriteLine arErr(i)

Else

strOut = arErr(i)

End If 'this error>100?

 

End If 'strOut not empty?

 

Next 'arErr member

 

'write out final error string

If strOut <> "" Then oFN.WriteLine strOut : strOut = ""

 

End If 'show errors?

 

End If 'WVa?

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

End If 'SecTest?

 

 

 

 

'#22. Winsock2 Service Provider DLLs

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

strTitle = "Winsock2 Service Provider DLLs:"

 

Dim strNSCatKey 'NameSpace Catalog Key

Dim strProCatKey 'Protocol Catalog Key

Dim strNSSP 'NameSpace Service Provider

Dim arTSP '(returned) Transport Service Provider array

Dim int1C 'single chr binary (integer) code

 

'TSP output array for numeric keys, key #, strlen of key #, work var

Dim arTSPFi(), intKN, intL, intT

'TSP output array for alpha (illegal) keys

Dim arATSPFi()

'arTSPFi is 4 x n array

ReDim arTSPFi(3,0)

ReDim arATSPFi(1,0)

'number of numbered TSP keys

Dim intNumKeys : intNumKeys = 0

intCnt = 0 'arTSPFi UBound - 1

Dim intACnt : intACnt = 0 'arATSPFi UBound - 1

strAllOutDefault = " {++}"

 

'NameSpace Providers

 

strKey = "System\CurrentControlSet\Services\Winsock2\Parameters"

 

'find name of NameSpace Catalog key

intErrNum1 = oReg.GetStringValue (HKLM,strKey,"Current_NameSpace_Catalog",strNSCatKey)

 

'if the Current_NameSpace_Catalog name exists And value set (exc for W2K!)

If intErrNum1 = 0 And strNSCatKey <> "" Then

 

strSubTitle = "Namespace Service Providers" & vbCRLF & vbCRLF &_

SYCA("HKLM\" & strKey & "\" & strNSCatKey & "\Catalog_Entries\" &_

strAllOutDefault)

 

'find NameSpace catalog entry subkeys

oReg.EnumKey HKLM,strKey & "\" & strNSCatKey & "\Catalog_Entries",arKeys

 

'if sub-keys exist

If IsArray(arKeys) Then

 

'for each subkey

For Each oKey in arKeys

 

'find LibraryPath

intErrNum2 = oReg.GetStringValue (HKLM,strKey & "\" & strNSCatKey &_

"\Catalog_Entries\" & oKey,"LibraryPath",strNSSP)

 

'if the LibraryPath name exists And value set (exc for W2K!)

If intErrNum2 = 0 And strNSSP <> "" Then

 

TitleLineWrite

 

On Error Resume Next

oFN.WriteLine oKey & "\LibraryPath" & " = " & DQ &_

strNSSP & DQ & CoName(IDExe(strNSSP))

intErrNum3 = Err.Number : Err.Clear

On Error Goto 0

If intErrNum3 <> 0 Then oFN.WriteLine oKey & "\LibraryPath" &_

" = (value not set)"

 

End If 'LibaryPath value set?

 

Next 'subkey

 

'IsArray = True, but array is empty

If strSubTitle <> "" And flagShowAll Then

TitleLineWrite : oFN.WriteLine vbCRLF & "HKLM\" & strKey &_

"\" & strNSCatKey & "\Catalog_Entries\" & " = (sub-keys not found)"

End If

 

Else 'Catalog_Entries subkeys do not exist

 

If flagShowAll Then

TitleLineWrite : oFN.WriteLine "(sub-keys not found)"

End If

 

End If 'Catalog_Entries subkeys exist?

 

Else 'Current_NameSpace_Catalog value doesn't exist Or value not set

 

If flagShowAll Then

TitleLineWrite : oFN.WriteLine vbCRLF & SYCA("HKLM\" & strKey &_

"\Current_Namespace_Catalog = (value not found)")

End If

 

End If 'Current_NameSpace_Catalog value exists?

 

 

'Transport Service Providers (Layered Service Providers = LSP's)

 

intErrNum1 = oReg.GetStringValue (HKLM,strKey,"Current_Protocol_Catalog",strProCatKey)

 

'if the Current_Protocol_Catalog name exists And value set (exc for W2K!)

If intErrNum1 = 0 And strProCatKey <> "" Then

 

strSubTitle = "Transport Service Providers" & vbCRLF & vbCRLF &_

SYCA("HKLM\" & strKey & "\" & strProCatKey & "\Catalog_Entries\" &_

strAllOutDefault)

 

'find Protocol catalog entry subkeys

oReg.EnumKey HKLM,strKey & "\" & strProCatKey & "\Catalog_Entries",arKeys

 

'if sub-keys exist

If IsArray(arKeys) Then

 

'for each subkey

For Each oKey in arKeys

 

'can only take UBound if subkeys exist

'find number of keys in array & # digits

intNumKeys = UBound(arKeys) + 1

 

'determine # digits

intL = Len(CStr(intNumKeys))

 

'convert key name to integer

On Error Resume Next

intKN = CInt(oKey)

intErrNum = Err.Number : Err.Clear

On Error Goto 0

 

If intErrNum <> 0 Then intKN = -1 'key not in numeric format

 

'find PackedCatalogItem

intErrNum2 = oReg.GetBinaryValue (HKLM,strKey & "\" & strProCatKey &_

"\Catalog_Entries\" & oKey,"PackedCatalogItem",arTSP)

 

'if the PackedCatalogItem name exists And value set (exc for W2K!)

If intErrNum2 = 0 And IsArray(arTSP) Then

 

strDLL = "" 'clear strDLL

 

'reform strDLL from binary data array

For i = 0 To UBound(arTSP)

 

int1C = arTSP(i)

'end of target is single "0" byte

If int1C = 0 Then Exit For

'otherwise convert binary to ASCII and append to string

strDLL = strDLL & Chr(int1C)

 

Next 'binary data array element

 

'if key number numeric

If intKN <> -1 Then

 

'if file array populated

If intCnt > 0 Then

 

flagMatch = False

 

'for every arTSPFi member

For i = 0 To UBound(arTSPFi,2)

 

'if array file matches DLL, store array subscript

If arTSPFi(0,i) = strDLL Then

flagMatch = True : intSS = i : Exit For

End If

 

Next 'arTSPFi member

 

'if DLL is new

If Not flagMatch Then

 

'initialize output array for DLL

ReDim Preserve arTSPFi(3,intCnt)

arTSPFi(0,intCnt) = strDLL 'FN path\file name

arTSPFi(1,intCnt) = Right("0" & CStr(intKN),intL) 'OS output string

arTSPFi(2,intCnt) = intKN 'LA last added key number

arTSPFi(3,intCnt) = intKN 'UL upper limit key number

 

'increment output array for next pass

intCnt = intCnt + 1

 

Else 'flagMatch = True

 

'this key # consecutive to DLL UL

If intKN - arTSPFi(3,intSS) = 1 Then

 

'set DLL UL to this key #

arTSPFi(3,intSS) = intKN

 

Else 'this key # not consecutive to DLL UL

 

'if last added = upper limit, add comma and key # for new range

If arTSPFi(2,intSS) = arTSPFi(3,intSS) Then

 

arTSPFi(1,intSS) = arTSPFi(1,intSS) & ", " &_

Right("0" & CStr(intKN),intL)

arTSPFi(2,intSS) = intKN

arTSPFi(3,intSS) = intKN

 

'last added < upper limit, add hyphen, upper limit, comma and

'key # for new range

Else 'LA <> UL

 

arTSPFi(1,intSS) = arTSPFi(1,intSS) & " - " &_

Right("0" & CStr(arTSPFi(3,intSS)),intL) & ", " &_

Right("0" & CStr(intKN),intL)

arTSPFi(2,intSS) = intKN

arTSPFi(3,intSS) = intKN

 

End If 'LA = UL?

 

End If 'consecutive occurrence?

 

End If 'flagMatch?

 

Else 'intCnt = 0

 

'add first DLL to array

ReDim arTSPFi(3,intCnt)

arTSPFi(0,intCnt) = strDLL 'FN

arTSPFi(1,intCnt) = Right("0" & CStr(intKN),intL) 'OS

arTSPFi(2,intCnt) = intKN 'LA

arTSPFi(3,intCnt) = intKN 'UL

 

intCnt = intCnt + 1

 

End If 'intCnt > 0?

 

Else 'intKN not numeric

 

ReDim Preserve ATSPFi(1,intACnt)

arATSPFi(0,intACnt) = oKey

arATSPFi(1,intACnt) = strDLL

intACnt = intACnt + 1

 

End If 'intKN numeric?

 

End If 'PackedCatalogItem value exists?

 

Next 'subkey

 

 

'output results

 

'if Catalog_Entries sub-keys exist

If intNumKeys > 0 Then

 

'finalize output strings

For i = 0 To UBound(arTSPFi,2)

 

'last added < upper limit, add upper limit

If arTSPFi(2,i) < arTSPFi(3,i) Then

 

arTSPFi(1,i) = arTSPFi(1,i) & " - " & Right("0" & arTSPFi(3,i),intL)

 

End If 'LA = UL?

 

Next 'TSP array member

 

TitleLineWrite

 

'write out non-numeric sub-keys

If intACnt > 0 Then

 

For i = 0 To UBound(arATSPFi,2)

 

oFN.WriteLine vbCRLF & arATSPFi(0,i) & " = " & DQ &_

arATSPFi(1,i) & DQ & CoName(IDExe(arATSPFi(1,i))) & vbCRLF

 

Next

 

End If 'non-numeric sub-keys exist?

 

'write out numeric sub-keys

 

'0000000000##\PackedCatalogItem contains (DLL [Company Name], ##):

'%SystemRoot%\system32\xxxxxx.dll [CN] ##-##, ##-##

'%SystemRoot%\system32\yyyyyy.dll [CN] ##-##

 

oFN.WriteLine String(12-intL,"0") &_

String(intL,"#") & "\PackedCatalogItem (contains) DLL " &_

"[Company Name], (at) " & String(intL,"#") & " range:"

 

For i = 0 To UBound(arTSPFi,2)

 

oFN.WriteLine arTSPFi(0,i) & CoName(IDExe(arTSPFi(0,i))) & ", " &_

arTSPFi(1,i)

 

Next

 

Else 'intNumKeys=0 (no Catalog_Entries sub-keys)

 

If flagShowAll Then

TitleLineWrite : oFN.WriteLine "(sub-keys not found)"

End If

 

End If 'arKeys subkeys exist?

 

Else 'Catalog_Entries sub-keys do not exist

 

If flagShowAll Then

TitleLineWrite : oFN.WriteLine "(sub-keys not found)"

End If

 

End If 'Catalog_Entries array exists?

 

Else 'Current_Protocol_Catalog name doesn't exist Or value not set

 

If flagShowAll Then

TitleLineWrite : oFN.WriteLine vbCRLF & SYCA("HKLM\" & strKey &_

"\Current_Protocol_Catalog = (value not found)")

End If

 

End If 'Current_Protocol_Catalog value exists?

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

'recover array memory

ReDim arTSPFi(0)

ReDim arATSPFi(0)

 

End If 'SecTest?

[MAcgYvER everyONE 0]

'#23. Internet Explorer Toolbars, Explorer Bars, Extensions

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

strTitle = "Toolbars, Explorer Bars, Extensions:"

 

'HKCU/HKLM Explorer Bars, combined array of existing explorer bars

Dim arHKExplorerBars(), arListedExplorerBars()

Dim arAllowedExplorerBars() 'allowed explorer bars

Dim strHKExplorerBar 'single explorer bar

'all CLSIDs, CLSID\Implemented Categories sub-keys, single CLSID, single Impl Cat sub-key

Dim arCLSIDKeys(), arCLSIDImpCatSubKey(), strImpCatSubKey

'count of HKCU/HKLM explorer bars needed for ReDim statement

Dim cntExplorerBars : cntExplorerBars = 0

Dim arHKExtensions() 'HKCU/HKLM extension keys

Dim arAllowedExtensions() 'allowed extensions

Dim strHKExtension 'single extension key name

Dim arAllowedToolbars() 'allowed toolbars

Dim strHKToolbar 'single toolbar value name

Dim arHKCUTbSK() 'HKCU toolbar sub-keys

Dim strSKName 'single toolbar subkey name

Dim arSKValName() 'toolbar sub-key value names

Dim arHKToolbarVals() 'toolbar value names

Dim flagTBTLW : flagTBTLW = False 'toolbar title lines

 

 

'Toolbars

 

strSubTitle = "Toolbars"

 

ReDim arAllowedToolbars(4) 'must be in upper case!

arAllowedToolbars(0) = "{01E04581-4EEE-11D0-BFE9-00AA005B4383}" '&Address

arAllowedToolbars(1) = "{0E5CBF21-D15F-11D0-8301-00AA005B4383}" '&Links

arAllowedToolbars(2) = "{1E796980-9CC5-11D1-A83F-00C04FC99D61}" 'displayed toolbar buttons (non-CLSID)

arAllowedToolbars(3) = "{710EB7A1-45ED-11D0-924A-0020AFC7AC4D}" 'unknown default (non-CLSID)

arAllowedToolbars(4) = "{8E718888-423F-11D2-876E-00A0C9082467}" '... &Radio

 

strKey = "Software\Microsoft\Internet Explorer\Toolbar"

 

'for HKCU & HKLM hives

For i = 0 To 1

 

strSubSubTitle = SOCA(arHives(i,0) & "\" & strKey & "\")

 

'get toolbar key values

oReg.EnumValues arHives(i,1),strKey,arHKToolbarVals,arType

 

'if values exist

If IsArray(arHKToolbarVals) Then

 

'for each value

For Each strCLSID in arHKToolbarVals

 

'change to UCase

strCLSID = Trim(UCase(strCLSID))

 

'assume not on allowed list

flagAllow = False

 

'is Toolbar on allowed list?

For j = 0 To UBound(arAllowedToolbars)

If arAllowedToolbars(j) = UCase(strCLSID) Then

flagAllow = True : Exit For 'toggle allowed flag

End If

Next

 

'if not allowed Or ShowAll

If Not flagAllow Or flagShowAll Then

 

flagTitle = False

 

CLSIDLocTitle arHives(i,1), strKey, strCLSID, strLocTitle

 

For ctrCH = intCLL To 1

 

ResolveCLSID strCLSID, arHives(ctrCH,1), strCLSIDTitle, strIPSDLL

 

If strIPSDLL <> "" Then 'IPS exists?

 

If Not flagTitle Then

 

'output toolbar CLSID value name

On Error Resume Next

If strSubSubTitle <> "" Then

TitleLineWrite : oFN.WriteLine DQ & strCLSID & DQ &_

" = " & strLocTitle

intErrNum = Err.Number : Err.Clear

If intErrNum <> 0 Then oFN.WriteLine DQ & strCLSID & DQ &_

" = (no title provided)"

Else

oFN.WriteLine DQ & strCLSID & DQ & " = " & strLocTitle

intErrNum = Err.Number : Err.Clear

If intErrNum <> 0 Then oFN.WriteLine DQ & strCLSID & DQ &_

" = (no title provided)"

End If

flagTitle = True

On Error Goto 0

 

End If

 

'output InProcServer32 value

oFN.WriteLine " -> {" & arHives(ctrCH,0) & "...CLSID} = " &_

strCLSIDTitle & vbCRLF & Space(19) & "\InProcServer32\(Default) = " &_

StringFilter(strIPSDLL,True) & CoName(IDExe(strIPSDLL))

 

End If 'strIPSDLL <> ""?

 

Next 'CLSID hive

 

End If 'flagAllow Or ShowAll?

 

Next 'HKCU/HKLM toolbar key value

 

End If 'toolbar key has values

 

'for HKCU Toolbar key only

If arHives(i,0) = "HKCU" Then

 

'get HKCU toolbar subkeys

oReg.EnumKey HKCU,strKey,arHKCUTbSK

 

'if key array exists

If IsArray(arHKCUTbSK) Then

 

'for each sub-key

For Each strSKName in arHKCUTbSK

 

strSubSubTitle = "HKCU\" & strKey & "\" & strSKName & "\"

 

'if one of three targeted sub-keys

If LCase(strSKName) = "explorer" Or LCase(strSKName) = "shellbrowser" Or _

LCase(strSKName) = "webbrowser" Then

 

'get toolbar subkey values

oReg.EnumValues HKCU,strKey & "\" & strSKName,arSKValName,arType

 

'if array of values exists

If IsArray(arSKValName) Then

 

'for each value

For Each strValue in arSKValName

 

'assume not on allowed list

flagAllow = False

 

'is Toolbar on allowed list?

For j = 0 To UBound(arAllowedToolbars)

If arAllowedToolbars(j) = UCase(strValue) Then

flagAllow = True : Exit For 'toggle allowed flag

End If

Next

 

'if not allowed Or ShowAll

If Not flagAllow Or flagShowAll Then

 

flagTitle = False

 

For ctrCH = intCLL To 1

 

ResolveCLSID strValue, arHives(ctrCH,1), strCLSIDTitle, strIPSDLL

 

'if InProcServer32 value exists

If strIPSDLL <> "" Then

 

'output toolbar CLSID

If strSubSubTitle <> "" Then TitleLineWrite

If Not flagTitle Then

oFN.WriteLine DQ & strValue & DQ : flagTitle = True

End If

oFN.WriteLine " -> {" & arHives(ctrCH,0) & "...CLSID} = " &_

strCLSIDTitle & vbCRLF & Space(19) & "\InProcServer32\(Default) = " &_

StringFilter(strIPSDLL,True) & CoName(IDExe(strIPSDLL))

 

End If 'IPS exists?

 

Next

 

End If 'flagAllow Or ShowAll?

 

Next 'strValue

 

End If 'IsArray(arSKValName)?

 

End If 'targeted sub-key

 

Next 'toolbar sub-key

 

End If 'toolbar sub-key array exists

 

End If 'HKCU hive?

 

'if ShowAll, output title lines if not already done

If flagShowAll Then TitleLineWrite

 

Next 'hive

 

 

'Explorer Bars

 

strSubTitle = "Explorer Bars"

 

ReDim arAllowedExplorerBars(9) 'must be in upper case!

arAllowedExplorerBars(0) = "{30D02401-6A81-11D0-8274-00C04FD5AE38}" 'Search Band

arAllowedExplorerBars(1) = "{32683183-48A0-441B-A342-7C2A440A9478}" 'Media Band

arAllowedExplorerBars(2) = "{4D5C8C25-D075-11D0-B416-00C04FB90376}" '&Tip of the Day

arAllowedExplorerBars(3) = "{BDEADE7F-C265-11D0-BCED-00A0C90AB50F}" '&Discuss

arAllowedExplorerBars(4) = "{C4EE31F3-4768-11D2-BE5C-00A0C9A83DA1}" 'File and Folders Search ActiveX Control

arAllowedExplorerBars(5) = "{EFA24E61-B078-11D0-89E4-00C04FC9E26E}" 'Favorites Band

arAllowedExplorerBars(6) = "{EFA24E62-B078-11D0-89E4-00C04FC9E26E}" 'History Band

arAllowedExplorerBars(7) = "{EFA24E64-B078-11D0-89E4-00C04FC9E26E}" 'Explorer Band

arAllowedExplorerBars(8) = "{21569614-B795-46B1-85F4-E737A8DC09AD}" 'Search Band (WVa)

arAllowedExplorerBars(9) = "{5D60981B-2654-09E1-085A-6B546CA52169}" 'Favories Band (W98)

 

strKey = "Software\Microsoft\Internet Explorer\Explorer Bars"

 

'for HKCU & HKLM hives

For i = 0 To 1

 

strSubSubTitle = SOCA(arHives(i,0) & "\" & strKey & "\")

 

'get explorer bar subkeys

oReg.EnumKey arHives(i,1),strKey,arHKExplorerBars

 

'if subkeys exist

If IsArray(arHKExplorerBars) Then

 

'for each subkey

For Each strHKExplorerBar in arHKExplorerBars

 

'convert subkey name (CLSID) to uppercase

strHKExplorerBar= UCase(strHKExplorerBar)

 

'assume not on allowed list

flagAllow = False

 

'add to ListedExplorerBars array

ReDim Preserve arListedExplorerBars(cntExplorerBars)

arListedExplorerBars(cntExplorerBars) = strHKExplorerBar

cntExplorerBars = cntExplorerBars + 1 'cnt = UBound + 1

 

'is Explorer Bar on allowed list?

For j = 0 To UBound(arAllowedExplorerBars)

If arAllowedExplorerBars(j) = UCase(strHKExplorerBar) Then

flagAllow = True : Exit For 'toggle allowed flag

End If

Next

 

'if not allowed Or ShowAll

If Not flagAllow Or flagShowAll Then

 

flagTitle = False

 

CLSIDLocTitle arHives(i,1), strKey, strHKExplorerBar, strLocTitle

 

For ctrCH = intCLL To 1

 

ResolveCLSID strHKExplorerBar, arHives(ctrCH,1), strCLSIDTitle, strIPSDLL

 

'if InProcServer32 value exists

If strIPSDLL <> "" Then

 

'output explorer bar CLSID

If strSubSubTitle <> "" Then TitleLineWrite

 

If Not flagTitle Then

oFN.WriteLine strHKExplorerBar & "\(Default) = " & strLocTitle

flagTitle = True

End If

 

'output InProcServer32 value

oFN.WriteLine " -> {" & arHives(ctrCH,0) & "...CLSID} = " &_

strCLSIDTitle & vbCRLF & Space(19) & "\InProcServer32\(Default) = " &_

StringFilter(strIPSDLL,True) & CoName(IDExe(strIPSDLL))

 

End If 'IPS exists?

 

Next

 

End If 'not on allowed list Or ShowAll

 

Next 'HKCU/HKLM explorer bar subkey

 

End If 'explorer bar key has subkeys

 

'if ShowAll, output sub-title lines if not already done

If flagShowAll Then TitleLineWrite

 

Next 'hive

 

 

'check CLSIDs for Explorer Bars

 

Dim datDEBStart : datDEBStart = Now

 

strKey = "Software\Classes\CLSID"

 

For ctrCH = intCLL To 1

 

'get CLSIDs

oReg.EnumKey arHives(ctrCH,1),strKey,arCLSIDKeys

 

If IsArray(arCLSIDKeys) Then

 

'for each CLSID

For Each strCLSIDKey in arCLSIDKeys

 

'convert to uppercase

strCLSIDKey = UCase(strCLSIDKey)

 

'look for Implemented Categories subkeys

intErrNum = oReg.EnumKey (arHives(ctrCH,1),strKey & "\" & strCLSIDKey &_

"\Implemented Categories",arCLSIDImpCatSubKey)

 

'if Implemented Categories subkeys exist

If intErrNum = 0 And IsArray(arCLSIDImpCatSubKey) Then

 

'for each Implemented Categories subkey

For Each strImpCatSubKey in arCLSIDImpCatSubKey

 

'convert to uppercase

strImpCatSubKey = UCase(strImpCatSubKey)

 

'if subkey name is vertical or horizontal explorer bar

If strImpCatSubKey = "{00021494-0000-0000-C000-000000000046}" Or _

strImpCatSubKey = "{00021493-0000-0000-C000-000000000046}" Then

 

flagFound = False 'assume CLSID is not listed in HKCU/HKLM explorer bars

 

If IsArray(arListedExplorerBars) Then

 

'search explorer bar array for CLSID

For Each strArMember in arListedExplorerBars

If strArMember = strCLSIDKey Then

flagFound = True : Exit For

End If

Next

 

End If 'IsArray(arListedExplorerBars)?

 

'if CLSID not listed

If Not flagFound Then

 

'assume not allowed

flagAllow = False

 

'see if on allowed list

For j = 0 To UBound(arAllowedExplorerBars)

If arAllowedExplorerBars(j) = UCase(strCLSIDKey) Then

flagAllow = True : Exit For

End If

Next

 

'if not allowed Or ShowAll

If Not flagAllow Or flagShowAll Then

 

'look for InProcServer32

intErrNum3 = oReg.GetExpandedStringValue(arHives(ctrCH,1),"Software\Classes\CLSID\" &_

strCLSIDKey & "\InProcServer32","",strValue3)

 

'if InProcServer32 value exists

If intErrNum3 = 0 And strValue3 <> "" Then

 

'get CLSID title

oReg.GetStringValue arHives(ctrCH,1),"Software\Classes\CLSID\" &_

strCLSIDKey,"",strValue4

 

TitleLineWrite

 

'output CLSID + title, prepare output string,

'output Implemented Categories key, InProcServer32

If strValue4 <> "" Then

oFN.WriteLine vbCRLF & SOCA(arHives(ctrCH,0) & "\Software\Classes\CLSID\") &_

strCLSIDKey & "\(Default) = " & StringFilter(strValue4,True)

Else

oFN.WriteLine vbCRLF & SOCA(arHives(ctrCH,0) & "\Software\Classes\CLSID\") &_

strCLSIDKey & "\(Default) = (title not found)"

End If

If Mid(strImpCatSubKey,9,1) = "3" Then

strOut = " [vertical bar]"

Else

strOut = " [horizontal bar]"

End If

oFN.WriteLine "Implemented Categories\" & strImpCatSubKey & "\" & strOut

oFN.WriteLine "InProcServer32\(Default) = " &_

DQ & strvalue3 & DQ & CoName(IDExe(strValue3))

 

End If 'CLSID InProcServer32 exists?

 

End If 'CLSID not allowed Or ShowAll?

 

End If 'CLSID not already found in HKCU/HKLM?

 

End If 'strImpCatSubKey designates scroll bar?

 

Next 'arCLSIDImpCatSubKey

 

End If 'Implemented Categories sub-key exists?

 

Next 'CLSID sub-key

 

End If 'CLSID array exists?

 

Next 'CLSID hive

 

'determine -supp seconds used

Dim strDEBTime : strDEBTime = DateDiff("s",datDEBStart,Now) & " seconds"

 

 

 

 

'Extensions (Tools menu items, toolbar buttons)

 

strSubTitle = "Extensions (Tools menu items, main toolbar menu buttons)"

 

ReDim arAllowedExtensions(4) 'must be in upper case!

arAllowedExtensions(0) = "{438AFBA1-B0CB-11D2-9214-00104B3BCE5F}" '&Document Tree

arAllowedExtensions(1) = "{B06300D0-CCDE-11D2-92D3-0000F87A4A55}" 'Add to R&estricted Zone

arAllowedExtensions(2) = "{BF80219A-CCDD-11D2-92D3-0000F87A4A55}" 'Add to Tr&usted Zone

arAllowedExtensions(3) = "{C95FE080-8F5D-11D2-A20B-00AA003C157A}" 'Show &Related Links

arAllowedExtensions(4) = "{FC09D8A3-C85A-11D2-92D0-0000F87A4A55}" 'Offline

'{FB5F1910-F110-11D2-BB9E-00C04F795683} MSN Messenger Service

 

strKey = "Software\Microsoft\Internet Explorer\Extensions"

 

'for HKCU & HKLM hives

For i = 0 To 1

 

strSubSubTitle = SOCA(arHives(i,0) & "\" & strKey & "\")

 

'get extension subkeys

oReg.EnumKey arHives(i,1),strKey,arHKExtensions

 

'if subkeys exist

If IsArray(arHKExtensions) Then

 

'for each subkey

For Each strHKExtension in arHKExtensions

 

If Len(strHKExtension) = 38 And Left(strHKExtension,1) = "{" And _

Right(strHKExtension,1) = "}" Then

 

'convert subkey name (CLSID) to uppercase

strHKExtension= UCase(strHKExtension)

 

'assume not on allowed list

flagAllow = False

 

'is Extension on allowed list?

For j = 0 To UBound(arAllowedExtensions)

If arAllowedExtensions(j) = UCase(strHKExtension) Then

flagAllow = True : Exit For 'toggle allowed flag

End If

Next

 

'if not allowed Or ShowAll

If Not flagAllow Or flagShowAll Then

 

'look for ButtonText/MenuText/CLSIDExtension/Exec values

intErrNum1 = oReg.GetStringValue(arHives(i,1),strKey & "\" &_

strHKExtension,"ButtonText",strValue1)

intErrNum2 = oReg.GetStringValue(arHives(i,1),strKey & "\" &_

strHKExtension,"MenuText",strValue2)

intErrNum3 = oReg.GetStringValue(arHives(i,1),strKey & "\" &_

strHKExtension,"CLSIDExtension",strValue3)

intErrNum4 = oReg.GetStringValue(arHives(i,1),strKey &_

"\" & strHKExtension,"Script",strValue4)

intErrNum5 = oReg.GetStringValue(arHives(i,1),strKey &_

"\" & strHKExtension,"Exec",strValue5)

 

If strSubSubTitle <> "" Then

TitleLineWrite : oFN.WriteLine strHKExtension & "\"

Else

oFN.WriteLine vbCRLF & strHKExtension & "\"

End If

 

'most output is optional (on error, do nothing)

On Error Resume Next

If intErrNum1 = 0 And strValue1 <> "" Then _

oFN.WriteLine DQ & "ButtonText" & DQ & " = " &_

DQ & strValue1 & DQ

If intErrNum2 = 0 And strValue2 <> "" Then _

oFN.WriteLine DQ & "MenuText" & DQ & " = " & DQ &_

strValue2 & DQ

 

If intErrNum3 = 0 And strValue3 <> "" Then

 

Err.Clear 'required to reset Err if ButtonText or MenuText missing

 

flagTitle = False

For ctrCH = intCLL To 1

 

ResolveCLSID strValue3, arHives(ctrCH,1), strCLSIDTitle, strValue6

 

If Not flagTitle Then

oFN.WriteLine DQ & "CLSIDExtension" & DQ & " = " &_

DQ & strValue3 & DQ

flagTitle = True

End If

 

If strValue6 <> "" Then

oFN.WriteLine " -> {" & arHives(ctrCH,0) & "...CLSID} = " &_

strCLSIDTitle & vbCRLF & Space(19) & "\InProcServer32\(Default) = " &_

StringFilter(strValue6,True) & CoName(IDExe(strValue6))

End If

 

Next 'CLSID hive

 

End If 'CLSIDExtension value exists

 

If intErrNum4 = 0 And strValue4 <> "" Then oFN.WriteLine DQ &_

"Script" & DQ & " = " & DQ & strValue4 & DQ &_

CoName(IDExe(strValue4))

If intErrNum5 = 0 And strValue5 <> "" Then oFN.WriteLine DQ &_

"Exec" & DQ & " = " & DQ & strValue5 & DQ &_

CoName(IDExe(strValue5))

Err.Clear

On Error Goto 0

 

End If 'flagAllow Or flagAll?

 

End If 'CLSID format?

 

Next 'Extension subkey

 

End If 'Extension subkeys exist

 

'if ShowAll, output sub-title lines if not already done

If flagShowAll Then TitleLineWrite

 

Next 'hive

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

'recover array memory

ReDim arCLSIDKeys(0)

ReDim arCLSIDImpCatSubKey(0)

ReDim arExplorerBars(0)

ReDim arAllowedExplorerBars(0)

ReDim arListedExplorerBars(0)

ReDim arHKExtensions(0)

ReDim arAllowedExtensions(0)

ReDim arAllowedToolbars(0)

ReDim arHKCUTbSK(0)

ReDim arSKValName(0)

ReDim arHKToolbarVals(0)

 

End If 'SecTest?

 

 

 

 

'#24. Internet Explorer URL Prefixes

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

strTitle = "Internet Explorer Address Prefixes:"

 

'prefix used if bare domain ("microsoft.com") entered into IE address box

strKey = "Software\Microsoft\Windows\CurrentVersion\URL"

 

strSubTitle = "Prefix for bare domain (" & DQ &_

"domain-name-here.com" & DQ & ")" & vbCRLF & vbCRLF &_

SOCA("HKLM\" & strKey & "\Default Prefix\")

 

'get DefaultPrefix default value

intErrNum = oReg.GetStringValue (HKLM,strKey & "\DefaultPrefix","",strValue)

 

'assume not infected

strWarn = ""

 

'value exists and is not empty

If intErrNum = 0 And strValue <> "" Then

 

'if default value not OK, toggle warning & flagHWarn

If Trim(LCase(strValue)) <> "http://" Then

strWarn = HWarn : flagHWarn = True

End If

 

If strWarn <> "" Or flagShowAll Then

 

TitleLineWrite : oFN.Writeline strWarn & "(Default) = " &_

StringFilter(strValue,True)

 

End If

 

Else 'value doesn't exist

 

If flagShowAll Then

TitleLineWrite

oFN.WriteLine "(Default) = (value not set)"

End If

 

End If 'default value exists?

 

 

'prefix used with specific service

'2 x 5 array

Dim arPrefix()

ReDim arPrefix(1,4)

arPrefix(0,0) = "ftp" : arPrefix(1,0) = "ftp://"

arPrefix(0,1) = "gopher" : arPrefix(1,1) = "gopher://"

arPrefix(0,2) = "home" : arPrefix(1,2) = "http://"

arPrefix(0,3) = "mosaic" : arPrefix(1,3) = "http://"

arPrefix(0,4) = "www" : arPrefix(1,4) = "http://"

 

'find all the names in the key

intErrNum1 = oReg.EnumValues (HKLM, strKey & "\Prefixes", arNames, arType)

 

strSubTitle = "Prefix for specific service (i.e., " & DQ & "www" &_

DQ & ")" & vbCRLF & vbCRLF & SOCA("HKLM\" & strKey & "\Prefixes\")

 

'enumerate data if present

If intErrNum1 = 0 And IsArray(arNames) Then

 

'for each name

For Each strName in arNames

 

'assume infected

flagMatch = False : strWarn = HWarn

 

'for each prefix type

For i = 0 To UBound(arPrefix,2)

 

'if name = prefix Or name = prefix.

If Trim(LCase(strName)) = arPrefix(0,i) Or _

Trim(LCase(strName)) = arPrefix(0,i) & "." Then

 

'get value

intErrNum2 = oReg.GetStringValue(HKLM,strKey & "\Prefixes", _

strName,strValue)

 

'if value exists (exc. for W2K!)

If intErrNum2 = 0 And strValue <> "" Then

 

'toggle flags if value = default value

If Trim(LCase(strValue)) = arPrefix(1,i) Then

flagMatch = True : strWarn = "" : Exit For

End If 'value = arPrefix member?

 

End If 'strValue exists And not empty?

 

End If 'name = arPrefix member?

 

Next 'arPrefix member

 

'get value if name not in arPrefix

If Not flagMatch Then oReg.GetStringValue HKLM, _

strKey & "\Prefixes",strName,strValue

 

'output if flagMatch Or flagShowAll

If Not flagMatch Or flagShowAll Then

 

TitleLineWrite

 

If strWarn <> "" Then flagHWarn = True

 

On Error Resume Next

 

'output warning, name, value

oFN.WriteLine strWarn & StringFilter(strName,True) & " = " &_

DQ & strValue & DQ

intErrNum = Err.Number : Err.Clear

'error check for W2K if value not set

If intErrNum <> 0 Then oFN.WriteLine StringFilter(strName,True) &_

" = (value not set)"

 

On Error Goto 0

 

End If 'flagMatch or flagShowAll?

 

Next 'prefix key name array member

 

If strSubTitle <> "" And flagShowAll Then

TitleLineWrite : oFN.WriteLine "(values not found)"

End If

 

Else 'prefix key name array doesn't exist

 

If flagShowAll Then

TitleLineWrite : oFN.WriteLine "(values not found)"

End If

 

End If 'prefix key name array exists

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

'recover array memory

ReDim arPrefix(0,0)

 

End If 'SecTest?

[MAcgYvER everyONE 0]

'#25. Misc. IE Hijack Points

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

'IERESET Text File, IERESET file name, INF-file section name,

'array of count of missing phrase lines by section

Dim oIERTF, strSection, arSectionCount(), intTFF

Dim intAsc1Chr, intAsc2Chr 'ASCII code of 1st & 2nd chr of IERESET.INF

'zero-based number of sections in phrase array with lines missing from disk file

Public intSectionCount : intSectionCount = -1

'one-based number of lines in each section of phrase array with lines missing from disk file

Public intSectionLineCount : intSectionLineCount = 0

 

strTitle = "Miscellaneous IE Hijack Points"

strWarn = HWarn

 

'parse IERESET.INF, look for added and missing lines

Dim strIERFN : strIERFN = UCase(strFPWF) & "\INF\IERESET.INF"

 

'read the IE version from the registry

 

'IE version reg value, work string

Dim strIELVer, strIELVWK

'short string version, non-numeric if dec symbol not "."

Dim strIEShVer : strIEShVer = "0"

'numeric IE version: 0 if IE version not in registry or value not set

'otherwise, number using single local dec symbol

Dim intIELVer : intIELVer = 0

Dim strDecSym : strDecSym = "." 'dec symbol

 

strKey = "Software\Microsoft\Internet Explorer"

intErrNum = oReg.GetStringValue(HKLM,strKey,"Version",strIELVer)

 

strSubTitle = SOCA("HKLM\" & strKey & "\Version = " & strIELVer)

strSubSubTitle = strIERFN & " (used to " & DQ & "Reset Web " &_

"Settings" & DQ & ")"

 

'in W2K, if value not set, strIELVer will be garbage

If intErrNum = 0 And Len(Trim(strIELVer)) > 3 Then

 

'read the decimal symbol from the registry

strKey1 = "Control Panel\International"

intErrNum1 = oReg.GetStringValue(HKCU,strKey1,"sDecimal",strValue1)

'if the symbol exists, store it

If intErrNum1 = 0 And strValue1 <> "" Then strDecSym = strValue1

 

'replace 1st dec pt in the IE ver with XXX

strIELVWK = Replace (Trim(strIELVer),".","XXX",1,1,1)

'delete all succeeding dec pts

strIELVWK = Replace (Trim(strIELVWK),".","",1,-1,1)

'restore dec symbol to pos'n of first dec pt and call it an integer

intIELVer = Replace (Trim(strIELVWK),"XXX",strDecSym,1,1,1)

 

If IsNumeric(intIELVer) Then 'should exclude W2K value not set garbage

 

strIEShVer = Left(LTrim(strIELVer),3)

 

If strIEShVer <> "5.5" Then 'for 5.5, retain 3 chrs

 

'use left-most chr

strIEShVer = Left(LTrim(strIELVer),1)

 

'if IE ver < 5, advise that INF file doesn't exist

If intIELVer < 5 Then

TitleLineWrite

oFN.WriteLine vbCRLF & "IERESET.INF does not exist for this Internet " &_

"Explorer version."

End If 'intIELVer<5?

 

End If 'strIEShVer=5.5?

 

Else 'intIELVer not numeric, so advise about bad IE version and reset to 0

 

strSubTitle = "HKLM\" & strKey & "\Version = (invalid data)" &_

vbCRLF & "The Internet Explorer version cannot be found!"

TitleLineWrite

oFN.WriteLine "The contents of IERESET.INF cannot be reliably checked!"

intIELVer = 0

 

End If 'intIELVer numeric?

 

Else 'IE ver not found or value corrupt

 

strSubTitle = SOCA("HKLM\" & strKey & "\Version = (invalid data)" &_

vbCRLF & "The Internet Explorer version cannot be found!")

TitleLineWrite

oFN.WriteLine "The contents of IERESET.INF cannot be reliably checked!"

 

End If 'IE ver exists?

 

'change titles if not already written

If strTitle <> "" Then

strSubTitle = strIERFN & " (used to " & DQ & "Reset Web Settings" &_

DQ & ")"

strSubSubTitle = ""

End If

 

If strIEShVer <> "7" Then 'IE 7

 

Dim arIER() 'common IERESET.INF lines & phrases

ReDim arIER(31,2) 'section, phrase, found-in-file-on-disk?

arIER(0,0)="[Version]" : arIER(0,1)="Signature=""$CHICAGO$"""

arIER(1,0)="[Version]" : arIER(1,1)="AdvancedINF=2.5,""You need a new version of advpack.dll"""

arIER(2,0)="[RestoreHomePage]" : arIER(2,1)="AddReg=RestoreHomePage.reg"

arIER(3,0)="[RestoreHomePage.reg]" : arIER(3,1)="HKCU,""Software\Microsoft\Internet Explorer\Main"",""Start Page"",0,%START_PAGE_URL%"

arIER(4,0)="[RestoreBrowserSettings.reg]" : arIER(4,1)="HKLM,""Software\Microsoft\Internet Explorer\Main"",""Default_Page_URL"",0,%START_PAGE_URL%"

arIER(5,0)="[RestoreBrowserSettings.reg]" : arIER(5,1)="HKLM,""Software\Microsoft\Internet Explorer\Main"",""Default_Search_URL"",0,%SEARCH_PAGE_URL%"

arIER(6,0)="[RestoreBrowserSettings.reg]" : arIER(6,1)="HKLM,""Software\Microsoft\Internet Explorer\Main"",""Search Page"",0,%SEARCH_PAGE_URL%"

arIER(7,0)="[RestoreBrowserSettings.reg]" : arIER(7,1)="HKLM,""Software\Microsoft\Internet Explorer\Main\UrlTemplate"",""1"",0,""www.%s.com"""

arIER(8,0)="[RestoreBrowserSettings.reg]" : arIER(8,1)="HKLM,""Software\Microsoft\Internet Explorer\Main\UrlTemplate"",""2"",0,""www.%s.org"""

arIER(9,0)="[RestoreBrowserSettings.reg]" : arIER(9,1)="HKLM,""Software\Microsoft\Internet Explorer\Main\UrlTemplate"",""3"",0,""www.%s.net"""

arIER(10,0)="[RestoreBrowserSettings.reg]" : arIER(10,1)="HKLM,""Software\Microsoft\Internet Explorer\Main\UrlTemplate"",""4"",0,""www.%s.edu"""

arIER(11,0)="[RestoreBrowserSettings.reg]" : arIER(11,1)="HKCU,""Software\Microsoft\Internet Explorer\Main"",""Search Page"",0,%SEARCH_PAGE_URL%"

arIER(12,0)="[RestoreBrowserSettings.reg]" : arIER(12,1)="HKCU,""Software\Microsoft\Internet Explorer\SearchUrl"",""Provider"",0,"""""

arIER(13,0)="[RestoreBrowserSettings.reg]" : arIER(13,1)="HKLM,""Software\Microsoft\Internet Explorer\Search"",""SearchAssistant"",0,""http://ie.search.msn.com/{SUB_RFC1766}/srchasst/srchasst.htm"""

arIER(14,0)="[RestoreBrowserSettings.reg]" : arIER(14,1)="HKLM,""Software\Microsoft\Internet Explorer\Search"",""CustomizeSearch"",0,""http://ie.search.msn.com/{SUB_RFC1766}/srchasst/srchcust.htm"""

arIER(15,0)="[RestoreBrowserSettings.reg]" : arIER(15,1)="HKLM,""Software\Microsoft\Windows\CurrentVersion\Internet Settings\SafeSites"",%SAFESITE_VALUE%,0,""http://ie.search.msn.com/*"""

arIER(16,0)="[DeleteTemplates.reg]" : arIER(16,1)="HKLM,""Software\Microsoft\Internet Explorer\Main\UrlTemplate"",""5"""

arIER(17,0)="[DeleteTemplates.reg]" : arIER(17,1)="HKLM,""Software\Microsoft\Internet Explorer\Main\UrlTemplate"",""6"""

arIER(18,0)="[DeleteTemplates.reg]" : arIER(18,1)="HKLM,""Software\Microsoft\Internet Explorer\Main\UrlTemplate"",""7"""

arIER(19,0)="[DeleteTemplates.reg]" : arIER(19,1)="HKLM,""Software\Microsoft\Internet Explorer\Main\UrlTemplate"",""8"""

arIER(20,0)="[DeleteTemplates.reg]" : arIER(20,1)="HKLM,""Software\Microsoft\Internet Explorer\Main\UrlTemplate"",""9"""

arIER(21,0)="[DeleteAutosearch.reg]" : arIER(21,1)="HKCU,""Software\Microsoft\Internet Explorer\Main"",""AutoSearch"""

arIER(22,0)="[strings]" : arIER(22,1)="SEARCH_PAGE_URL=""http://www.microsoft.com/isapi/redir.dll?prd=ie&ar=iesearch"""

arIER(23,0)="[RestoreBrowserSettings]" : arIER(23,1)="AddReg=RestoreBrowserSettings.reg"

 

arIER(24,0)="[RestoreBrowserSettings]" : arIER(24,1)="DelReg=DeleteTemplates.reg"

arIER(25,0)="[RestoreBrowserSettings]" : arIER(25,1)="DelReg=DeleteTemplates.reg, DeleteAutosearch.reg"

arIER(26,0)="[strings]" : arIER(26,1)="START_PAGE_URL=""http://www.microsoft.com/isapi/redir.dll?prd=ie&pver=" & strIEShVer & "&ar=msnhome"""

arIER(27,0)="[strings]" : arIER(27,1)="START_PAGE_URL=""http://www.msn.com"""

arIER(28,0)="[strings]" : arIER(28,1)="SAFESITE_VALUE=""http://home.microsoft.com/"""

arIER(29,0)="[strings]" : arIER(29,1)="SAFESITE_VALUE=""ie.search.msn.com"""

arIER(30,0)="[strings]" : arIER(30,1)="MS_START_PAGE_URL=""http://www.microsoft.com/isapi/redir.dll?prd=ie&pver=" & strIEShVer & "&ar=msnhome"""

arIER(31,0)="[strings]" : arIER(31,1)="MS_START_PAGE_URL=""http://www.msn.com"""

 

'set found-in-file-on-disk flag to False

For i = 0 To UBound(arIER,1) : arIER(i,2) = False : Next

 

'if IERESET.INF exists

If Fso.FileExists(strIERFN) Then

 

'open the file for reading/don't create/ASCII format

Set oIERTF = Fso.OpenTextFile (strIERFN,1,False,0)

 

'get the file size

Dim intFileSize : intFileSize = Fso.GetFile(strIERFN).Size

 

If intFileSize > 100 Then

 

'read 1st 2 chrs, find Asc code (not AscW code)

intAsc1Chr = Asc(oIERTF.Read(1)) : intAsc2Chr = Asc(oIERTF.Read(1))

 

oIERTF.Close

 

'if Asc codes = 255 & 254, file is Unicode

'ASCII file read as Unicode: 1st Unicode line is entire file

'Unicode file read as ASCII: 1st ASCII line is variable length

'TriStateDefault appears to distinguish between ASCII & Unicode on file open

'VBS internally allots 2 bytes per ASCII chr

 

intTFF = 0 'ASCII fmt

If intAsc1Chr = 255 And intAsc2Chr = 254 Then intTFF = -1 'Unicode fmt

 

Set oIERTF = Fso.OpenTextFile (strIERFN,1,False,intTFF)

 

strSubSubTitle = "Added lines (compared with English-language version):"

 

flagInfect = False

 

'for each line

Do Until oIERTF.AtEndOfStream

 

strLine = Trim(oIERTF.ReadLine) 'read a line

 

flagMatch = False 'line doesn't match phrase array

 

'if line not empty And not a comment

If Len(strLine) > 0 And Left(strLine,1) <> ";" Then

 

If Left(strLine,1) = "[" Then 'if line is section title

 

strSection = strLine 'save the section name

 

Else 'line not a section title, so it's a data line

 

For i = 0 To UBound(arIER,1) 'for every line in phrase array

 

'if section's identical and phrase found in line,

'toggle line match flag & found-in-file-on-disk flag

If LCase(arIER(i,0)) = LCase(strSection) And _

LCase(strLine) = LCase(arIER(i,1)) Then

flagMatch = True : arIER(i,2) = True : Exit For

Exit For

End If

 

Next

 

If Not flagMatch Then 'if line not matched

flagInfect = True

TitleLineWrite

On Error Resume Next

'output section name & line

oFN.WriteLine strSection & ": " & strLine

intErrNum = Err.Number : Err.Clear

On Error Goto 0

If intErrNum <> 0 Then oFN.WriteLine "(unwritable string)"

End If 'line matched?

 

End If 'section title line?

 

End If 'data line?

 

Loop 'next file line

 

'close IERESET.INf

oIERTF.Close : Set oIERTF=Nothing

 

'initialize section title for phrases missing from file

strSection = ""

strSubSubTitle = "Missing lines (compared with English-language version):"

flagFound = True 'False if found-in-file-on-disk = False

 

For i = 0 To 23 'for single-option phrases

If Not arIER(i,2) Then

flagFound = False : flagInfect = True 'toggle flags

'increment counters

IERESETCounter strSection, arIER(i,0), arSectionCount

End If

Next 'single-option phrase

 

'check double-option phrases

For i = 24 To 30 Step 2

'if neither option found-in-file-on-disk

If Not arIER(i,2) And Not arIER(i+1,2) Then

flagFound = False : flagInfect = True 'toggle flags

'increment counters

IERESETCounter strSection, arIER(i,0), arSectionCount

End If

Next 'double-option phrase

 

If Not flagFound Then 'if lines missing

 

TitleLineWrite

 

'output contents of arSectionCount (section title: # missing lines)

For i = 0 To UBound(arSectionCount,2)

strOut = " line"

If arSectionCount(1,i) > 1 Then strOut = " lines"

oFN.WriteLine arSectionCount(0,i) & ": " & arSectionCount(1,i) & strOut

Next

 

End If 'lines missing?

 

strSubSubTitle = "" 'reset title line (no longer needed)

 

If strTitle <> "" And flagShowAll Then

strSubTitle = strIERFN & " (used to " & DQ &_

"Reset Web Settings" & DQ & " -- no anomalies found)"

TitleLineWrite

End If

 

Else 'IERESET.INF<100 bytes

 

oIERTF.Close

 

'file should always exist if IE ver > 5 Or if in one of these OS's

If intIELVer > 5 Or strOS = "WXP" Or strOS = "W2K" Or strOS = "WME" Then

 

TitleLineWrite

oFN.WriteLine strWarn & strIERFN & " is *much* too small and is " &_

"probably corrupt!"

flagHWarn = True

 

End If 'should file exist?

 

End If 'IERSET.INF>100 bytes?

 

Else 'IERESET.INF not found

 

'file should always exist if IE ver > 5 Or if in one of these OS's

If intIELVer > 5 Or strOS = "WXP" Or strOS = "W2K" Or strOS = "WME" Then

 

TitleLineWrite

oFN.WriteLine strWarn & strIERFN & " was not found!"

flagHWarn = True

 

End If 'should file exist?

 

End If 'IERESET.INF found?

 

End If 'strIEShVer<>7?

 

'URLSearchHooks

strKey = "Software\Microsoft\Internet Explorer\URLSearchHooks"

strSubTitle = "HKCU\" & strKey & "\"

 

intErrNum = oReg.EnumValues (HKCU, strKey, arNames, arType)

 

If IsArray(arNames) Then

 

For Each strCLSID In arNames

 

If UCase(strCLSID) <> "{CFBFAE00-17A6-11D0-99CB-00C04FD64497}" Or _

flagShowAll Then

 

flagTitle = False

 

CLSIDLocTitle HKCU, strKey, strCLSID, strLocTitle

 

For ctrCH = intCLL To 1

 

ResolveCLSID strCLSID, arHives(ctrCH,1), strCLSIDTitle, strIPSDLL

 

If strIPSDLL <> "" Then

 

strWarn = ""

If UCase(strCLSID) <> "{CFBFAE00-17A6-11D0-99CB-00C04FD64497}" Then

strWarn = HWarn : flagHWarn = True

End If

 

TitleLineWrite

 

If Not flagTitle Then

oFN.WriteLine strWarn & DQ & strCLSID & DQ & " = " & strLocTitle

flagTitle = True

End If

 

oFN.WriteLine " -> {" & arHives(ctrCH,0) & "...CLSID} = " &_

strCLSIDTitle & vbCRLF & Space(19) & "\InProcServer32\(Default) = " &_

StringFilter(strIPSDLL,True) & CoName(IDExe(strIPSDLL))

 

End If 'IPS exists?

 

Next 'CLSID hive

 

End If 'match Or flagShowAll?

 

Next 'strCLSID

 

Else

 

If flagShowAll Then

TitleLineWrite

oFN.WriteLine "(URLSearchHooks key not found!)"

End If

 

End If 'IsArray?

 

 

'AboutURLs

strKey = "Software\Microsoft\Internet Explorer\AboutURLs"

strSubTitle = SOCA("HKLM\" & strKey & "\")

 

EnumNVP HKLM, strKey, arNames, arType

 

If flagNVP Then 'name/value pairs exist

 

Set arSK = CreateObject("Scripting.Dictionary") 'key, item

 

'add dictionary pairs (universal elements)

arSK.Add "blank", "res://mshtml.dll/blank.htm"

arSK.Add "Home", "dword:0x0000010E"

arSK.Add "mozilla", "res://mshtml.dll/about.moz"

 

'value not set or IE 5-7

If intIELVer >= 7 Then 'IE 7

arSK.Add "DesktopItemNavigationFailure", "res://ieframe.dll/navcancl.htm"

arSK.Add "NavigationCanceled", "res://ieframe.dll/navcancl.htm"

arSK.Add "NavigationFailure", "res://ieframe.dll/navcancl.htm"

arSK.Add "OfflineInformation", "res://ieframe.dll/offcancl.htm"

arSK.Add "NoAdd-ons", "res://ieframe.dll/noaddon.htm"

arSK.Add "NoAdd-onsInfo", "res://ieframe.dll/noaddoninfo.htm"

arSK.Add "PostNotCached", "res://ieframe.dll/repost.htm"

arSK.Add "SecurityRisk", "res://ieframe.dll/securityatrisk.htm"

arSK.Add "Tabs", "res://ieframe.dll/tabswelcome.htm"

ElseIf intIELVer = 0 Or intIELVer >= 5 Then

arSK.Add "DesktopItemNavigationFailure", "res://shdoclc.dll/navcancl.htm"

arSK.Add "NavigationCanceled", "res://shdoclc.dll/navcancl.htm"

arSK.Add "NavigationFailure", "res://shdoclc.dll/navcancl.htm"

arSK.Add "OfflineInformation", "res://shdoclc.dll/offcancl.htm"

arSK.Add "PostNotCached", "res://mshtml.dll/repost.htm"

Else 'IE < 5

arSK.Add "DesktopItemNavigationFailure", "res://shdocvw.dll/navcancl.htm"

arSK.Add "NavigationCanceled", "res://shdocvw.dll/navcancl.htm"

arSK.Add "NavigationFailure", "res://shdocvw.dll/navcancl.htm"

arSK.Add "OfflineInformation", "res://shdocvw.dll/offcancl.htm"

arSK.Add "PostNotCached", "res://mshtml.dll/repost.htm"

End If 'IE>7?

 

arSKk = arSK.Keys : arSKi = arSK.Items

 

For i = 0 To UBound(arNames)

 

strWarn = HWarn

 

'use the type to find the value

strValue = RtnValue (HKLM, strKey, arNames(i), arType(i))

 

For j = 0 To arSK.Count-1

 

flagFound = False

 

If LCase(arNames(i)) = LCase(arSKk(j)) And _

LCase(strValue) = LCase(arSKi(j)) Then

flagFound = True : strWarn = "" : Exit For

End If

 

Next 'dictionary pair

 

If Not flagFound Or flagShowAll Then

 

TitleLineWrite

WriteValueData arNames(i), strValue, arType(i), strWarn

If strWarn <> "" Then flagHWarn = True

 

End If

 

Next 'arNames member

 

arSK.RemoveAll : Set arSK=Nothing 'recover dictionary memory

 

Else

 

If flagShowAll Then

TitleLineWrite

oFN.WriteLine "(AboutURLs key not found!)"

End If

 

End If 'flagNVP?

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

End If 'SecTest?

 

 

 

 

'#26. HOSTS file

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

'left-trimmed HOSTS line, IP address, HOSTS Path, tab pos'n, space pos'n

Dim strLineWk, strIP, strHP, intTabPosn, intSpacePosn

Dim intWSPosn : intWSPosn = 0 'white space posn

Dim intMapCtr : intMapCtr = 0 'map ctr

Dim intNLHMapCtr : intNLHMapCtr = 0 'non-localhost map ctr

 

'prepare section title

strTitle = "HOSTS file"

 

'determine HOSTS file location

If strOS <> "W98" And strOS <> "WME" Then

 

'find HOSTS directory from registry, compare to default value

strKey = "SYSTEM\CurrentControlSet\Services\Tcpip\Parameters"

intErrNum = oReg.GetExpandedStringValue (HKLM,strKey,"DataBasePath",strValue)

 

'if registry value exists

If intErrNum = 0 And strValue <> "" Then

 

'trim it & expand path string

strTmp = Wshso.ExpandEnvironmentStrings(Trim(strValue))

'lop off trailing backslash

If Right(strTmp,1) = "\" Then strTmp = Left(strTmp,Len(strTmp)-1)

 

'set HOSTS path from registry value

strHP = strTmp & "\HOSTS"

 

'output warning if not identical to default value

strWarn = ""

If LCase(strTmp) <> LCase(strFPSF) & "\drivers\etc" Then

strWarn = HWarn : flagHWarn = True

End If

 

If LCase(strTmp) <> LCase(strFPSF) & "\drivers\etc" Or flagShowAll Then

 

TitleLineWrite

 

oFN.WriteLine vbCRLF & "HKLM\" & strKey & "\" & vbCRLF & strWarn &_

DQ & "DataBasePath" & DQ & " = " & DQ & strValue &_

DQ

 

End If 'value <> default?

 

Else 'registry value doesn't exist

 

'set HOSTS location to default

strHP = strFPSF & "\Drivers\Etc\HOSTS"

 

End If 'HOSTS directory registry value exists?

 

Else 'W98/WMe

 

strHP = strFPWF & "\HOSTS"

 

End If 'O/S?

 

'if HOSTS exists

If Fso.FileExists(strHP) Then

 

'open it for reading

Set oSCF = Fso.OpenTextFile (strHP,1)

 

Do While Not oSCF.AtEndOfStream

 

'read a line

strLine = oSCF.ReadLine

strLineWk = Trim(strLine) 'trim the line

 

'if line not CR And not a comment

If Len(strLineWk) > 0 And InStr(1,strLineWk,"#",1) <> 1 Then

 

'increment the mapped domain name count

intMapCtr = intMapCtr + 1

 

'find an interior space/tab

intSpacePosn = InStr(1,strLineWk," ",1)

intTabPosn = InStr(1,strLineWk,Chr(09),1)

 

If intSpacePosn > 0 Then intWSPosn = intSpacePosn

If intSpacePosn = 0 Or (intTabPosn > 0 And intTabPosn < intSpacePosn) _

Then intWSPosn = intTabPosn

 

'if a space or tab exists

If intWSPosn > 0 Then

 

'extract the IP address left of the space

strIP = Left(strLineWk,intWSPosn-1)

 

'if not localhost, increment the mapped non localhost count

If strIP <> "127.0.0.1" And strIP <> "::1" Then

intNLHMapCtr = intNLHMapCtr + 1 : TitleLineWrite

End If

 

End If 'line has embedded space?

 

End If 'line not CR/comment?

 

Loop 'read another line

 

oSCF.Close : Set oSCF=Nothing

 

'output if more than one IP mapped Or any IP mapped to non-localhost

'Or ShowAll

If (intMapCtr >= 1 And intNLHMapCtr > 0) Or flagShowAll Then

 

'set up output strings

 

'total number of mappings

If intMapCtr = 0 Then 'none

strOut1 = "maps: no domain names to IP addresses"

ElseIf intMapCtr = 1 Then 'one

strOut1 = "maps: 1 domain name to an IP address," & vbCRLF

Else '> 1

strOut1 = "maps: " & intMapCtr &_

" domain names to IP addresses," & vbCRLF

End If

 

'non-localhost mappings

If intNLHMapCtr = 0 Then 'none

If intMapCtr = 0 Then 'no maps found

strOut2 = ""

ElseIf intMapCtr = 1 Then 'one map found

strOut2 = Space(6) & "and this is the localhost IP address"

Else

strOut2 = Space(6) & "and all are the localhost IP address" '> 1 map found

End If

ElseIf intNLHMapCtr = 1 Then 'one

strOut2 = Space(6) & "1 of the IP addresses is *not* localhost!"

Else '> 1

strOut2 = Space(6) & intNLHMapCtr & " of the IP addresses are *not* localhost!"

End If

 

'output mapped & non-localhost counts

TitleLineWrite

 

oFN.WriteLine vbCRLF & strHP & vbCRLF & vbCRLF & strOut1 & strOut2

 

End If '>= 1 IP mapped And at least 1 IP mapped to non-localhost

 

Else 'HOSTS doesn't exist

 

If flagShowAll Then

 

TitleLineWrite

'say file not found

oFN.WriteLine vbCRLF & strHP & " (file not found)"

 

End If 'flagShowAll?

 

End If 'HOSTS exists?

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

End If 'SecTest?

 

 

 

 

'#27. Started Services

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

'for NT-type O/S's

If strOS <> "W98" And strOS <> "WME" Then

 

'MS default services array, subscript number in MS default services array

'CoName string, optionally quote-delimited path name

Dim arMSSvc(), intMSSvcNo, strExeName, strPathNameOut

 

'set up MS default services array for WVa/WXP/W2K/NT4

'service name, service executable, DLL file name for svchost.exe-dependent service

 

If strOS = "WXP" Then

 

ReDim arMSSvc(93,2)

arMSSvc(0,0) = "alerter" : arMSSvc(0,1) = "svchost.exe" : arMSSvc(0,2) = "alrsvc.dll"

arMSSvc(1,0) = "alg" : arMSSvc(1,1) = "alg.exe" : arMSSvc(1,2) = ""

arMSSvc(2,0) = "appmgmt" : arMSSvc(2,1) = "svchost.exe" : arMSSvc(2,2) = "appmgmts.dll"

arMSSvc(3,0) = "wuauserv" : arMSSvc(3,1) = "svchost.exe" : arMSSvc(3,2) = "wuauserv.dll"

arMSSvc(4,0) = "bits" : arMSSvc(4,1) = "svchost.exe" : arMSSvc(4,2) = "qmgr.dll"

arMSSvc(5,0) = "clipsrv" : arMSSvc(5,1) = "clipsrv.exe" : arMSSvc(5,2) = ""

arMSSvc(6,0) = "eventsystem" : arMSSvc(6,1) = "svchost.exe" : arMSSvc(6,2) = "es.dll"

arMSSvc(7,0) = "comsysapp" : arMSSvc(7,1) = "dllhost.exe" : arMSSvc(7,2) = ""

arMSSvc(8,0) = "browser" : arMSSvc(8,1) = "svchost.exe" : arMSSvc(8,2) = "browser.dll"

arMSSvc(9,0) = "cryptsvc" : arMSSvc(9,1) = "svchost.exe" : arMSSvc(9,2) = "cryptsvc.dll"

arMSSvc(10,0) = "dhcp" : arMSSvc(10,1) = "svchost.exe" : arMSSvc(10,2) = "dhcpcsvc.dll"

arMSSvc(11,0) = "trkwks" : arMSSvc(11,1) = "svchost.exe" : arMSSvc(11,2) = "trkwks.dll"

arMSSvc(12,0) = "msdtc" : arMSSvc(12,1) = "msdtc.exe" : arMSSvc(12,2) = ""

arMSSvc(13,0) = "dnscache" : arMSSvc(13,1) = "svchost.exe" : arMSSvc(13,2) = "dnsrslvr.dll"

arMSSvc(14,0) = "eventlog" : arMSSvc(14,1) = "services.exe" : arMSSvc(14,2) = ""

arMSSvc(15,0) = "ersvc" : arMSSvc(15,1) = "svchost.exe" : arMSSvc(15,2) = "ersvc.dll"

arMSSvc(16,0) = "fastuserswitchingcompatibility" : arMSSvc(16,1) = "svchost.exe" : arMSSvc(16,2) = "shsvcs.dll"

arMSSvc(17,0) = "helpsvc" : arMSSvc(17,1) = "svchost.exe" : arMSSvc(17,2) = "pchsvc.dll"

arMSSvc(18,0) = "hidserv" : arMSSvc(18,1) = "svchost.exe" : arMSSvc(18,2) = "hidserv.dll"

arMSSvc(19,0) = "imapiservice" : arMSSvc(19,1) = "imapi.exe" : arMSSvc(19,2) = ""

arMSSvc(20,0) = "iisadmin" : arMSSvc(20,1) = "inetinfo.exe" : arMSSvc(20,2) = ""

arMSSvc(21,0) = "cisvc" : arMSSvc(21,1) = "cisvc.exe" : arMSSvc(21,2) = ""

arMSSvc(22,0) = "sharedaccess" : arMSSvc(22,1) = "svchost.exe" : arMSSvc(22,2) = "ipnathlp.dll"

arMSSvc(23,0) = "policyagent" : arMSSvc(23,1) = "lsass.exe" : arMSSvc(23,2) = ""

arMSSvc(24,0) = "dmserver" : arMSSvc(24,1) = "svchost.exe" : arMSSvc(24,2) = "dmserver.dll"

arMSSvc(25,0) = "dmadmin" : arMSSvc(25,1) = "dmadmin.exe" : arMSSvc(25,2) = ""

arMSSvc(26,0) = "messenger" : arMSSvc(26,1) = "svchost.exe" : arMSSvc(26,2) = "msgsvc.dll"

arMSSvc(27,0) = "swprv" : arMSSvc(27,1) = "dllhost.exe" : arMSSvc(27,2) = ""

arMSSvc(28,0) = "netlogon" : arMSSvc(28,1) = "lsass.exe" : arMSSvc(28,2) = ""

arMSSvc(29,0) = "mnmsrvc" : arMSSvc(29,1) = "mnmsrvc.exe" : arMSSvc(29,2) = ""

arMSSvc(30,0) = "netman" : arMSSvc(30,1) = "svchost.exe" : arMSSvc(30,2) = "netman.dll"

arMSSvc(31,0) = "netdde" : arMSSvc(31,1) = "netdde.exe" : arMSSvc(31,2) = ""

arMSSvc(32,0) = "netddedsdm" : arMSSvc(32,1) = "netdde.exe" : arMSSvc(32,2) = ""

arMSSvc(33,0) = "nla" : arMSSvc(33,1) = "svchost.exe" : arMSSvc(33,2) = "mswsock.dll"

arMSSvc(34,0) = "ntlmssp" : arMSSvc(34,1) = "lsass.exe" : arMSSvc(34,2) = ""

arMSSvc(35,0) = "sysmonlog" : arMSSvc(35,1) = "smlogsvc.exe" : arMSSvc(35,2) = ""

arMSSvc(36,0) = "plugplay" : arMSSvc(36,1) = "services.exe" : arMSSvc(36,2) = ""

arMSSvc(37,0) = "wmdmpmsp" : arMSSvc(37,1) = "svchost.exe" : arMSSvc(37,2) = "mspmspsv.dll"

arMSSvc(38,0) = "spooler" : arMSSvc(38,1) = "spoolsv.exe" : arMSSvc(38,2) = ""

arMSSvc(39,0) = "protectedstorage" : arMSSvc(39,1) = "lsass.exe" : arMSSvc(39,2) = ""

arMSSvc(40,0) = "rsvp" : arMSSvc(40,1) = "rsvp.exe" : arMSSvc(40,2) = ""

arMSSvc(41,0) = "rasauto" : arMSSvc(41,1) = "svchost.exe" : arMSSvc(41,2) = "rasauto.dll"

arMSSvc(42,0) = "rasman" : arMSSvc(42,1) = "svchost.exe" : arMSSvc(42,2) = "rasmans.dll"

arMSSvc(43,0) = "rdsessmgr" : arMSSvc(43,1) = "sessmgr.exe" : arMSSvc(43,2) = ""

arMSSvc(44,0) = "rpcss" : arMSSvc(44,1) = "svchost.exe" : arMSSvc(44,2) = "rpcss.dll"

arMSSvc(45,0) = "rpclocator" : arMSSvc(45,1) = "locator.exe" : arMSSvc(45,2) = ""

arMSSvc(46,0) = "remoteregistry" : arMSSvc(46,1) = "svchost.exe" : arMSSvc(46,2) = "regsvc.dll"

arMSSvc(47,0) = "ntmssvc" : arMSSvc(47,1) = "svchost.exe" : arMSSvc(47,2) = "ntmssvc.dll"

arMSSvc(48,0) = "remoteaccess" : arMSSvc(48,1) = "svchost.exe" : arMSSvc(48,2) = "mprdim.dll"

arMSSvc(49,0) = "seclogon" : arMSSvc(49,1) = "svchost.exe" : arMSSvc(49,2) = "seclogon.dll"

arMSSvc(50,0) = "samss" : arMSSvc(50,1) = "lsass.exe" : arMSSvc(50,2) = ""

arMSSvc(51,0) = "lanmanserver" : arMSSvc(51,1) = "svchost.exe" : arMSSvc(51,2) = "srvsvc.dll"

arMSSvc(52,0) = "smtpsvc" : arMSSvc(52,1) = "inetinfo.exe" : arMSSvc(52,2) = ""

arMSSvc(53,0) = "shellhwdetection" : arMSSvc(53,1) = "svchost.exe" : arMSSvc(53,2) = "shsvcs.dll"

arMSSvc(54,0) = "scardsvr" : arMSSvc(54,1) = "scardsvr.exe" : arMSSvc(54,2) = ""

arMSSvc(55,0) = "scarddrv" : arMSSvc(55,1) = "scardsvr.exe" : arMSSvc(55,2) = ""

arMSSvc(56,0) = "ssdpsrv" : arMSSvc(56,1) = "svchost.exe" : arMSSvc(56,2) = "ssdpsrv.dll"

arMSSvc(57,0) = "sens" : arMSSvc(57,1) = "svchost.exe" : arMSSvc(57,2) = "sens.dll"

arMSSvc(58,0) = "srservice" : arMSSvc(58,1) = "svchost.exe" : arMSSvc(58,2) = "srsvc.dll"

arMSSvc(59,0) = "schedule" : arMSSvc(59,1) = "svchost.exe" : arMSSvc(59,2) = "schedsvc.dll"

arMSSvc(60,0) = "lmhosts" : arMSSvc(60,1) = "svchost.exe" : arMSSvc(60,2) = "lmhsvc.dll"

arMSSvc(61,0) = "tapisrv" : arMSSvc(61,1) = "svchost.exe" : arMSSvc(61,2) = "tapisrv.dll"

arMSSvc(62,0) = "tlntsvr" : arMSSvc(62,1) = "tlntsvr.exe" : arMSSvc(62,2) = ""

arMSSvc(63,0) = "termservice" : arMSSvc(63,1) = "svchost.exe" : arMSSvc(63,2) = "termsrv.dll"

arMSSvc(64,0) = "themes" : arMSSvc(64,1) = "svchost.exe" : arMSSvc(64,2) = "shsvcs.dll"

arMSSvc(65,0) = "ups" : arMSSvc(65,1) = "ups.exe" : arMSSvc(65,2) = ""

arMSSvc(66,0) = "upnphost" : arMSSvc(66,1) = "svchost.exe" : arMSSvc(66,2) = "upnphost.dll"

arMSSvc(67,0) = "uploadmgr" : arMSSvc(67,1) = "svchost.exe" : arMSSvc(67,2) = "pchsvc.dll"

arMSSvc(68,0) = "vss" : arMSSvc(68,1) = "vssvc.exe" : arMSSvc(68,2) = ""

arMSSvc(69,0) = "webclient" : arMSSvc(69,1) = "svchost.exe" : arMSSvc(69,2) = "webclnt.dll"

arMSSvc(70,0) = "audiosrv" : arMSSvc(70,1) = "svchost.exe" : arMSSvc(70,2) = "audiosrv.dll"

arMSSvc(71,0) = "stisvc" : arMSSvc(71,1) = "svchost.exe" : arMSSvc(71,2) = "wiaservc.dll"

arMSSvc(72,0) = "msiserver" : arMSSvc(72,1) = "msiexec.exe" : arMSSvc(72,2) = ""

arMSSvc(73,0) = "winmgmt" : arMSSvc(73,1) = "svchost.exe" : arMSSvc(73,2) = "wmisvc.dll"

arMSSvc(74,0) = "wmi" : arMSSvc(74,1) = "svchost.exe" : arMSSvc(74,2) = "advapi32.dll"

arMSSvc(75,0) = "w32time" : arMSSvc(75,1) = "svchost.exe" : arMSSvc(75,2) = "w32time.dll"

arMSSvc(76,0) = "wzcsvc" : arMSSvc(76,1) = "svchost.exe" : arMSSvc(76,2) = "wzcsvc.dll"

arMSSvc(77,0) = "wmiapsrv" : arMSSvc(77,1) = "svchost.exe" : arMSSvc(77,2) = "wmiapsrv.dll"

arMSSvc(78,0) = "lanmanworkstation" : arMSSvc(78,1) = "svchost.exe" : arMSSvc(78,2) = "wkssvc.dll"

arMSSvc(79,0) = "w3svc" : arMSSvc(79,1) = "inetinfo.exe" : arMSSvc(79,2) = ""

arMSSvc(80,0) = "dcomlaunch" : arMSSvc(80,1) = "svchost.exe" : arMSSvc(80,2) = "rpcss.dll"

arMSSvc(81,0) = "irmon" : arMSSvc(81,1) = "svchost.exe" : arMSSvc(81,2) = "irmon.dll"

arMSSvc(82,0) = "ip6fwhlp" : arMSSvc(82,1) = "svchost.exe" : arMSSvc(82,2) = "ip6fwhlp.dll"

arMSSvc(83,0) = "wscsvc" : arMSSvc(83,1) = "svchost.exe" : arMSSvc(83,2) = "wscsvc.dll"

arMSSvc(84,0) = "wmiapsrv" : arMSSvc(84,1) = "wmiapsrv.exe" : arMSSvc(84,2) = ""

arMSSvc(85,0) = "httpfilter" : arMSSvc(85,1) = "svchost.exe" : arMSSvc(85,2) = "w3ssl.dll"

arMSSvc(86,0) = "xmlprov" : arMSSvc(86,1) = "svchost.exe" : arMSSvc(86,2) = "xmlprov.dll"

 

'WS2K3 only

arMSSvc(87,0) = "dfs" : arMSSvc(87,1) = "dfssvc.exe" : arMSSvc(87,2) = ""

arMSSvc(88,0) = "httpfilter" : arMSSvc(88,1) = "lsass.exe" : arMSSvc(88,2) = ""

arMSSvc(89,0) = "srvcsurg" : arMSSvc(89,1) = "srvcsurg.exe" : arMSSvc(89,2) = ""

arMSSvc(90,0) = "appmgr" : arMSSvc(90,1) = "appmgr.exe" : arMSSvc(90,2) = ""

arMSSvc(91,0) = "snmp" : arMSSvc(91,1) = "snmp.exe" : arMSSvc(91,2) = ""

arMSSvc(92,0) = "elementmgr" : arMSSvc(92,1) = "elementmgr.exe" : arMSSvc(92,2) = ""

arMSSvc(93,0) = "w3svc" : arMSSvc(93,1) = "svchost.exe" : arMSSvc(93,2) = "iisw3adm.dll"

 

ElseIf strOS = "W2K" Then

 

ReDim arMSSvc(65,2)

arMSSvc(0,0) = "alerter" : arMSSvc(0,1) = "services.exe" : arMSSvc(0,2) = ""

arMSSvc(1,0) = "appmgmt" : arMSSvc(1,1) = "services.exe" : arMSSvc(1,2) = ""

arMSSvc(2,0) = "wuauserv" : arMSSvc(2,1) = "svchost.exe" : arMSSvc(2,2) = "wuauserv.dll"

arMSSvc(3,0) = "bits" : arMSSvc(3,1) = "svchost.exe" : arMSSvc(3,2) = "qmgr.dll"

arMSSvc(4,0) = "clipsrv" : arMSSvc(4,1) = "clipsrv.exe" : arMSSvc(4,2) = ""

arMSSvc(5,0) = "eventsystem" : arMSSvc(5,1) = "svchost.exe" : arMSSvc(5,2) = "es.dll"

arMSSvc(6,0) = "browser" : arMSSvc(6,1) = "services.exe" : arMSSvc(6,2) = ""

arMSSvc(7,0) = "dhcp" : arMSSvc(7,1) = "services.exe" : arMSSvc(7,2) = ""

arMSSvc(8,0) = "trkwks" : arMSSvc(8,1) = "services.exe" : arMSSvc(8,2) = ""

arMSSvc(9,0) = "msdtc" : arMSSvc(9,1) = "msdtc.exe" : arMSSvc(9,2) = ""

arMSSvc(10,0) = "dnscache" : arMSSvc(10,1) = "services.exe" : arMSSvc(10,2) = ""

arMSSvc(11,0) = "eventlog" : arMSSvc(11,1) = "services.exe" : arMSSvc(11,2) = ""

arMSSvc(12,0) = "fax" : arMSSvc(12,1) = "faxsvc.exe" : arMSSvc(12,2) = ""

arMSSvc(13,0) = "iisadmin" : arMSSvc(13,1) = "inetinfo.exe" : arMSSvc(13,2) = ""

arMSSvc(14,0) = "cisvc" : arMSSvc(14,1) = "cisvc.exe" : arMSSvc(14,2) = ""

arMSSvc(15,0) = "sharedaccess" : arMSSvc(15,1) = "svchost.exe" : arMSSvc(15,2) = "ipnathlp.dll"

arMSSvc(16,0) = "policyagent" : arMSSvc(16,1) = "lsass.exe" : arMSSvc(16,2) = ""

arMSSvc(17,0) = "dmserver" : arMSSvc(17,1) = "services.exe" : arMSSvc(17,2) = ""

arMSSvc(18,0) = "dmadmin" : arMSSvc(18,1) = "dmadmin.exe" : arMSSvc(18,2) = ""

arMSSvc(19,0) = "messenger" : arMSSvc(19,1) = "services.exe" : arMSSvc(19,2) = ""

arMSSvc(20,0) = "netlogon" : arMSSvc(20,1) = "lsass.exe" : arMSSvc(20,2) = ""

arMSSvc(21,0) = "mnmsrvc" : arMSSvc(21,1) = "mnmsrvc.exe" : arMSSvc(21,2) = ""

arMSSvc(22,0) = "netman" : arMSSvc(22,1) = "svchost.exe" : arMSSvc(22,2) = "netman.dll"

arMSSvc(23,0) = "netdde" : arMSSvc(23,1) = "netdde.exe" : arMSSvc(23,2) = ""

arMSSvc(24,0) = "ntlmssp" : arMSSvc(24,1) = "lsass.exe" : arMSSvc(24,2) = ""

arMSSvc(25,0) = "sysmonlog" : arMSSvc(25,1) = "smlogsvc.exe" : arMSSvc(25,2) = ""

arMSSvc(26,0) = "plugplay" : arMSSvc(26,1) = "services.exe" : arMSSvc(26,2) = ""

arMSSvc(27,0) = "wmdmpmsn" : arMSSvc(27,1) = "svchost.exe" : arMSSvc(27,2) = "mspmsnsv.dll"

arMSSvc(28,0) = "spooler" : arMSSvc(28,1) = "spoolsv.exe" : arMSSvc(28,2) = ""

arMSSvc(29,0) = "protectedstorage" : arMSSvc(29,1) = "services.exe" : arMSSvc(29,2) = ""

arMSSvc(30,0) = "rsvp" : arMSSvc(30,1) = "rsvp.exe" : arMSSvc(30,2) = ""

arMSSvc(31,0) = "rasauto" : arMSSvc(31,1) = "svchost.exe" : arMSSvc(31,2) = "rasauto.dll"

arMSSvc(32,0) = "rasman" : arMSSvc(32,1) = "svchost.exe" : arMSSvc(32,2) = "rasmans.dll"

arMSSvc(33,0) = "rpcss" : arMSSvc(33,1) = "svchost.exe" : arMSSvc(33,2) = "rpcss.dll"

arMSSvc(34,0) = "rpclocator" : arMSSvc(34,1) = "locator.exe" : arMSSvc(34,2) = ""

arMSSvc(35,0) = "remoteregistry" : arMSSvc(35,1) = "regsvc.exe" : arMSSvc(35,2) = ""

arMSSvc(36,0) = "ntmssvc" : arMSSvc(36,1) = "svchost.exe" : arMSSvc(36,2) = "ntmssvc.dll"

arMSSvc(37,0) = "remoteaccess" : arMSSvc(37,1) = "svchost.exe" : arMSSvc(37,2) = "mprdim.dll"

arMSSvc(38,0) = "seclogon" : arMSSvc(38,1) = "services.exe" : arMSSvc(38,2) = ""

arMSSvc(39,0) = "samss" : arMSSvc(39,1) = "lsass.exe" : arMSSvc(39,2) = ""

arMSSvc(40,0) = "lanmanserver" : arMSSvc(40,1) = "services.exe" : arMSSvc(40,2) = ""

arMSSvc(41,0) = "smtpsvc" : arMSSvc(41,1) = "inetinfo.exe" : arMSSvc(41,2) = ""

arMSSvc(42,0) = "scardsvr" : arMSSvc(42,1) = "scardsvr.exe" : arMSSvc(42,2) = ""

arMSSvc(43,0) = "scarddrv" : arMSSvc(43,1) = "scardsvr.exe" : arMSSvc(43,2) = ""

arMSSvc(44,0) = "stisvc" : arMSSvc(44,1) = "stisvc.exe" : arMSSvc(44,2) = ""

arMSSvc(45,0) = "sens" : arMSSvc(45,1) = "svchost.exe" : arMSSvc(45,2) = "sens.dll"

arMSSvc(46,0) = "schedule" : arMSSvc(46,1) = "mstask.exe" : arMSSvc(46,2) = ""

arMSSvc(47,0) = "lmhosts" : arMSSvc(47,1) = "services.exe" : arMSSvc(47,2) = ""

arMSSvc(48,0) = "tapisrv" : arMSSvc(48,1) = "svchost.exe" : arMSSvc(48,2) = "tapisrv.dll"

arMSSvc(49,0) = "tlntsvr" : arMSSvc(49,1) = "tlntsvr.exe" : arMSSvc(49,2) = ""

arMSSvc(50,0) = "ups" : arMSSvc(50,1) = "ups.exe" : arMSSvc(50,2) = ""

arMSSvc(51,0) = "msiserver" : arMSSvc(51,1) = "msiexec.exe" : arMSSvc(51,2) = ""

arMSSvc(52,0) = "winmgmt" : arMSSvc(52,1) = "winmgmt.exe" : arMSSvc(52,2) = ""

arMSSvc(53,0) = "wmi" : arMSSvc(53,1) = "services.exe" : arMSSvc(53,2) = ""

arMSSvc(54,0) = "w32time" : arMSSvc(54,1) = "services.exe" : arMSSvc(54,2) = ""

arMSSvc(55,0) = "wzcsvc" : arMSSvc(55,1) = "svchost.exe" : arMSSvc(55,2) = "wzcsvc.dll"

arMSSvc(56,0) = "lanmanworkstation" : arMSSvc(56,1) = "services.exe" : arMSSvc(56,2) = ""

arMSSvc(57,0) = "w3svc" : arMSSvc(57,1) = "inetinfo.exe" : arMSSvc(57,2) = ""

arMSSvc(58,0) = "wmdm pmsp service" : arMSSvc(58,1) = "mspmspsv.exe" : arMSSvc(58,2) = ""

arMSSvc(59,0) = "msftpsvc" : arMSSvc(59,1) = "inetinfo.exe" : arMSSvc(59,2) = ""

arMSSvc(60,0) = "irmon" : arMSSvc(60,1) = "svchost.exe" : arMSSvc(60,2) = "irmon.dll"

 

'W2KS

arMSSvc(61,0) = "dhcpServer" : arMSSvc(61,1) = "tcpsvcs.exe" : arMSSvc(61,2) = ""

arMSSvc(62,0) = "dfs" : arMSSvc(62,1) = "dfssvc.exe" : arMSSvc(62,2) = ""

arMSSvc(63,0) = "dns" : arMSSvc(63,1) = "dns.exe" : arMSSvc(63,2) = ""

arMSSvc(64,0) = "ias" : arMSSvc(64,1) = "svchost.exe" : arMSSvc(64,2) = "ias.dll"

arMSSvc(65,0) = "licenseservice" : arMSSvc(65,1) = "llssrv.exe" : arMSSvc(65,2) = ""

 

ElseIf strOs = "NT4" Then

 

ReDim arMSSvc(27,2)

arMSSvc(0,0) = "alerter" : arMSSvc(0,1) = "services.exe" : arMSSvc(0,2) = ""

arMSSvc(1,0) = "clipsrv" : arMSSvc(1,1) = "clipsrv.exe" : arMSSvc(1,2) = ""

arMSSvc(2,0) = "eventsystem" : arMSSvc(2,1) = "esserver.exe" : arMSSvc(2,2) = ""

arMSSvc(3,0) = "browser" : arMSSvc(3,1) = "services.exe" : arMSSvc(3,2) = ""

arMSSvc(4,0) = "dhcp" : arMSSvc(4,1) = "services.exe" : arMSSvc(4,2) = ""

arMSSvc(5,0) = "replicator" : arMSSvc(5,1) = "lmrepl.exe" : arMSSvc(5,2) = ""

arMSSvc(6,0) = "eventlog" : arMSSvc(6,1) = "services.exe" : arMSSvc(6,2) = ""

arMSSvc(7,0) = "messenger" : arMSSvc(7,1) = "services.exe" : arMSSvc(7,2) = ""

arMSSvc(8,0) = "netlogon" : arMSSvc(8,1) = "lsass.exe" : arMSSvc(8,2) = ""

arMSSvc(9,0) = "netdde" : arMSSvc(9,1) = "netdde.exe" : arMSSvc(9,2) = ""

arMSSvc(10,0) = "netddedsdm" : arMSSvc(10,1) = "netdde.exe" : arMSSvc(10,2) = ""

arMSSvc(11,0) = "ntlmssp" : arMSSvc(11,1) = "services.exe" : arMSSvc(11,2) = ""

arMSSvc(12,0) = "plugplay" : arMSSvc(12,1) = "services.exe" : arMSSvc(12,2) = ""

arMSSvc(13,0) = "protectedstorage" : arMSSvc(13,1) = "pstores.exe" : arMSSvc(13,2) = ""

arMSSvc(14,0) = "rasauto" : arMSSvc(14,1) = "rasman.exe" : arMSSvc(14,2) = ""

arMSSvc(15,0) = "rasman" : arMSSvc(15,1) = "rasman.exe" : arMSSvc(15,2) = ""

arMSSvc(16,0) = "rpclocator" : arMSSvc(16,1) = "locator.exe" : arMSSvc(16,2) = ""

arMSSvc(17,0) = "rpcss" : arMSSvc(17,1) = "rpcss.exe" : arMSSvc(17,2) = ""

arMSSvc(18,0) = "lanmanserver" : arMSSvc(18,1) = "services.exe" : arMSSvc(18,2) = ""

arMSSvc(19,0) = "spooler" : arMSSvc(19,1) = "spoolss.exe" : arMSSvc(19,2) = ""

arMSSvc(20,0) = "sens" : arMSSvc(20,1) = "sens.exe" : arMSSvc(20,2) = ""

arMSSvc(21,0) = "schedule" : arMSSvc(21,1) = "mstask.exe" : arMSSvc(21,2) = ""

arMSSvc(22,0) = "lmhosts" : arMSSvc(22,1) = "services.exe" : arMSSvc(22,2) = ""

arMSSvc(23,0) = "tapisrv" : arMSSvc(23,1) = "tapisrv.exe" : arMSSvc(23,2) = ""

arMSSvc(24,0) = "ups" : arMSSvc(24,1) = "ups.exe" : arMSSvc(24,2) = ""

arMSSvc(25,0) = "msiserver" : arMSSvc(25,1) = "msiexec.exe" : arMSSvc(25,2) = ""

arMSSvc(26,0) = "winmgmt" : arMSSvc(26,1) = "winmgmt.exe" : arMSSvc(26,2) = ""

arMSSvc(27,0) = "lanmanworkstation" : arMSSvc(27,1) = "services.exe" : arMSSvc(27,2) = ""

 

ElseIf strOS = "WVA" Then

 

ReDim arMSSvc(76,2)

arMSSvc(0,0) = "aelookupsvc" : arMSSvc(0,1) = "svchost.exe" : arMSSvc(0,2) = "aelupsvc.dll"

arMSSvc(1,0) = "appinfo" : arMSSvc(1,1) = "svchost.exe" : arMSSvc(1,2) = "appinfo.dll"

arMSSvc(2,0) = "AudioEndpointBuilder" : arMSSvc(2,1) = "svchost.exe" : arMSSvc(2,2) = "Audiosrv.dll"

arMSSvc(3,0) = "Audiosrv" : arMSSvc(3,1) = "svchost.exe" : arMSSvc(3,2) = "Audiosrv.dll"

arMSSvc(4,0) = "BITS" : arMSSvc(4,1) = "svchost.exe" : arMSSvc(4,2) = "qmgr.dll"

arMSSvc(5,0) = "bfe" : arMSSvc(5,1) = "svchost.exe" : arMSSvc(5,2) = "bfe.dll"

arMSSvc(6,0) = "CryptSvc" : arMSSvc(6,1) = "svchost.exe" : arMSSvc(6,2) = "cryptsvc.dll"

arMSSvc(7,0) = "CscService" : arMSSvc(7,1) = "svchost.exe" : arMSSvc(7,2) = "cscsvc.dll"

arMSSvc(8,0) = "DcomLaunch" : arMSSvc(8,1) = "svchost.exe" : arMSSvc(8,2) = "rpcss.dll"

arMSSvc(9,0) = "Dhcp" : arMSSvc(9,1) = "svchost.exe" : arMSSvc(9,2) = "dhcpcsvc.dll"

arMSSvc(10,0) = "Dnscache" : arMSSvc(10,1) = "svchost.exe" : arMSSvc(10,2) = "dnsrslvr.dll"

arMSSvc(11,0) = "dps" : arMSSvc(11,1) = "svchost.exe" : arMSSvc(11,2) = "dps.dll"

arMSSvc(12,0) = "EMDMgmt" : arMSSvc(12,1) = "svchost.exe" : arMSSvc(12,2) = "emdmgmt.dll"

arMSSvc(13,0) = "Eventlog" : arMSSvc(13,1) = "svchost.exe" : arMSSvc(13,2) = "wevtsvc.dll" 'ServiceDll value in main key

arMSSvc(14,0) = "EventSystem" : arMSSvc(14,1) = "svchost.exe" : arMSSvc(14,2) = "es.dll"

arMSSvc(15,0) = "fdphost" : arMSSvc(15,1) = "svchost.exe" : arMSSvc(15,2) = "fdphost.dll"

arMSSvc(16,0) = "gpsvc" : arMSSvc(16,1) = "svchost.exe" : arMSSvc(16,2) = "gpsvc.dll"

arMSSvc(17,0) = "ikeext" : arMSSvc(17,1) = "svchost.exe" : arMSSvc(17,2) = "ikeext.dll"

arMSSvc(18,0) = "iphlpsvc" : arMSSvc(18,1) = "svchost.exe" : arMSSvc(18,2) = "iphlpsvc.dll" 'missing data!

arMSSvc(19,0) = "KtmRm" : arMSSvc(19,1) = "svchost.exe" : arMSSvc(19,2) = "msdtckrm.dll"

arMSSvc(20,0) = "LanmanServer" : arMSSvc(20,1) = "svchost.exe" : arMSSvc(20,2) = "srvsvc.dll"

arMSSvc(21,0) = "LanmanWorkstation" : arMSSvc(21,1) = "svchost.exe" : arMSSvc(21,2) = "wkssvc.dll"

arMSSvc(22,0) = "lmhosts" : arMSSvc(22,1) = "svchost.exe" : arMSSvc(22,2) = "lmhsvc.dll" 'missing data!

arMSSvc(23,0) = "MMCSS" : arMSSvc(23,1) = "svchost.exe" : arMSSvc(23,2) = "mmcss.dll"

arMSSvc(24,0) = "MpsSvc" : arMSSvc(24,1) = "svchost.exe" : arMSSvc(24,2) = "mpssvc.dll"

arMSSvc(25,0) = "Netman" : arMSSvc(25,1) = "svchost.exe" : arMSSvc(25,2) = "netman.dll"

arMSSvc(26,0) = "netprofm" : arMSSvc(26,1) = "svchost.exe" : arMSSvc(26,2) = "netprofm.dll"

arMSSvc(27,0) = "NlaSvc" : arMSSvc(27,1) = "svchost.exe" : arMSSvc(27,2) = "nlasvc.dll"

arMSSvc(28,0) = "nsi" : arMSSvc(28,1) = "svchost.exe" : arMSSvc(28,2) = "nsisvc.dll" 'missing data!

arMSSvc(29,0) = "PcaSvc" : arMSSvc(29,1) = "svchost.exe" : arMSSvc(29,2) = "pcasvc.dll"

arMSSvc(30,0) = "PlugPlay" : arMSSvc(30,1) = "svchost.exe" : arMSSvc(30,2) = "umpnpmgr.dll"

arMSSvc(31,0) = "PolicyAgent" : arMSSvc(31,1) = "svchost.exe" : arMSSvc(31,2) = "ipsecsvc.dll"

arMSSvc(32,0) = "ProfSvc" : arMSSvc(32,1) = "svchost.exe" : arMSSvc(32,2) = "profsvc.dll"

arMSSvc(33,0) = "RasMan" : arMSSvc(33,1) = "svchost.exe" : arMSSvc(33,2) = "rasmans.dll"

arMSSvc(34,0) = "RpcSs" : arMSSvc(34,1) = "svchost.exe" : arMSSvc(34,2) = "rpcss.dll"

arMSSvc(35,0) = "SamSs" : arMSSvc(35,1) = "lsass.exe" : arMSSvc(35,2) = ""

arMSSvc(36,0) = "Schedule" : arMSSvc(36,1) = "svchost.exe" : arMSSvc(36,2) = "schedsvc.dll"

arMSSvc(37,0) = "seclogon" : arMSSvc(37,1) = "svchost.exe" : arMSSvc(37,2) = "seclogon.dll"

arMSSvc(38,0) = "SENS" : arMSSvc(38,1) = "svchost.exe" : arMSSvc(38,2) = "sens.dll"

arMSSvc(39,0) = "ShellHWDetection" : arMSSvc(39,1) = "svchost.exe" : arMSSvc(39,2) = "shsvcs.dll"

arMSSvc(40,0) = "slsvc" : arMSSvc(40,1) = "SLsvc.exe" : arMSSvc(40,2) = ""

arMSSvc(41,0) = "Spooler" : arMSSvc(41,1) = "spoolsv.exe" : arMSSvc(41,2) = ""

arMSSvc(42,0) = "SSDPSRV" : arMSSvc(42,1) = "svchost.exe" : arMSSvc(42,2) = "ssdpsrv.dll"

arMSSvc(43,0) = "SysMain" : arMSSvc(43,1) = "svchost.exe" : arMSSvc(43,2) = "sysmain.dll"

arMSSvc(44,0) = "TabletInputService" : arMSSvc(44,1) = "svchost.exe" : arMSSvc(44,2) = "TabSvc.dll"

arMSSvc(45,0) = "TapiSrv" : arMSSvc(45,1) = "svchost.exe" : arMSSvc(45,2) = "tapisrv.dll"

arMSSvc(46,0) = "TermService" : arMSSvc(46,1) = "svchost.exe" : arMSSvc(46,2) = "termsrv.dll"

arMSSvc(47,0) = "Themes" : arMSSvc(47,1) = "svchost.exe" : arMSSvc(47,2) = "shsvcs.dll"

arMSSvc(48,0) = "THREADORDER" : arMSSvc(48,1) = "svchost.exe" : arMSSvc(48,2) = "mmcss.dll"

arMSSvc(49,0) = "TrkWks" : arMSSvc(49,1) = "svchost.exe" : arMSSvc(49,2) = "trkwks.dll"

arMSSvc(50,0) = "TrustedInstaller" : arMSSvc(50,1) = "TrustedInstaller.exe" : arMSSvc(50,2) = ""

arMSSvc(51,0) = "uxsms" : arMSSvc(51,1) = "svchost.exe" : arMSSvc(51,2) = "uxsms.dll"

arMSSvc(52,0) = "W32Time" : arMSSvc(52,1) = "svchost.exe" : arMSSvc(52,2) = "w32time.dll"

arMSSvc(53,0) = "wdisystemhost" : arMSSvc(53,1) = "svchost.exe" : arMSSvc(53,2) = "wdi.dll"

arMSSvc(54,0) = "WebClient" : arMSSvc(54,1) = "svchost.exe" : arMSSvc(54,2) = "webclnt.dll"

arMSSvc(55,0) = "WerSvc" : arMSSvc(55,1) = "svchost.exe" : arMSSvc(55,2) = "WerSvc.dll"

arMSSvc(56,0) = "WinDefend" : arMSSvc(56,1) = "svchost.exe" : arMSSvc(56,2) = "mpsvc.dll"

arMSSvc(57,0) = "WinHttpAutoProxySvc" : arMSSvc(57,1) = "svchost.exe" : arMSSvc(57,2) = "winhttp.dll"

arMSSvc(58,0) = "Winmgmt" : arMSSvc(58,1) = "svchost.exe" : arMSSvc(58,2) = "WMIsvc.dll"

arMSSvc(59,0) = "WPDBusEnum" : arMSSvc(59,1) = "svchost.exe" : arMSSvc(59,2) = "wpdbusenum.dll"

arMSSvc(60,0) = "wscsvc" : arMSSvc(60,1) = "svchost.exe" : arMSSvc(60,2) = "wscsvc.dll"

arMSSvc(61,0) = "WSearch" : arMSSvc(61,1) = "SearchIndexer.exe" : arMSSvc(61,2) = ""

arMSSvc(62,0) = "wuauserv" : arMSSvc(62,1) = "svchost.exe" : arMSSvc(62,2) = "wuaueng.dll"

arMSSvc(63,0) = "ProtectedStorage" : arMSSvc(63,1) = "lsass.exe" : arMSSvc(63,2) = ""

arMSSvc(64,0) = "NfsClnt" : arMSSvc(64,1) = "nfsclnt.exe" : arMSSvc(64,2) = ""

arMSSvc(65,0) = "IISADMIN" : arMSSvc(65,1) = "inetinfo.exe" : arMSSvc(65,2) = ""

arMSSvc(66,0) = "MSMQ" : arMSSvc(66,1) = "mqsvc.exe" : arMSSvc(66,2) = ""

arMSSvc(67,0) = "MSMQTriggers" : arMSSvc(67,1) = "mqtgsvc.exe" : arMSSvc(67,2) = ""

arMSSvc(68,0) = "iprip" : arMSSvc(68,1) = "svchost.exe" : arMSSvc(68,2) = "iprip.dll"

arMSSvc(69,0) = "SNMP" : arMSSvc(69,1) = "snmp.exe" : arMSSvc(69,2) = ""

arMSSvc(70,0) = "LPDSVC" : arMSSvc(70,1) = "tcpsvcs.exe" : arMSSvc(70,2) = ""

arMSSvc(71,0) = "WAS" : arMSSvc(71,1) = "svchost.exe" : arMSSvc(71,2) = "iisw3adm.dll"

arMSSvc(72,0) = "W3SVC" : arMSSvc(72,1) = "svchost.exe" : arMSSvc(72,2) = "iisw3adm.dll"

arMSSvc(73,0) = "swprv" : arMSSvc(73,1) = "svchost.exe" : arMSSvc(73,2) = "swprv.dll"

arMSSvc(74,0) = "VSS" : arMSSvc(74,1) = "vssvc.exe" : arMSSvc(74,2) = ""

arMSSvc(75,0) = "upnphost" : arMSSvc(75,1) = "svchost.exe" : arMSSvc(75,2) = "upnphost.dll"

arMSSvc(76,0) = "FDResPub" : arMSSvc(76,1) = "svchost.exe" : arMSSvc(76,2) = "fdrespub.dll"

 

' arMSSvc(77,0) = "" : arMSSvc(77,1) = "svchost.exe" : arMSSvc(77,2) = ""

 

End If 'filling MS default services array

[MAcgYvER everyONE 0]

'Services collection, Service object,

Dim colSvce, oSvce

'lowest-sort name holder, temp variables x 3

Dim intLSS, str1stName, strT0, strT1, strT2

Dim flagSM : flagSM = False 'Safe Mode flag

 

'for W2K/WXP/WVa, determine if running in Safe Mode

If strOS <> "NT4" Then

 

strKey = "SYSTEM\CurrentControlSet\Control"

intErrNum = oReg.GetStringValue (HKLM,strKey,"SystemStartOptions",strValue)

'if name exists

If intErrNum = 0 Then

'check if in Safe Mode

If InStr(LCase(strValue),"safeboot") <> 0 Then flagSM = True

End If

 

End If 'W2K/WXP/WVa?

 

'set up title line for normal, ShowAll, Safe Mode operation

strTitle = "Running Services (Display Name, Service Name, Path {Service DLL}):"

If flagShowAll Then strTitle = "All Running Services (Display Name, Service Name, Path {Service DLL}):"

If flagSM Then strTitle = "All Non-Disabled Services (Display Name, " &_

"Service Name, Path {Service DLL}):"

 

'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

On Error Resume Next

intCnt = colSvce.Count

intErrNum = Err.Number : Err.Clear

On Error Goto 0

 

'output warning and exit if count impeded

If intErrNum <> 0 Then

flagIWarn = True

TitleLineWrite

oFN.WriteLine vbCRLF & IWarn &_

"The running services cannot be counted." & vbCRLF &_

"Presence of a spyware service is suspected." & vbCRLF &_

"The script has been forced to exit."

SRClose

WScript.Quit

End If

 

'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

 

'check for null values or empty strings returned by WMI

If IsNull(oSvce.PathName) Then

arSvces(i,2) = "(null value)"

ElseIf oSvce.PathName = "" Then

arSvces(i,2) = "(empty string)"

Else

arSvces(i,2) = oSvce.PathName

End If

 

i = i + 1

 

Next 'service in collection

 

Set colSvce=Nothing

 

'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 'j 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 'i sorted name array element

 

'for every service sorted by display name

For i = 0 To UBound(arSvces,1)

 

'format path name for output

If arSvces(i,2) = "(null value)" Then

strPathNameOut = "(null value)"

ElseIf arSvces(i,2) = "(empty string)" Then

strPathNameOut = "(empty string)"

Else

strPathNameOut = StringFilter(arSvces(i,2),True)

End If

 

intMSSvcNo = -1 'assume not an MS Service

 

'find company name

strCN = CoName(IDExe(arSvces(i,2)))

 

'if service name found in MS default services array, save array subscript

For j = 0 To UBound(arMSSvc,1)

If LCase(arSvces(i,1)) = LCase(arMSSvc(j,0)) Then

intMSSvcNo = j : Exit For

End If

Next 'arMSSvc (MS Service)

 

'for services with unique file names

If InStr(LCase(arSvces(i,2)),"services.exe") = 0 And _

InStr(LCase(arSvces(i,2)),"svchost") = 0 Then

 

'find last backslash in service executable path

intLBSP = InStrRev(arSvces(i,2),"\")

'set position to 0 if no backslash present

If IsNull(intLBSP) Then intLBSP = 0

'extract service executable

strExeName = Mid(IDExe(arSvces(i,2)),intLBSP+1)

 

'if not MS default service Or ShowAll

If intMSSvcNo < 0 Or flagShowAll Then

 

If strTitle <> "" Then

TitleLineWrite : oFN.WriteBlankLines (1)

End If

 

'output display name, service name, path

oFN.WriteLine StringFilter(arSvces(i,0),False) & ", " &_

StringFilter(arSvces(i,1),False) & ", " &_

strPathNameOut & strCN

 

'if MS default service And (executable name or CoName doesn't match expected value)

ElseIf intMSSvcNo >= 0 And _

(LCase(strExeName) <> LCase(arMSSvc(intMSSvcNo,1)) Or _

strCN <> MS) Then

 

If strTitle <> "" Then

TitleLineWrite : oFN.WriteBlankLines (1)

End If

 

'output display name, service name, path

oFN.WriteLine StringFilter(arSvces(i,0),False) & ", " &_

StringFilter(arSvces(i,1),False) & ", " &_

strPathNameOut & strCN

 

End If 'MS default service with unexpected executable/CoName?

 

'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\"

intErrNum = oReg.GetExpandedStringValue (HKLM,strKey & arSvces(i,1) &_

"\Parameters","ServiceDll",strValue)

 

'prepare output for missing Parameters key or ServiceDLL value

strLine = " {(missing data)}"

strCN = CoName(IDExe(strValue))

 

If intErrNum = 0 And strValue <> "" Then

 

strLine = " {" & DQ & strValue & DQ & strCN & "}"

 

'extract ServiceDLL filename.ext

strDLL = Fso.GetFileName(strValue)

 

flagMatch = True

'if ShowAll Or DLL name/CoName have unexpected values

If flagShowAll Or LCase(strCN) <> " [ms]" Or intMSSvcNo = -1 Then

flagMatch = False

ElseIf LCase(strDLL) <> LCase(arMSSvc(intMSSvcNo,2)) Then

flagMatch = False

End If

 

If Not flagMatch Then

 

If strTitle <> "" Then

TitleLineWrite : oFN.WriteBlankLines (1)

End If

 

'output display name, service name, path

oFN.WriteLine StringFilter(arSvces(i,0),False) & ", " &_

StringFilter(arSvces(i,1),False) & ", " &_

strPathNameOut & strLine

 

End If 'flagMatch?

 

Else 'Parameters\ServiceDll not found so check service key

 

intErrNum1 = oReg.GetExpandedStringValue (HKLM,strKey & arSvces(i,1), _

"ServiceDll",strValue1)

 

'prepare output for missing Parameters key or ServiceDLL value

strLine = " {(missing data)}"

strCN = CoName(IDExe(strValue1))

 

If intErrNum1 = 0 And strValue1 <> "" Then

 

strLine = " {" & DQ & strValue1 & DQ & strCN & "}"

 

'extract ServiceDLL filename.ext

strDLL = Fso.GetFileName(strValue1)

 

flagMatch = True

'if ShowAll Or DLL name/CoName have unexpected values

If flagShowAll Or LCase(strCN) <> " [ms]" Or intMSSvcNo = -1 Then

flagMatch = False

ElseIf LCase(strDLL) <> LCase(arMSSvc(intMSSvcNo,2)) Then

flagMatch = False

End If

 

If Not flagMatch Then

 

If strTitle <> "" Then

TitleLineWrite : oFN.WriteBlankLines (1)

End If

 

'output display name, service name, path

oFN.WriteLine StringFilter(arSvces(i,0),False) & ", " &_

StringFilter(arSvces(i,1),False) & ", " &_

strPathNameOut & strLine

 

End If 'flagMatch?

 

End If 'ServiceDll exists at service key?

 

End If 'Parameters\ServiceDll exists?

 

'services.exe

Else

 

'extract service executable filename.ext

strExeName = Fso.GetFileName(arSvces(i,2))

 

flagMatch = True

'if ShowAll Or service name <> Services.exe or CoName <> MS

If flagShowAll Or LCase(strCN) <> " [ms]" Or intMSSvcNo = -1 Then

flagMatch = False

ElseIf LCase(strExeName) <> LCase(arMSSvc(intMSSvcNo,1)) Then

flagMatch = False

End If

 

If Not flagMatch Then

If strTitle <> "" Then

TitleLineWrite : oFN.WriteBlankLines (1)

End If

 

'output display name, service name, path

oFN.WriteLine StringFilter(arSvces(i,0),False) & ", " &_

StringFilter(arSvces(i,1),False) & ", " &_

strPathNameOut & strCN

End If

 

End If 'independent file, svchost, or services?

 

Next 'service file

 

'recover array memory

ReDim arSvces(0,0)

ReDim arMSSvc(0,0)

 

End If 'NT4-type O/S?

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

End If 'SecTest?

 

 

 

 

'#28. Accessibility Tools

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

'prepare title line

strTitle = "Accessibility Tools:"

 

'in W2K, recurse Utility Manager subkeys

If strOS = "W2K" Then

 

strKey = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Accessibility\Utility Manager"

strSubTitle = "HKLM" & "\" & strKey & "\"

 

ReDim arAllowedNames(2) : arAllowedNames(0) = "magnifier.exe"

arAllowedNames(1) = "narrator.exe" : arAllowedNames(2) = "osk.exe"

 

'find all the subkeys

oReg.EnumKey HKLM, strKey, arSubKeys

 

'enumerate data if present

If IsArray(arSubKeys) Then

 

'for each key

For Each strSubKey In arSubKeys

 

'get the configured startup values (dword returned as string)

 

strValue1 = RtnValue (HKLM, strKey & "\" & strSubKey, "Start with Utility Manager", REG_DWORD)

strValue2 = RtnValue (HKLM, strKey & "\" & strSubKey, "Start with Windows", REG_DWORD)

 

'if startup enabled (dword = 1)

If LCase(strValue1) = "dword:0x00000001" Or LCase(strValue2) = "dword:0x00000001" Then

 

'use new subtitle

strSubTitle = "HKLM" & "\" & strKey & "\" & strSubKey & "\"

 

strWarn = IWarn 'assume app path is not an allowed executable

 

'retrieve Application Path value & find CN

strValue3 = RtnValue (HKLM, strKey & "\" & strSubKey, "Application Path", REG_SZ)

strCN = CoName(IDExe(strValue3))

 

'empty strWarn if app path/CoName OK or app path empty

For i = 0 To UBound(arAllowedNames)

If (LCase(strValue3) = arAllowedNames(i) And strCN = MS) Or _

LCase(strValue3) = "(empty string)" Then

strWarn = "" : Exit For

End If

Next

 

'display warning in footer if app path executable not allowed

If strWarn <> "" Then flagIWarn = True

 

'output the title line if not already done

TitleLineWrite

 

'retrieve Display Name value

strValue4 = RtnValue (HKLM, strKey & "\" & strSubKey, "Display Name", REG_SZ)

 

'output data

oFN.WriteLine strWarn & DQ & "Application Path" & DQ & " = " &_

StringFilter(strValue3,True) & strCN & vbCRLF &_

DQ & "Display Name" & DQ & " = " & StringFilter(strValue4,True)

If LCase(strValue1) = "dword:0x00000001" Then _

oFN.WriteLine DQ & "Start with Utility Manager" & DQ & " = " & strValue1

If LCase(strValue2) = "dword:0x00000001" Then _

oFN.WriteLine DQ & "Start with Windows" & DQ & " = " & strValue2

 

End If 'sub-key name exists & dword = 1

 

Next 'sub-key

 

End If 'sub-key array exists?

 

'if ShowAll, output the key name if not already done

If flagShowAll Then TitleLineWrite

 

'clean up

strTitle = "" : strSubTitle = "" : strWarn = ""

ReDim arAllowedNames(0)

 

End If 'W2K?

 

 

'examine 4 WVa keys for accessibility tool names

If strOS = "WVA" Then

 

Public intUB : intUB = -1 'Upper Bound of unique accessibility tool array

 

ReDim arAllowedNames(2) : arAllowedNames(0) = "magnify.exe"

arAllowedNames(1) = "narrator.exe" : arAllowedNames(2) = "osk.exe"

 

'2 principal keys: HKCU/HKLM...Accessibility

strKey = "Software\Microsoft\Windows NT\CurrentVersion\Accessibility"

 

'for each hive

For ctrCH = intCLL To 1

 

strSubTitle = SOCA(arHives(ctrCH,0) & "\" & strKey & "\")

 

intErrNum = oReg.GetStringValue (arHives(ctrCH,1),strKey,"Configuration",strValue)

 

'if strValue exists & not empty or ShowAll

If (intErrNum = 0 And strValue <> "") Or flagShowAll Then

 

If intErrNum = 0 And strValue <> "" Then

 

TitleLineWrite

 

'output Configuration value

oFN.WriteLine DQ & "Configuration" & DQ & " = " & DQ & strValue & DQ

 

'parse comma-delimited strValue into Public arAcc array

StrParse2Unique strValue

 

Else 'ShowAll

 

TitleLineWrite

oFN.WriteLine DQ & "Configuration" & DQ & " = (value not set)"

 

End If 'strValue exists?

 

End If 'strValue exists or ShowAll?

 

'output if ShowAll

If flagShowAll Then TitleLineWrite

 

Next 'hive

 

 

'HKCU...AccessibilityTemp

strKey = "Software\Microsoft\Windows NT\CurrentVersion\AccessibilityTemp"

 

strSubTitle = "HKCU\" & strKey & "\"

 

'find the names array

intErrNum = oReg.EnumValues (HKCU, strKey, arNames, arType)

 

'if names array found

If intErrNum = 0 And IsArray(arNames) Then

 

TitleLineWrite

 

For Each strName In arNames

 

'output the DWORD values as strings

strValue = RtnValue (HKCU, strKey, strName, REG_DWORD)

oFN.WriteLine DQ & strName & DQ & " = " & strValue

 

'add unique names to array

AppUnique2DynArr strName,1,Len(strName)

 

Next

 

End If

 

 

'HKLM...Accessibility/Session#

strKey = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Accessibility"

strSubTitle = "HKLM\" & strKey & "\Session#\"

 

flagFound = False 'true if Session# key found

 

'find the subkeys

oReg.EnumKey HKLM, strKey, arSubKeys

 

'enumerate data if present

If IsArray(arSubKeys) Then

 

For Each strSubKey in arSubKeys

 

'save the subkey name if first seven letters are "session"

If LCase(Left(Trim(strSubKey),7)) = "session" Then

flagFound = True : strName = strSubKey : Exit For

End If

 

Next

 

'if Session# key found

If flagFound Then

 

'look for Configuration value

intErrNum = oReg.GetStringValue (HKLM,strKey & "\" & strName,"Configuration",strValue)

 

'if Configuration value found

If intErrNum = 0 And strValue <> "" Then

 

strSubTitle = "HKLM\" & strKey & "\" & strName & "\"

TitleLineWrite

'output Configuration value

oFN.WriteLine DQ & "Configuration" & DQ & " = " & StringFilter(strValue,True)

 

'parse comma-delimited strValue into arAcc array

StrParse2Unique strValue

 

End If 'Configuration value exists?

 

End If 'Session# sub-key found?

 

End If 'HKLM...Accessibility sub-keys exist?

 

 

'output arAcc members - unique accessibility tools

If IsArray(arAcc) Then

 

strKey = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Accessibility\ATs"

 

'get the ATs sub-keys

oReg.EnumKey HKLM, strKey, arSubKeys

 

'if array populated

If IsArray(arSubKeys) Then

 

'for each unique app tool

For Each strName In arAcc

 

'for each ATs sub-key name

For Each strSubKey In arSubKeys

 

'if app tool = sub-key name

If LCase(Trim(strName)) = LCase(Trim(strSubKey)) Then

 

'find Description & StartExe values

strValue1 = RtnValue (HKLM, strKey & "\" & strSubKey, "Description", REG_SZ)

strValue2 = RtnValue (HKLM, strKey & "\" & strSubKey, "StartExe", REG_EXPAND_SZ)

 

strFN = LCase(Fso.GetFileName(strValue2)) 'find file name

strCN = CoName(IDExe(strValue2)) 'find CoName

 

'no output if StartExe simple integer

If IsNumeric(strValue2) Then Exit For

 

'output title line

strSubTitle = "HKLM\" & strKey & "\" & strSubKey & "\"

TitleLineWrite

 

strWarn = IWarn 'assume StartExe is not an allowed executable

 

'empty strWarn if StartExe/CoName OK or StartExe empty

For i = 0 To UBound(arAllowedNames)

If (strFN = arAllowedNames(i) And strCN = MS) Or _

strFN = "(empty string)" Then

strWarn = "" : Exit For

End If

Next

 

If strWarn <> "" Then flagIWarn = True

 

'output data

oFN.WriteLine DQ & "Description" & DQ & " = " &_

StringFilter(strValue1,True) & vbCRLF &_

strWarn & DQ & "StartExe" & DQ &_

" = " & StringFilter(strValue2,True) & CoName(IDExe(strValue2))

 

Exit For 'arSubKey members

 

End If 'arAcc member=ATs sub-key name?

 

Next 'arSubKey member

 

Next 'arAcc member

 

End If 'is arSubKeys an array?

 

End If 'is arAcc an array?

 

'clean up

strTitle = "" : strSubTitle = "" : intUB = 0 : ReDim arAcc(0)

ReDim arAllowedNames(0)

 

End If 'WVa?

 

End If 'SecTest?

 

 

 

 

'#29. Keyboard Driver Filters

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

'prepare title line

strTitle = "Keyboard Driver Filters:"

 

Dim arValue() 'multi-string value

strOut = "" 'empty output string

flagInfect = False

 

'for W2K/WXP/WVa

If strOS = "W2K" Or strOS = "WXP" Or strOS = "WVA" Then

 

strKey = "SYSTEM\CurrentControlSet\Control\Class\{4D36E96B-E325-11CE-BFC1-08002BE10318}"

intErrNum = oReg.GetMultiStringValue (HKLM,strKey,"UpperFilters",arValue)

 

'if value exists

If intErrNum = 0 And IsArray(arValue) Then

 

'if array is not empty

If UBound(arValue) >= 0 Then

 

'for every UpperFilter

For i = 0 To UBound(arValue)

 

'if not default value

If LCase(Trim(arValue(i))) <> "kbdclass" Then

 

'toggle infection flag

flagInfect = True : flagIWarn = True

 

'if no extension, look in Drivers

If Fso.GetExtensionName(arValue(i)) = "" Then

strCN = CoName(strFPSF & "\Drivers\" & arValue(i) & ".sys")

Else 'use IDExe for CoName

strCN = CoName(IDExe(arValue(i)))

End If 'extension?

 

'if output string not empty, use leading comma

If strOut <> "" Then

strOut = strOut & ", " & IWarn & DQ & arValue(i) & DQ & strCN

Else 'skip leading comma if output string empty

strOut = IWarn & DQ & arValue(i) & DQ & strCN

End If

 

'set up output for ShowAll

ElseIf flagShowAll Then

 

'if no extension, look in Drivers

If Fso.GetExtensionName(arValue(i)) = "" Then

strCN = CoName(strFPSF & "\Drivers\" & arValue(i) & ".sys")

Else 'use IDExe for CoName

strCN = CoName(IDExe(arValue(i)))

End If 'extension?

 

'if output string not empty, use leading comma

If strOut <> "" Then

strOut = strOut & ", " & DQ & arValue(i) & DQ & strCN

Else 'skip leading comma if output string empty

strOut = DQ & arValue(i) & DQ & strCN

End If

 

End If 'kbdclass Or flagShowAll?

 

Next 'multi-string value element

 

'output if necessary

If flagInfect Or flagShowAll Then

 

TitleLineWrite

oFN.WriteLine vbCRLF & "HKLM\" & strKey & "\" & vbCRLF & DQ &_

"UpperFilters" & DQ & " = " & strOut

 

End If 'output necessary?

 

End If 'arValue empty?

 

Else 'arValue not returned

 

If flagShowAll Then

TitleLineWrite : oFN.WriteLine vbCRLF & "HKLM\" & strKey & "\" & vbCRLF & DQ &_

"UpperFilters" & DQ & " = (value not found)"

End If

 

End If 'arValue returned?

 

'recover array memory

ReDim arValue(0)

 

End If 'W2K/WXP/WVa?

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

End If 'SecTest?

 

 

 

 

'#30. Print Monitors

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

Dim arPMon(), intMSPMonNo

'assume monitor drivers don't exist

Dim flagMonDrvExist : flagMonDrvExist = False

 

If strOS = "NT4" Then

ReDim arPMon(1,1)

arPMon(0,0) = "Local Port" : arPMon(0,1) = "localmon.dll"

arPMon(1,0) = "PJL Language Monitor" : arPMon(1,1) = "pjlmon.dll"

ElseIf strOS = "W2K" Or strOS = "WXP" Then

ReDim arPMon(5,1)

arPMon(0,0) = "BJ Language Monitor" : arPMon(0,1) = "cnbjmon.dll"

arPMon(1,0) = "Local Port" : arPMon(1,1) = "localspl.dll"

arPMon(2,0) = "PJL Language Monitor" : arPMon(2,1) = "pjlmon.dll"

arPMon(3,0) = "Standard TCP/IP Port" : arPMon(3,1) = "tcpmon.dll"

arPMon(4,0) = "USB Monitor" : arPMon(4,1) = "usbmon.dll"

arPMon(5,0) = "Windows NT Fax Monitor" : arPMon(5,1) = "msfaxmon.dll"

ElseIf strOS = "WVA" Then

ReDim arPMon(5,1)

arPMon(0,0) = "Local Port" : arPMon(0,1) = "localspl.dll"

arPMon(1,0) = "Microsoft Shared Fax Monitor" : arPMon(1,1) = "FXSMON.DLL"

arPMon(2,0) = "Standard TCP/IP Port" : arPMon(2,1) = "tcpmon.dll"

arPMon(3,0) = "USB Monitor" : arPMon(3,1) = "usbmon.dll"

arPMon(4,0) = "WSD Port" : arPMon(4,1) = "WSDMon.dll"

arPMon(5,0) = "LPR Port" : arPMon(5,1) = "lprmon.dll"

ElseIf strOS = "WME" Then

ReDim arPMon(0,1)

arPMon(0,0) = "usbmon" : arPMon(0,1) = "usbmon.dll"

End If

 

strTitle = "Print Monitors:"

strKey = "System\CurrentControlSet\Control\Print\Monitors"

strSubTitle = SYCA("HKLM" & "\" & strKey & "\")

 

'find all the subkeys

oReg.EnumKey HKLM, strKey, arSubKeys

 

'enumerate data if present

If IsArray(arSubKeys) Then

 

'for each key

For Each strSubKey In arSubKeys

 

'set default values

intMSPMonNo = -1 : strCN = "" : flagAllow = False

 

'get the driver value

intErrNum = oReg.GetStringValue (HKLM,strKey & "\" & strSubKey,"Driver",strValue)

 

'if the driver value exists (exc for W2K!)

If intErrNum = 0 And strValue <> "" Then

 

flagMonDrvExist = True 'monitor drivers exist

 

'check for allowed values

If strOS <> "W98" Then

 

'set intMSPMonNo if subkey name & drive name are on approved list

For j = 0 To UBound(arPMon,1)

If LCase(strSubKey) = LCase(arPMon(j,0)) And _

LCase(strValue) = LCase(arPMon(j,1)) Then

intMSPMonNo = j : Exit For

End If

 

Next 'arPMon

 

End If 'strOS?

 

'find CoName

strCN = CoName(IDExe(strValue))

 

'toggle flag if subkey name/driver name/CoName OK

If intMSPMonNo >= 0 And strCN = MS Then flagAllow = True

 

'output if driver unapproved or showall

If Not flagAllow Or flagShowAll Then

 

TitleLineWrite

 

'output the quote-delimited names and values

On Error Resume Next

oFN.WriteLine StringFilter(strSubKey,False) & "\Driver = " &_

DQ & strValue & DQ & strCN

intErrNum = Err.Number : Err.Clear

On Error Goto 0

If intErrNum <> 0 Then oFN.WriteLine StringFilter(strSubKey,False) &_

"\Driver = (value not set)"

 

End If 'output?

 

End If 'driver value exists?

 

Next 'Monitors subkey

 

End If 'no Monitors subkeys found

 

If Not flagMonDrvExist And flagShowAll Then

strSubTitle = strSubTitle & vbCRLF & "(no drivers found)"

TitleLineWrite

End If

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

'recover array memory

ReDim arSubKeys(0)

ReDim arPMon(0,0)

 

End If 'SecTest?

 

 

'run closing sub

SRClose

 

 

'clean up

Set oReg=Nothing

Set Fso=Nothing

Set Wshso=Nothing

 

 

 

 

Sub SRClose

 

'find the number of seconds spent replying to popups

Dim datPUBsec : datPUBsec = datPUB1 + datPUB2

'find the words for the message box duration

Dim strPUBSec

Dim strOut

If flagShowAll Or flagSupp Or flagOut = "C" Then

strPUBsec = ""

ElseIf datPUBsec < 2 Then

strPUBsec = ", including " & datPUBsec & " second for message boxes"

Else

strPUBsec = ", including " & datPUBsec & " seconds for message boxes"

End if

 

'form the run time phrase

Dim strRunTime : strRunTime = " (total run time: " &_

DateDiff("s",datLaunch,Now) & " seconds" & strPUBsec & ")"

Dim intClosePUBSec 'script close announcement popup display seconds

Dim strBody : strBody = ""

Dim strSpacer : strSpacer = vbCRLF

Dim strHeader : strHeader = vbCRLF & vbCRLF & String(10,"-") &_

" (launch time: " & FmtDate(datLaunch) & " " & FmtHMSFtr(datLaunch) & ")"

Dim strFooter : strFooter = vbCRLF & String(10,"-") &_

strRunTime

 

'explain <<!>> & <<H>> symbols if present

'precede HWarn symbol by new line if IWarn also present

If flagIWarn And flagHWarn Then strSpacer = ""

 

If flagIWarn Then strBody = strBody & vbCRLF & "<<!>>: " &_

"Suspicious data at a malware launch point." & vbCRLF

 

If flagHWarn Then strBody = strBody & strSpacer & "<<H>>: " &_

"Suspicious data at a browser hijack point." & vbCRLF

 

If Not flagShowAll Then

strBody = strBody &_

vbCRLF & "+ This report excludes default entries except where indicated." &_

vbCRLF & "+ To see *everywhere* the script checks and *everything* it finds," &_

vbCRLF & " launch it from a command prompt or a shortcut with the -all parameter."

If Not flagSupp Then

strBody = strBody &_

vbCRLF & "+ To search all directories of local fixed drives for DESKTOP.INI" &_

vbCRLF & " DLL launch points, use the -supp parameter or answer " & DQ & "No" & DQ &_

" at the" & vbCRLF & " first message box and " & DQ & "Yes" & DQ &_

" at the second message box."

Else 'flagSupp=True

strBody = strBody &_

vbCRLF & "+ The search for DESKTOP.INI DLL launch points on all local fixed drives" &_

vbCRLF & " took " & strDTITime & "."

End If

Else 'flagShowAll=True

strHeader = vbCRLF & vbCRLF & "--" & strRunTime : strFooter = ""

End If

 

oFN.WriteLine strHeader & strBody & strFooter

 

oFN.Close : Set oFN=Nothing

 

'inform user that script is complete

If flagOut = "W" Then

 

intClosePUBSec = 20 : If flagTest Then intClosePUBSec = 1

 

'include path if report file directory specified via cmd-line parameter

If flagDirArg Then

 

strOut = "All Done! The results are in the file:" & vbCRLF & vbCRLF &_

strFN

 

Else 'directory not specified via cmd-line parameter

 

strOut = "All Done! The results are in the file:" & vbCRLF & vbCRLF &_

strFNNP & vbCRLF & vbCRLF & "This file is in the same directory as the script."

 

End if 'report file path?

 

Wshso.PopUp strOut,intClosePUBSec,"Silent Runners R" & strRevNo & " Complete", _

vbOKOnly + vbInformation + vbSystemModal

 

Else 'console output

 

'include path if report file directory specified via cmd-line parameter

If flagDirArg Then

 

strOut = "Silent Runners R" & strRevNo & " is done! The results " &_

"are in the file:" & vbCRLF & vbCRLF & strFN

 

Else 'directory not specified via cmd-line parameter

 

strOut = "Silent Runners R" & strRevNo & " is done! The results " &_

"are in the file:" & vbCRLF & vbCRLF & strFNNP & vbCRLF & vbCRLF &_

"This file is in the same directory as the script."

 

End If 'report file path?

 

WScript.Echo strOut

 

End If 'flagout?

 

End Sub

 

 

 

 

'YYYY-MM-DD

Function FmtDate (datIn)

 

FmtDate = Year(datIn) & "-" & Right("0" & Month(datIn),2) & "-" &_

Right("0" & Day(datIn),2)

 

End Function

 

 

 

 

'hh.mm.ss for report title

Function FmtHMS (datIn)

 

FmtHMS = Right("0" & Hour(datIn),2) & "." & Right("0" & Minute(datIn),2) &_

"." & Right("0" & Second(datIn),2)

 

End Function

 

 

 

 

'hh:mm:ss for report footer

Function FmtHMSFtr (datIn)

 

FmtHMSFtr = Right("0" & Hour(datIn),2) & ":" & Right("0" & Minute(datIn),2) &_

":" & Right("0" & Second(datIn),2)

 

End Function

 

 

 

 

'enumerate Name/Value Pairs

Sub EnumNVP (hexHive,strRunKey,arNames,arType)

 

Dim intUB, intErrNum, intErrNum1, i

 

flagNVP = False

 

'find all the names in the key

intErrNum = oReg.EnumValues (hexHive, strRunKey, arNames, arType)

 

'excludes W2K/WXP/WVa with no name/value pairs

If intErrNum = 0 And IsArray(arNames) Then

 

'try to get array UBound

On Error Resume Next

intUB = UBound(arNames)

intErrNum1 = Err.Number : Err.Clear

On Error Goto 0

 

'excludes WS2K3 with no name/value pairs

If intErrNum1 = 0 Then

 

'excludes W98/WMe/NT4 with no name/value pairs

If intUB >= 0 Then flagNVP = True

 

End If 'UBound exists?

 

End If 'names array exists?

 

End Sub

 

 

 

 

'return Name given value Type, toggle flag if value found

Function RtnValue (hexHive, strKey, strName, intType)

 

flagValueFound = False

 

'value as string/integer/array, counter, string variable, error number

Dim strFValue, intFValue, arFValue, i, strFMsg, intFErrNum

 

Select Case intType

 

'string value

Case REG_SZ

 

'return the string-type value

intErrNum = oReg.GetStringValue (hexHive,strKey,strName,strFValue)

 

If intErrNum = 0 Then

If strFValue = "" Then

strFValue = "(empty string)"

Else

flagValueFound = True

End If 'value empty?

RtnValue = strFValue

Else

RtnValue = "(value not set)"

End If 'value set?

 

'expandable-string value

Case REG_EXPAND_SZ

 

'return the expanded string-type value

intErrNum = oReg.GetExpandedStringValue (hexHive,strKey,strName,strFValue)

 

If intErrNum = 0 Then

If strFValue = "" Then

strFValue = "(empty string)"

Else

flagValueFound = True

End If 'value empty?

RtnValue = strFValue

Else

RtnValue = "(value not set)"

End If 'value set?

 

'binary value

Case REG_BINARY

 

'return the binary-type value as array

intFErrNum = oReg.GetBinaryValue (hexHive,strKey,strName,arFValue)

 

If intFErrNum = 0 And IsArray(arFValue) Then

 

If UBound(arFValue) >= 0 Then

'delimit every two-bytes by space

strFMsg = ""

For i = 0 To UBound(arFValue)

strFMsg = strFMsg & Right("00" & CStr(Hex(arFValue(i))),2) & " "

Next

strFMsg = "hex:" & RTrim(strFMsg) : flagValueFound = True

Else 'UBound(arFValue) = -1

strFMsg = "(value not set)"

End If 'UBound >= 0?

RtnValue = strFMsg

Else

RtnValue = "(value not set)"

End If 'value array exists?

 

'4-byte (32-bit) value

Case REG_DWORD

 

'return the DWORD-type value

intErrNum = oReg.GetDWORDValue (hexHive,strKey,strName,intFValue)

 

If intErrNum = 0 Then

flagValueFound = True

RtnValue = "dword:0x" & Right("00000000" & CStr(Hex(intFValue)),8)

Else

RtnValue = "(value not set)"

End If

 

'multiple-string value

Case REG_MULTI_SZ

 

'return the multiple-string-type value

intFErrNum = oReg.GetMultiStringValue (hexHive,strKey,strName,arFValue)

 

If intFErrNum = 0 And IsArray(arFValue) Then

If UBound(arFValue) >= 0 Then

flagValueFound = True

'delimit every quote-enclosed string by "|"

strFMsg = ""

For i = 0 To UBound(arFValue)

strFMsg = strFMsg & DQ & arFValue(i) & DQ & "|"

Next

Else 'UBound(arFValue) = -1

strFMsg = "(value not set)|" 'append "|" for later deletion

End If 'UBound >= 0?

strFMsg = Left(strFMsg,Len(strFMsg)-1) 'lop off trailing "|"

RtnValue = strFMsg

Else

RtnValue = "(value not set)"

End If 'value array exists?

 

'8-byte (64-bit) value

Case REG_QWORD

 

'return the QWORD-type value

intErrNum = oReg.GetQWORDValue (hexHive,strKey,strName,intFValue)

 

If intErrNum = 0 Then

flagValueFound = True

RtnValue = "hex:0x" & Right("0000000000000000" & CStr(Hex(intFValue)),16)

Else

RtnValue = "(value not set)"

End If

 

Case Else

 

'admit we don't know what it is

RtnValue = "(unknown data type)"

 

End Select 'data type

 

End Function

 

 

 

 

'return Type as string given Type as integer

Function RtnType (intType)

 

Select Case intType

 

'string value

Case REG_SZ

 

RtnType = "REG_SZ"

 

'expandable-string value

Case REG_EXPAND_SZ

 

RtnType = "REG_EXPAND_SZ"

 

'binary value

Case REG_BINARY

 

RtnType = "REG_BINARY"

 

'4-byte value

Case REG_DWORD

 

RtnType = "REG_DWORD"

 

'multiple-string-type value

Case REG_MULTI_SZ

 

RtnType = "REG_MULTI_SZ"

 

Case REG_QWORD

 

RtnType = "REG_QWORD"

 

'any other type

Case Else

 

RtnType = "(unknown data type)"

 

End Select

 

End Function

 

 

 

 

'write name/value pair to file

Function WriteValueData (strName, strValue, intType, strWarn)

 

Dim strOQEC 'Optionally Quote-Enclosed Comment

Dim strFiltVal : strFiltVal = StringFilter(strValue,False) 'filtered value

Dim strFiltNam : strFiltNam = StringFilter(strName,False) 'filtered name

 

'enclose REG_SZ strings in quotes and append CoName

If intType = REG_SZ Then

strOQEC = DQ & strFiltVal & DQ & CoName(IDExe(strValue))

ElseIf intType = REG_EXPAND_SZ Or intType = REG_SZ_NO_CN Then

strOQEC = DQ & strFiltVal & DQ

Else

strOQEC = strFiltVal

End If

 

'output the quote-delimited name and value

If strName = "" Then

oFN.WriteLine strWarn & DQ & "(Default)" & DQ & " = " & strOQEC

Else 'name is non-empty string

oFN.WriteLine strWarn & DQ & strFiltNam & DQ & " = " & strOQEC

End If

 

End Function

 

 

 

 

'compare registry value to accepted value and output

'hexHive, registry key, value name, accepted value, Special Handling label, CoName output flag

'any value accepted if accepted value = "all", CoName not output if flag = False

Sub RegDataChk_v2 (cHive, strKey, strName, strAccVal, strSH, flagCoName)

 

strSH = LCase(strSH)

 

Dim intType, strWarn, strValue

intType = 0 : strWarn = "" : strValue = "" : flagValueFound = False

 

'find value names & types

EnumNVP cHive,strKey,arNames,arType

 

'if names exist, check for strName

If flagNVP Then

 

For i = 0 To UBound(arNames)

'if target name found

If LCase(arNames(i)) = LCase(strName) Then

intType = arType(i) 'find type

strValue = RtnValue (cHive, strKey, arNames(i), intType) 'find value

'warn if value not allowed: all values not allowed, value <> allowed,

'value was found by RtnValue function

If strSH = "" Then

If LCase(strAccVal) <> "all" And LCase(strValue) <> LCase(strAccVal) _

And flagValueFound Then

flagIWarn = True : strWarn = IWarn

End If 'exception found?

'for ui, use string + comma-appended string as reference

ElseIf LCase(strSH) = "ui" Then

If LCase(strValue) <> LCase(strAccVal) And _

LCase(strValue) <> LCase(strAccVal) & "," Then

flagIWarn = True : strWarn = IWarn

End If 'exception found?

End If 'special handling?

Exit For

End If 'strName in arNames?

Next 'arNames member

 

'if type not set, name wasn't found

If intType = 0 Then strValue = "(name not found)"

 

'if output needed

If strWarn <> "" Or flagShowAll Then

 

TitleLineWrite

 

'quote-enclose value unless REG_MULTI_SZ Or no value found

'use LRParse for certain special handling fields

If intType = 7 Or Not flagValueFound Then

oFN.WriteLine strWarn & DQ & strName & DQ & " = " &_

StringFilter(strValue,False)

Else

If flagCoName Then

If strSH = "lrp" Or strSH = "ui" Then

oFN.WriteLine strWarn & DQ & strName & DQ & " = " &_

StringFilter(strValue,True) & LRParse(strValue)

Else

oFN.WriteLine strWarn & DQ & strName & DQ & " = " &_

StringFilter(strValue,True) & CoName(IDExe(strValue))

End If

Else 'flagCoName=False

oFN.WriteLine strWarn & DQ & strName & DQ & " = " &_

StringFilter(strValue,True)

End If 'flagCoName=True?

End If

 

End If 'output needed?

 

ElseIf flagShowAll Then 'flagNVP=False

TitleLineWrite

oFN.WriteLine DQ & strName & DQ & " = (name not found)"

End If 'values exist?

 

End Sub

 

 

 

 

'find a key's default value and compare to allowed string

Sub ChkDefaultValue (strKey,strAllowedValue)

 

'error number, value

Dim intErrNum, strValue

'initialize warning string

Dim strWarn : strWarn = ""

 

'find default value

intErrNum = oReg.GetStringValue (HKLM,strKey,"",strValue)

 

'if default value found

If intErrNum = 0 And strValue <> "" Then

 

'toggle warnings if default value not allowed

If LCase(Trim(strValue)) <> LCase(strAllowedValue) Then

strWarn = IWarn : flagIWarn = True

End If

 

'if output needed

If strWarn <> "" Or flagShowAll Then

'output

TitleLineWrite

oFN.WriteLine strWarn & "(Default) = " & DQ & strValue & DQ

End If

 

End If

 

End Sub

 

 

 

 

'enumerate a key's names and, for names matching those in a dictionary,

'find the values and compare to allowed strings stored as dictionary items

'if the values don't match the allowed strings and a flag is set,

'display the value at the unallowed location

Sub ChkNameValues (strKey, dictNV, flagResolveValue)

 

'error numbers

Dim intErrNum, intErrNum1, intErrNum2

'name/value type arrays, Dictionary associative array, single key

Dim arNames, arType, arDictKeys, strDictKey

'key, name, value x 2, output warning, output string

Dim strKey1, strName, strValue, strValue1, strWarn, strOut

'loc'n of SYS:/USR:

Dim intSYS, intUSR

 

'enumerate key names

intErrNum = oReg.EnumValues (HKLM, strKey, arNames, arType)

 

'if name array found

If intErrNum = 0 And IsArray(arNames) Then

 

'put dictionary keys in array

arDictKeys = dictNV.Keys

 

'for each name under strKey

For Each strName In arNames

 

'intialize variables

strWarn = "" : strOut = ""

 

'find value

intErrNum1 = oReg.GetStringValue (HKLM,strKey,strName,strValue)

 

'if value exists

If intErrNum1 = 0 And strValue <> "" Then

 

'for every dictionary key

For Each strDictKey In arDictKeys

 

'if dictionary key = name

If LCase(Trim(strDictKey)) = LCase(Trim(strName)) Then

 

'if dictionary key's item <> name's value

If LCase(dictNV.Item(strDictKey)) <> LCase(Trim(strValue)) Then

 

'toggle warnings

strWarn = IWarn : flagIWarn = True

 

'if need to resolve name's value

If flagResolveValue Then

 

'look for "SYS:" and "USR:"

intSYS = InStr(LCase(Trim(strValue)),"sys:")

intUSR = InStr(LCase(Trim(strValue)),"usr:")

'extract string beyond "SYS:" or "USR:"

strKey1 = Mid(Trim(strValue),5)

 

If intSYS = 1 Then 'if "SYS:" found in value

 

'resolve value in HKLM\SOFTWARE

intErrNum2 = oReg.GetStringValue (HKLM,"SOFTWARE\" & strKey1,strName,strValue1)

'form strOut if resolved value found

If intErrNum2 = 0 And strValue1 <> "" Then _

strOut = vbCRLF & strWarn & "HKLM\SOFTWARE\" & strKey1 & "\" & strName &_

" = " & DQ & strValue1 & DQ

 

ElseIf intUSR = 1 Then 'if "USR:" found in value

 

'resolve value in HKCU\Software

intErrNum2 = oReg.GetStringValue (HKCU,"Software\" & strKey1,strName,strValue1)

'form strOut if resolved value found

If intErrNum2 = 0 And strValue1 <> "" Then _

strOut = vbCRLF & strWarn & "HKCU\Software\" & strKey1 & "\" & strName &_

" = " & DQ & strValue1 & DQ

 

End If 'SYS: or USR: in value?

 

End If 'resolver flag set?

 

End If 'dictionary key's item <> name's value?

 

'if output necessary

If LCase(dictNV.Item(strDictKey)) <> LCase(Trim(strValue)) Or flagShowAll Then

 

'output & exit For

TitleLineWrite

oFN.WriteLine strWarn & DQ & strName & DQ & " = " & DQ & strValue & DQ & strOut

Exit For

 

End If 'output necessary?

 

End If 'dictionary key = name?

 

Next 'dictionary key

 

End If 'strValue exists?

 

Next 'strKey name

 

End If 'name array found?

 

End Sub

 

 

 

 

'set NoDriveTypeAutoRun flag

Function NDTAR (cHive, flagValueExists, flagFDEnabled)

 

'DWORD or BINARY value, binary value array, error number, hive name as string

Dim hVal, arBVal, intErrNum, strHive

 

strKey = "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer"

 

'if cHive NoDriveTypeAutoRun DWORD value exists

If oReg.GetDWORDValue(cHive,strKey,"NoDriveTypeAutoRun",hVal) = 0 Then

 

flagValueExists = True

 

'if autorun for fixed drives is disabled, set flag

If (hVal And 8) = 8 Then flagFDEnabled = 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 by O/S as

'0 for NDTAR instead of null!

If strOS = "W2K" Or strOS = "WXP" Then

flagValueExists = True

End If 'W2K/WXP?

 

Else 'UBound <> -1, so value set

 

flagValueExists = 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

On Error Resume Next

If (hVal And 8) = 8 Then flagFDEnabled = False

intErrNum = Err.Number : Err.Clear

On Error Goto 0

 

If intErrNum <> 0 Then

TitleLineWrite

strHive = "HKCU\"

If cHive = HKLM Then strHive = "HKLM\"

oFN.WriteLine vbCRLF & SOCA(strHive & strKey & "\" & vbCRLF &_

DQ & "NoDriveTypeAutoRun" & DQ & " = ** WARNING -- corrupt BINARY value! **")

End If

 

End If 'UBound = -1?

 

End If 'NoDriveTypeAutoRun value exists?

 

End Function

 

 

 

 

'detect if autorun disabled for individual drives

Function NDAR (cHive, flagValueExists)

 

'DWORD or BINARY value, binary value array, error number, hive name as string

Dim hVal, arBVal, intErrNum, strHive

 

strKey = "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer"

 

'if cHive NoDriveAutoRun DWORD value exists

If oReg.GetDWORDValue(cHive,strKey,"NoDriveAutoRun",hVal) = 0 Then

 

flagValueExists = 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 by O/S as

'0 instead of null!

If strOS = "W2K" Or strOS = "WXP" Then

 

flagValueExists = True

 

'set all NDAR flags to True

For i = 0 To UBound(arFixedDisks,2)

arFixedDisks(2,i) = True

Next

 

End If 'W2K/WXP?

[MAcgYvER everyONE 0]

Else 'UBound <> -1, so value set

 

flagValueExists = 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)

 

On Error Resume Next

'if autorun for the fixed disk is disabled, set flag

If (hVal And arFixedDisks(1,i)) = arFixedDisks(1,i) Then

arFixedDisks(2,i) = False

intErrNum = Err.Number : Err.Clear

End If

On Error Goto 0

 

If intErrNum <> 0 Then

strHive = "HKCU\"

If cHive = HKLM Then strHive = "HKLM\"

TitleLineWrite

oFN.WriteLine vbCRLF & SOCA(strHive & strKey & "\" & vbCRLF &_

DQ & "NoDriveAutoRun" & DQ & " = ** WARNING -- corrupt BINARY value! **")

Exit For

End If

 

Next 'fixed disk

 

End If 'hive NoDriveAutoRun value set?

 

End If 'hive NoDriveAutoRun value exists?

 

End Function

 

 

 

 

'INI/INF-file parser

Function IniInfParse (strInput, strVerb, strEquiv, strDisk)

 

Dim strOutput 'report line

Dim strWarn : strWarn = "" 'warning string

Dim strExe : strExe = "" 'executable after "="

Dim strLFN : strLFN = "" 'screen saver LFN

Dim intEqu

 

'if verb is first non-space chars (if line is populated)

If Left(LCase(LTrim(strInput)),Len(strVerb)) = strVerb Then

 

'find pos'n of equals sign

intEqu = InStr(strInput,"=")

 

'find executable statement after equals sign

strExe = Trim(Mid(strInput,intEqu+1))

 

'if chrs to right of equals sign different from argument or ShowAll

If (LCase(strExe) <> strEquiv) Or flagShowAll Then

 

'fill warning string if chrs to right of equals sign different from argument

If LCase(strExe) <> strEquiv And strEquiv <> "anything" Then

strWarn = IWarn : flagIWarn = True

End If

 

'concatenate line for load or run

If LCase(strVerb) = "load" Or LCase(strVerb) = "run" Then

 

strOutput = strWarn & DQ & strInput & DQ & LRParse(strExe)

 

'concatenate line for open or shellexecute

ElseIf LCase(strVerb) = "open" Or LCase(strVerb) = "shellexecute" Then

 

strOutput = strWarn & strDisk & "\AUTORUN.INF -> " &_

DQ & strInput & DQ & CoName(IDExe(strDisk & "\" & strExe))

 

'if screensaver = None then no line exists in INI-file

'if flagShowAll, nothing will be written since no line exists

ElseIf LCase(strVerb) = "scrnsave.exe" Then

 

'get screen saver LFN if file exists

If Fso.FileExists(strExe) Then

 

'create (but don't save) shortcut

Dim oSC : Set oSC = Wshso.CreateShortcut("getLFN.lnk")

'set & retrieve target path

oSC.TargetPath = strExe

strLFN = Fso.GetFile(oSC.TargetPath).Name

Set oSC=Nothing

 

'set up LFN string if SFN <> LFN

If LCase(strLFN) = LCase(Fso.GetFileName(strExe)) Then

strLFN = ""

Else

strLFN = " (" & strLFN & ")"

End If

 

End If 'screen saver file exists?

 

strOutput = strWarn & DQ & strInput & DQ & strLFN &_

CoName(IDExe(strExe))

 

'concatenate line for all other verbs

Else

 

strOutput = strWarn & DQ & strInput & DQ & LRParse(strExe)

 

End If 'load/run, open/shellexecute, scrnsave.exe, other?

 

TitleLineWrite : oFN.WriteLine strOutput

 

End If 'verb populated?

 

End If 'line populated

 

End Function

 

 

 

 

'trim the parameters from a string to isolate the executable and

'then locate the executable on the hard disk

Function IDExe (strPath)

 

'check for empty string

If IsNull(strPath) Or strPath = "" Then

IDExe = "file not found" : Exit Function

End If

 

'work path: trimmed, lower case, expanded env strings

Dim strPWk : strPWk = Trim(LCase(Wshso.ExpandEnvironmentStrings(strPath)))

 

Dim intFS 'forward slash pos'n

 

'check for "res://"

If Left(strPWk,6) = "res://" Then

 

'look for forword slash after "res://"

intFS = InStr(7,strPWk,"/",1)

'if no trailing fs, annex one's position at end of string

If intFS = 0 Then intFS = Len(strPWk) + 1

'extract string between "res://" and trailing fs

strPWk = Mid(strPWk,7,intFS-7)

 

End If 'string starts with "res://"?

 

If Fso.FileExists(strPWk) Then

IDExe = Fso.GetFile(strPWk).Path : Exit Function

End If 'as-is?

 

'dissect input string

 

'work path & TmpExe strings, loc'n of decimal pt, second quote, backslash, counter

Dim strTEx, intDP, int2Q, intBS, i

Dim flagFileFound : flagFileFound = False 'TRUE if file found in called function

Dim flagSpaceExists : flagSpaceExists = True 'FALSE if no space in work path

'Executable Extension array

Dim arExeExt : arExeExt = Array (".exe", ".com", ".cmd", ".bat", ".pif", ".dll")

 

'look for leading double quote, embedded " /", " """ (parameter prefixes)

If Left(strPWk,1) = DQ 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 = Trim(Mid(strPWk, 2, int2Q - 2))

'look for embedded " /"

ElseIf InStr(strPWk," /") > 0 Then

'if find it, reset the path string

strPWk = Trim(Mid(strPWk,1,InStr(strPWk," /")-1))

'look for embedded space + double quote

ElseIf InStr(strPWk," """) > 0 Then

'if find it, reset the path string

strPWk = Trim(Mid(strPWk,1,InStr(strPWk," """)-1))

End If

 

Do While flagSpaceExists

 

'look for trailing dot & backslash

intDP = InStrRev(strPWk,".")

intBS = InStrRev(strPWk,"\")

 

'if dot found And dot after backslash And string contains extension

If (intDP > 0) And (intDP > intBS) And (intDP < Len(strPWk)) Then

 

'look for entire string on hard disk

strTEx = WSL(strPWk, flagFileFound)

 

'if found, return it

If flagFileFound Then

IDExe = strTEx : Exit Function

End if

 

Else 'either dot not found Or dot in string Or string has no extension

 

'try adding executable extension

For i = 0 To UBound(arExeExt)

 

'look for string on hard disk

strTEx = WSL(strPWk & arExeExt(i), flagFileFound)

 

'if found, return it with executable extension appended

If flagFileFound Then

IDExe = strTEx : Exit Function

End if

 

Next 'executable extension

 

End If 'dot found And dot after BS And string has extension?

 

'trim chrs after space

If InStrRev(strPWk," ") = 0 Then

flagSpaceExists = False

Else

strPWk = Trim(Left(strPWk,InStrRev(strPWk," ") - 1))

End If

 

Loop 'flagSpaceExists

 

'last chance: look for AppPath of space-less executable

 

strPWk = Trim(AppPath(strPWk))

strTEx = WSL(strPWk,flagFileFound)

 

If flagFileFound Then

IDExe = strTEx

Else

IDExe = "file not found"

End if

 

End Function

 

 

 

 

'WinSysLocate

Function WSL (strIn, logFound)

 

'set default results

WSL = strIn : logFound = False

 

'if strIn exists, exit

If Fso.FileExists(strIn) Then

 

WSL = Fso.GetFile(strIn).Path

logFound = True

 

'if strIn doesn't contain drive or UNC network path

ElseIf InStr(strIn,":") = 0 And InStr(strIn,"\\") <> 1 Then

 

'check for file in Windows directory

If Fso.FileExists(strFPWF & "\" & strIn) Then

 

WSL = strFPWF & "\" & strIn : logFound = True

 

'check for file in System directory

ElseIf Fso.FileExists(strFPSF & "\" & strIn) Then

 

WSL = strFPSF & "\" & strIn : logFound = True

 

End If 'prefixed strIn exists?

 

End If 'strIn contains path?

 

End Function

 

 

 

 

'find company name in existing file

Function CoName (strFN)

 

If strFN = "file not found" Or IsNull(strFN) Or strFN = "" _

Or Not Fso.FileExists(strFN) Then

CoName = " [file not found]"

Exit Function

End If

 

'WMI file object, co-name, error number, working file name

Dim oFile, strMftr, intErrNum, strFNWk

 

'R44 -- removed StringFilter added in R40 -- findable Unicode file

' name added "unwritable string", which automatically threw a

' WMI GetObject Error

strFNWk = strFN

 

'if there are already escaped backslashes, unescape them

If InStr(strFNWk,"\\") <> 0 Then strFNWk = Replace(strFNWk,"\\","\")

'now reescape all of them

strFNWk = Replace(strFNWk,"\","\\")

 

'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=""" & strFNWk & """")

intErrNum = Err.Number : Err.Clear

On Error Goto 0

If intErrNum <> 0 Then

CoName = " [** WMI GetObject error **]"

Exit Function

End If

 

'find the co-name

strMftr = oFile.Manufacturer

 

Set oFile=Nothing

 

'if null, say so

If IsNull(strMftr) Then

 

CoName = " [null data]"

 

'if empty, say so

ElseIf strMftr = "" Then

 

CoName = " [empty string]"

 

'if some company, say it

Else

 

'if MS, say it with 2 letters

If strMftr = "Microsoft Corporation" Or strMftr = "Microsoft Corp." Then

 

CoName = MS

 

'if some other company, provide all the data, which may take up several lines

Else

 

CoName = " [" & StringFilter(Replace(strMftr,Chr(13) & Chr(10),Space(1)), _

True) & "]"

 

End If 'MS or not?

 

End If 'null, mt, MS or not?

 

End Function

 

 

 

 

'SCRipts.Ini-File Parser

'file name to open, action for which scripts must be parsed

Function ScrIFP (strValue, strAction)

 

'form scripts.ini path\FileName

Dim strScrFN : strScrFN = 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 flagActionWritten : flagActionWritten = False 'True if Action written once

Dim intActL : intActL = Len(strAction) 'action length (used for spacing of output)

 

'open the SCRIPTS.INI file For Reading

On Error Resume Next

Dim oSI : Set oSI = Fso.OpenTextFile(strScrFN, 1, False,-1)

intErrNum = Err.Number : Err.Clear

On Error Goto 0

 

'if couldn't open file, output a warning & quit

If intErrNum <> 0 Then

TitleLineWrite

oFN.WriteLine "WARNING! Insufficient permission to read " &_

DQ & strScrFN & DQ

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

 

TitleLineWrite

strArrow = DQ & strAction & DQ & " -> launches: "

If flagActionWritten = True Then strArrow = Space(intActL+2) & " -> launches: "

 

'output script command, reset script command & saved script number

oFN.WriteLine strArrow & DQ & strSC & DQ & CoName(IDExe(strCmd))

strSC = "" : strCmd = "" : flagActionWritten = True

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

 

oSI.Close : Set oSI=Nothing

 

'if a script was located, output last script command found

If strSC <> "" Then

 

strArrow = DQ & strAction & DQ & " -> launches: "

If flagActionWritten = True Then strArrow = Space(intActL+2) & " -> launches: "

TitleLineWrite

oFN.WriteLine strArrow & DQ & strSC & DQ & CoName(IDExe(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

 

 

 

 

'look for the App Path default value for an executable

Function AppPath (strFN)

 

Dim strKey, strValue, intErrNum

 

strKey = "Software\Microsoft\Windows\CurrentVersion\App Paths"

 

intErrNum = oReg.GetStringValue (HKLM,strKey & "\" & strFN,"",strValue)

 

'return the value or an empty string (or garbage if value not set under W2K!)

If intErrNum = 0 And strValue <> "" Then

AppPath = strValue

Else

AppPath = ""

End If

 

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)

'if executable has no extension, add ".exe"

 

If Fso.GetExtensionName(strLRSeg) = "" Then _

strLRSeg = strLRSeg & ".exe"

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)

 

If strOut = "" Then

strOut = CoName(IDExe(arOut(i)))

Else

'concatenate a comma & co-name (with leading space)

strOut = strOut & "," & CoName(IDExe(arOut(i)))

End If

 

Next

 

End If

 

'return delimited string

LRParse = strOut

 

End Function

 

 

 

 

'read JOB file & output error if file corrupt

Function JobFileRead (oFile, oJobFi)

 

'number of 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

 

'check for minimum length

If oFile.Size <= 80 Then

JobFileReadError oFile, " (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 & skip one line if not already done

If strTitle <> "" Then

TitleLineWrite

oFN.WriteBlankLines (1)

End If

 

'skip to the counter for the number of chrs in the first executable statement

oJobFi.Skip(10) 'no of bytes at unicode chr 35 (byte 70)

 

'no of 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, " (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, " (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, " (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, " (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, " (truncated parameter string)"

Exit Function

End If

 

'write out the .JOB file name & executable string

oFN.WriteLine DQ & Fso.GetBaseName(oFile.Path) & DQ &_

" -> launches: " & StringFilter(strJobExe,True) &_

CoName(IDExe(strCmd))

 

End If 'enabled task?

 

On Error Goto 0

 

End Function

 

 

 

 

'output reason for JOB file corruption

Function JobFileReadError (oFile, strReason)

 

'write titles if not already done

TitleLineWrite

 

'write out the .JOB file name & error

oFN.WriteLine DQ & Fso.GetBaseName(oFile.Path) & DQ &_

" -> " & "WARNING -- The file " & DQ & oFile.Name & DQ &_

" is corrupt!" & strReason

 

End Function

 

 

 

 

'filter unwritable chrs from output strings

'flagEmbedQ : if True, embed output string in quotes

Function StringFilter (strIn, flagEmbedQ)

 

'exit if string is null or empty

If IsNull(strIn) Then

StringFilter = "(null value)" : Exit Function

ElseIf strIn = Asc(0) Then

StringFilter = "(null value)" : Exit Function

ElseIf strIn = "" Then

StringFilter = "" : Exit Function

ElseIf LCase(strIn) = "(empty string)" Then

StringFilter = strIn : Exit Function

End If

 

Dim flagCorrupt : flagCorrupt = False 'unwritable chr encountered

Dim i, strChr 'counter, single chr

Dim intLen : intLen = Len(strIn) 'string length

Dim strOut : strOut = "" 'output string

 

'for every chr in argument

For i = 1 To intLen

 

'take ith chr

strChr = Mid(strIn,i,1)

 

'undocumented Asc behavior: certain chrs will return 63 ("?")

'if the chr really is a "?", then AscW will return the same thing

'otherwise, the chr is not a "?" and is unwritable

 

'if Asc = 160 Or Asc < 32 Or (Asc returns "?" but AscW doesn't)

If Asc(strChr) = 160 Or Asc(strChr) < 32 Or _

(Asc(strChr) = 63 And AscW(strChr) <> 63) Then

flagCorrupt = True : strOut = strOut & "*"

Else 'chr is legitimate ASCII

strOut = strOut & strChr

End If

 

Next

 

'say if string unwritable and enclose in quotes

If flagCorrupt Then

 

If flagEmbedQ Then

StringFilter = DQ & strOut & DQ & " (unwritable string)"

Else

StringFilter = strOut & " (unwritable string)"

End If 'flagEmbedQ?

 

Else 'input string is writable

 

If flagEmbedQ Then

StringFilter = DQ & strOut & DQ

Else

StringFilter = strOut

End If 'flagEmbedQ?

 

End If 'flagCorrupt?

 

End Function

 

 

 

 

'increment counters when IERESET.INF found-in-file-on-disk flag is False

Sub IERESETCounter (strSection, arIERSectionName, arSectionCount)

 

'if current INF section <> section for last not-found line

If strSection <> arIERSectionName Then 'if new section title

 

'increment # sections, reset # lines in section

'intSectionCount is an array index and initializes at -1

'intSectionLineCount initializes at 0 for new section

intSectionCount = intSectionCount + 1 : intSectionLineCount = 0

 

'1st row = section name; 2nd row = # not-found lines in section

'add column for new section to array, add title to array column

ReDim Preserve arSectionCount(1,intSectionCount)

arSectionCount(0,intSectionCount) = arIERSectionName

'set current section = section for last-found line

strSection = arIERSectionName

 

End If

 

'increment # lines not found in this section

intSectionLineCount = intSectionLineCount + 1

 

'increment # not-found lines in section

arSectionCount(1,intSectionCount) = intSectionLineCount

 

End Sub

 

 

 

 

'write title, sub-title, and sub-sub-title lines

Sub TitleLineWrite

 

If strTitle <> "" Then 'output title line if necessary

oFN.WriteLine vbCRLF & vbCRLF & strTitle & vbCRLF &_

String(Len(strTitle),"-")

strTitle = ""

End If

 

If strSubTitle <> "" Then 'output sub-title line if necessary

oFN.WriteLine vbCRLF & strSubTitle

strSubTitle = ""

End If

 

If strSubSubTitle <> "" Then 'output sub-title line if necessary

oFN.WriteLine vbCRLF & strSubSubTitle

strSubSubTitle = ""

End If

 

End Sub

 

 

 

 

Sub CLSIDLocTitle (hLocHive, strKeyLoc, strCLSID, strLocTitle)

 

'assign default values

flagIsCLSID = False : strLocTitle = ""

 

'toggle flag if strCLSID in correct format

If IsCLSID(strCLSID) Then flagIsCLSID = True

 

'get title from value

'title retrieved successfully even if value of type REG_EXPAND_SZ

intErrNum = oReg.GetStringValue (hLocHive,strKeyLoc,strCLSID,strValue)

 

If intErrNum = 0 And strValue <> "" Then

strLocTitle = StringFilter(strValue, True)

Else

strLocTitle = "(no title provided)"

End If 'strValue returned?

 

End Sub

 

 

 

 

'for CLSID name, recover CLSID title, CLSID\InProcServer32 DLL name

Sub ResolveCLSID (strCLSID, hCLSIDHive, strCLSIDTitle, strIPSDLL)

 

Dim strValue_1, strValue_2, strKey_1, strKey_2

Dim intErrNum_1, intErrNum_2, intErrNum_3

Dim arN(), arT()

 

'assign default values

strCLSIDTitle = "" : strIPSDLL = ""

 

strKey_1 = "Software\Classes\CLSID\" & strCLSID

strKey_2 = "Software\Classes\CLSID\" & strCLSID & "\InProcServer32"

 

'look for key

intErrNum_1 = oReg.EnumValues (hCLSIDHive,strKey_1,arN,arT)

 

'if key exists

If intErrNum_1 = 0 Then

 

'look for title

intErrNum_2 = oReg.GetStringValue (hCLSIDHive,strKey_1,"",strValue_1)

 

'set CLSID key title

strCLSIDTitle = "(no title provided)"

If intErrNum_2 = 0 And strValue_1 <> "" Then _

strCLSIDTitle = StringFilter(strValue_1, True)

 

'look for IPSDLL

intErrNum_3 = oReg.GetExpandedStringValue (hCLSIDHive,strKey_2,"",strValue_2)

If intErrNum_3 = 0 And strValue_2 <> "" Then strIPSDLL = strValue_2

 

End If 'CLSID key exists?

 

End Sub

 

 

 

 

'search for CLSID verb at InProcServer32, LocalServer32, ProgID, VersionIndependentProgID subkeys

'

'two inputs: CLSID, upper limit of arCLSIDVerb to search

'five outputs: flag (TRUE if CLSID found to be a default value),

' string value of hive in which CLSID found,

' CLSID verb, default value of verb, CLSID title

Sub CLSIDPop (strCLSID, intLimit, flagAllowedVerb, strHive, strCLSIDVerb, strCLSIDVerbValue, strCLSIDTitle)

 

'initialize variables

strCLSIDVerbValue = "" : strCLSIDTitle = ""

 

'counters x 3, CLSID key, CLSID key + verb, error numbers x 2

Dim i, j, k, strCLSIDKey, strCLSIDSubKey, intErrNum, intErrNum1

'TRUE if CLSID resolved, used to back out of For loops

Dim flagFoundHere : flagFoundHere = False

Dim strCLSIDDefaultValue 'CLSID default value (used for title)

 

Dim arCLSIDVerbs : arCLSIDVerbs = Array("InProcServer32","LocalServer32", _

"ProgID","VersionIndependentProgID")

 

'look for CLSID verbs up to limit

For i = 0 To intLimit

 

'exit if subverb action already found

If flagFoundHere Then Exit For

 

'look in each hive

For j = 0 To 1

 

'exit if subverb action already found

If flagFoundHere Then Exit For

 

'form CLSID key & CLSID verb key

strCLSIDKey = "SOFTWARE\Classes\CLSID\" & strCLSID

strCLSIDSubKey = strCLSIDKey & "\" & arCLSIDVerbs(i)

 

'retrieve CLSID verb key default value

intErrNum = oReg.GetStringValue (arHives(j,1),strCLSIDSubKey,"",strCLSIDVerbValue)

 

'if CLSID verb default value found

If intErrNum = 0 And strCLSIDVerbValue <> "" Then

 

flagFoundHere = True

 

strHive = arHives(j,0) : strCLSIDVerb = arCLSIDVerbs(i)

 

'look for CLSID title

intErrNum1 = oReg.GetStringValue (arHives(j,1),strCLSIDKey,"",strCLSIDDefaultValue)

'set CLSID key title

 

strCLSIDTitle = "(no title provided)"

If intErrNum1 = 0 And strCLSIDDefaultValue <> "" Then _

strCLSIDTitle = StringFilter(strCLSIDDefaultValue, True)

 

'check if CLSID verb is default

For k = 0 To UBound(arAllowedHandlerGrammar)

 

If LCase(Trim(strCLSIDVerbValue)) = LCase(arAllowedHandlerGrammar(k)) Then

flagAllowedVerb = True : Exit For 'if default, toggle flag and exit

End If

 

Next 'arAllowedHandlerGrammar member

 

End If 'CLSID verb default value found?

 

Next 'j hive

 

Next 'i arCLSIDVerbs

 

End Sub

 

 

 

 

'find directories with System attribute and DESKTOP.INI file

'with .ShellClassInfo section and CLSID statement

Sub DirSysAtt (oDir)

 

'sub-dir collection & count, single sub-dir, error number

Dim colSF, cntSF, oSF, intErrNum

'DeskTop.Ini path string & Parse return string,

Dim strDTI, strDTIP

 

'avoid "RECYCLER" And "System Volume Information" directories

If InStr(LCase(oDir),"recycler") > 0 Or _

InStr(LCase(oDir),"recycled") > 0 Or _

InStr(LCase(oDir),"system volume information") > 0 Then Exit Sub

 

'increment folder count

ctrFo = ctrFo + 1

 

'form DESKTOP.INI path string

strDTI = oDir.Path & "\DESKTOP.INI"

'if root directory, backslash is present by default

If oDir.IsRootFolder Then strDTI = oDir.Path & "DESKTOP.INI"

 

'if System attribute present And DESKTOP.INI CLSID exists,

'add path to array & increment count

If (oDir.Attributes And 4) And Fso.FileExists(strDTI) Then

strDTIP = DTIParse(strDTI)

If strDTIP <> "" Then

ReDim Preserve arSDDTI(ctrArDTI) : arSDDTI(ctrArDTI) = strDTIP

ctrArDTI = ctrArDTI + 1

End If 'return string not empty?

End If 'S And DTI exists?

 

'count the sub-folders, trap any error (prob. due to permissions)

On Error Resume Next

Set colSF = oDir.SubFolders : cntSF = colSF.Count

intErrNum = Err.Number : Err.Clear

On Error Goto 0

 

'if no error, recurse the sub-folders

If intErrNum = 0 Then

For Each oSF In colSF : DirSysAtt oSF : Next

Set colSF=Nothing

Else 'add (permissions) error to array & increment count

ReDim Preserve arSDErr(ctrArErr) : arSDErr(ctrArErr) = oDir.Path

ctrArErr = ctrArErr + 1

End If

 

End Sub

 

 

 

 

'return output string for DESKTOP.INI with CLSID statement

'consisting of CLSID and InProcServer32 DLL

Function DTIParse (strDTIFN)

 

'DESKTOP.INI file, error number, CoName

Dim oDTIFi, intErrNum, strIPSDLL, strCN

Dim strOut : strOut = "" 'output string

'file line, Lower-Case Left-Trimmed line, pos'n of equals sign

'CLSID, key string, counter

Dim strLine, strLCLT, intEq, strCLSID, strKey, i

Dim flagSection : flagSection = False 'in [.ShellClassInfo]?

Dim flagAllow 'IPS DLL on allowed list?

Dim flagTitle 'hive title line written?

 

DTIParse = "" 'by default, return empty string

 

'try to open DESKTOP.INI

On Error Resume Next

Set oDTIFi = Fso.OpenTextFile(strDTIFN,1,False,0)

intErrNum = Err.Number : Err.Clear

On Error Goto 0

 

'return error if file can't be opened

If intErrNum <> 0 Then

DTIParse = strDTIFN & " -- cannot be opened!" : Exit Function

End If

 

'[.shellclassinfo]

'CLSID=

'UICLSID=

 

'for every line

Do While Not oDTIFi.AtEndOfStream

 

strLine = oDTIFi.ReadLine

strLCLT = LCase(LTrim(strLine))

 

'detect [.ShellClassInfo]

If Left(strLCLT,1) = "[" And InStr(strLCLT,".shellclassinfo") > 0 Then

 

flagSection = True

 

'toggle flag if encountered another section before CLSID statement

ElseIf Left(strLCLT,1) = "[" And InStr(strLCLT,".shellclassinfo") = 0 Then

 

flagSection = False

 

'detect "CLSID=" or "UICLSID="

ElseIf flagSection And (Left(strLCLT,5) = "clsid" Or _

Left(strLCLT,7) = "uiclsid") Then

 

'find "="

intEq = InStr(1,strLCLT,"=",1)

 

'if "=" past "CLSID"

If intEq > 5 Then

 

strCLSID = RTrim(Mid(strLCLT,intEq + 1)) 'save the string past the equals

strKey = "Software\Classes\CLSID\" & strCLSID & "\InProcServer32"

 

flagTitle = False

 

For ctrCH = intCLL To 1

 

'get the CLSID IPS from the registry

intErrNum = oReg.GetExpandedStringValue (arHives(ctrCH,1),strKey,"", strIPSDLL)

 

'if the IPS DLL exists, check if it's allowed, CoName = MS & CLSID hive = HKLM

If intErrNum = 0 And strIPSDLL <> "" Then

 

flagAllow = False : strCN = CoName(IDExe(strIPSDLL))

 

For i = 0 To UBound(arOKDLLs)

If LCase(Fso.GetFileName(strIPSDLL)) = LCase(arOKDLLs(i)) And _

strCN = MS And ctrCH = 1 Then

flagAllow = True : Exit For

End If 'allowed?

Next 'allowed IPS DLL

 

'form string if DLL not allowed Or ShowAll

If Not flagAllow Or flagShowAll Then

 

If strOut = "" Then 'if no output yet, write full headers

 

strOut = vbCRLF & strDTIFN & vbCRLF & "[.ShellClassInfo]" &_

vbCRLF & strLine & vbCRLF & " -> {" & arHives(ctrCH,0) & "...CLSID}\" &_

"InProcServer32\(Default) = " & DQ & strIPSDLL & DQ & strCN

flagTitle = True

 

Else 'concatenate add'l text

 

If Not flagTitle Then 'no output for this line, so write line

 

strOut = strOut & vbCRLF & strLine & vbCRLF &_

" -> {" & arHives(ctrCH,0) & "...CLSID}\InProcServer32\(Default) = " &_

DQ & strIPSDLL & DQ & strCN

flagTitle = True

 

Else 'flagTitle True - current file line has generated output,

'so just append CLSID info

 

strOut = strOut & vbCRLF &_

" -> {" & arHives(ctrCH,0) & "...CLSID}\InProcServer32\(Default) = " &_

DQ & strIPSDLL & DQ & strCN

 

End If 'flagTitle?

 

End If 'strOut empty?

 

End If 'DLL not allowed?

 

End If 'IPS DLL exists?

 

Next 'CLSID hive

 

End If 'equals sign past "CLSID" or "UICLSID"?

 

End If 'in [.ShellClassInfo] section?

 

Loop 'DESKTOP.INI line

 

oDTIFi.Close : Set oDTIFi=Nothing

 

'set function value & exit

DTIParse = strOut

 

End Function

 

 

 

 

'file type, hive number, SOC default value

'check existence of file type key if SOC key not found? (True = Yes)

Sub SOCValue (strFT, intHive, strDefVal, flagFTKey)

 

'key string, error, returned value, array of key values/value types,

'company name, ddeexec key name

Dim strKey, intErrNum, strValue, arNames(), arType(), strCN, strKeyDDEX

Dim strWarn : strWarn = ""

 

'initialize company name

strCN = ""

 

'form file type S

strKey = "Software\Classes\" & strFT & "\shell"

 

'look for shell default value

intErrNum = oReg.GetStringValue (arHives(intHive,1),strKey,"",strValue)

 

'if file type shell value exists And not empty And <> "open"

If intErrNum = 0 And strValue <> "" And LCase(strValue <> "open") Then

 

flagIWarn = True 'toggle flag for report file footer

 

'output shell default value with IWarn

strOut = StrOutSep (strOut,IWarn & SOCA(arHives(intHive,0) & "\" &_

StringFilter(strKey,False)) & "\(Default) = " &_

StringFilter(strValue,True),vbCRLF)

 

'form ddeexec key

strKeyDDEX = strKey & "\" & strValue & "\ddeexec"

 

'form command key

strKey = strKey & "\" & strValue & "\command"

 

'look for command value

intErrNum = oReg.GetStringValue (arHives(intHive,1),strKey,"",strValue1)

 

'if command value exists

If intErrNum = 0 And strValue1 <> "" Then

 

'find CoName

strCN = CoName(IDExe(strValue1))

 

'output command value with warning

strOut = StrOutSep(strOut,IWarn & SOCA(arHives(intHive,0) & "\" &_

StringFilter(strKey,False)) & "\(Default) = " &_

StringFilter(strValue1,True) & strCN,vbCRLF)

 

End If 'command value exists?

 

'look for ddeexec value

DDEX intHive, strKeyDDEX

 

Else 'shell value empty Or = "open"

 

'form ddeexec key

strKeyDDEX = strKey & "\open\ddeexec"

 

'form SOC key

strKey = strKey & "\open\command"

 

'look for file type SOC

intErrNum = oReg.GetStringValue (arHives(intHive,1),strKey,"",strValue)

 

'if file type SOC value exists

If intErrNum = 0 And strValue <> "" Then

 

'if SOC value not expected, look for company name

If LCase(strValue) <> LCase(strDefVal) Then

strCN = CoName(IDExe(strValue))

strWarn = IWarn : flagIWarn = True

End If

 

'output if default value not expected or show all

If (LCase(strValue) <> LCase(strDefVal)) Or flagShowAll Then

strOut = StrOutSep(strOut,strWarn & SOCA(arHives(intHive,0) & "\" &_

StringFilter(strKey,False)) & "\(Default) = " &_

StringFilter(strValue,True) & strCN,vbCRLF)

End If

 

'file type SOC default value doesn't exist, does SOC key exist?

Else

 

'look for SOC key

intErrNum = oReg.EnumValues (arHives(intHive,1),strKey,arNames,arType)

 

'output SOC key status

If intErrNum = 0 Then

 

strOut = StrOutSep(strOut,SOCA(arHives(intHive,0) & "\" &_

StringFilter(strKey,False)) & "\(Default) = (value not set)",vbCRLF)

 

'SOC key doesn't exist, check for file type key if requested

ElseIf flagFTKey Then

 

'output missing HKLM key

If intHive = 1 Then strOut = StrOutSep (strOut,SOCA(arHives(intHive,0) &_

"\" & StringFilter(strKey,False)) & "\ = (key not found)",vbCRLF)

 

'form file type key

strKey = "Software\Classes\" & strFT

 

'look for file type key

intErrNum = oReg.EnumValues (arHives(intHive,1),strKey,arNames,arType)

 

'output file type key status

If intErrNum = 0 Then

strOut = StrOutSep (strOut,SOCA(arHives(intHive,0) & "\" &_

StringFilter(strKey,False)) & "\",vbCRLF)

ElseIf intHive = 1 Then

strOut = StrOutSep (strOut,SOCA(arHives(intHive,0) & "\" &_

StringFilter(strKey,False)) & "\ = (key not found)",vbCRLF)

End If

 

End If 'check file type key?

 

End If 'file type SOC exists?

 

'look for ddeexec value

DDEX intHive, strKeyDDEX

 

End If 'file type shell exists?

 

End Sub

 

 

 

 

'look for shell\open\ddeexec default values

Sub DDEX (intHive2, strKey)

 

'error x 2, returned value, arrays of key values/value types

Dim intErrNum, intErrNum1, strValue, arNames(), arType()

Dim strWarn : strWarn = IWarn

 

'look for ddeexec key

intErrNum = oReg.EnumValues (arHives(intHive2,1),strKey,"",arNames,arType)

 

'if ddeexec key exists

If intErrNum = 0 Then

 

flagIWarn = True

 

'get default value

oReg.GetStringValue arHives(intHive2,1),strKey,"",strValue

 

'form output string

strOut = StrOutSep (strOut, strWarn & SOCA(arHives(intHive2,0) & "\" &_

StringFilter(strKey,False)) & "\(Default) = " &_

StringFilter(strValue,True),vbCRLF)

 

'look for Application key

intErrNum1 = oReg.EnumValues (arHives(intHive2,1),strKey & "\Application","",arNames,arType)

 

'if Application key exists, get default value

If intErrNum1 = 0 Then

 

oReg.GetStringValue arHives(intHive2,1),strKey & "\Application","",strValue1

 

strOut = StrOutSep (strOut, strWarn & SOCA(arHives(intHive2,0) & "\" &_

StringFilter(strKey,False)) & "\Application\(Default) = " &_

StringFilter(strValue1,True),vbCRLF)

 

End If 'Application key exists?

 

End If 'ddeexec key exists?

 

End Sub

 

 

 

 

'initial output string, string to add, Separator string

Function StrOutSep (strOut, strAdd, strSep)

 

'if output string not empty, separate added string with strSep

If strOut <> "" Then

StrOutSep = strOut & strSep & strAdd

Else 'initial output string empty, set output to added string

StrOutSep = strAdd

End If

 

End Function

[MAcgYvER everyONE 0]

'recurse sub-directories for WVa Scheduled Tasks, run ESTParse sub on contents

Sub DirEST (oDir)

 

Dim strOutFo : strOutFo = "" 'output string for the folder

 

'File/Sub-Folder collections & count, single file/sub-dir

Dim colFi, colSF, oFi, oSF

 

'avoid "RECYCLER" And "System Volume Information" directories

If InStr(LCase(oDir.Name),"recycler") > 0 Or _

InStr(LCase(oDir.Name),"recycled") > 0 Or _

InStr(LCase(oDir.Name),"system volume information") > 0 Then Exit Sub

 

Set colFi = oDir.Files 'get the file collection

 

'trap any file access errors in the directory

'parse each file for EST info and append info to output string

On Error Resume Next

 

For Each oFi In colFi

 

strTmp = ESTParse(oFi.Path)

If strTmp <> "" Then 'if EST found

 

If strOutFo <> "" Then 'if output string not MT

strOutFo = strOutFo & vbCRLF & strTmp 'add EST to next line

Else 'output string still MT

strOutFo = strTmp 'don't precede EST string with CR

End If 'output string MT?

 

End If 'EST found?

 

Next 'next file in directory

intErrNum = Err.Number : Err.Clear

 

On Error Goto 0

 

'in case of access error, save the directory path in the error array

' increment the error count & exit

If intErrNum <> 0 Then

ReDim Preserve arErr(ctrErr) : arErr(ctrErr) = oDir.Path

ctrErr = ctrErr + 1 : Exit Sub

End If

 

'if EST's found, prefix the output string with the directory path

If strOutFo <> "" Then

If strOut = "" Then 'if first directory with output

'skip line and place EST's below directory path

strOut = vbCRLF & oDir.Path & vbCRLF & strOutFo

Else 'not first directory with output

'put blank line between old and new strings, then follow with

'directory path and new EST's

strOut = strOut & vbCRLF & vbCRLF & oDir.Path & vbCRLF & strOutFo

End If 'first directory with output?

End If 'EST's found in directory?

 

'get the sub-folder collection, trap any error (prob. due to permissions)

On Error Resume Next

Set colSF = oDir.SubFolders

intErrNum = Err.Number : Err.Clear

On Error Goto 0

 

'if no error, recurse the sub-folders

If intErrNum = 0 Then

For Each oSF In colSF : DirEST oSF : Next

Set colSF=Nothing

Else 'add (permissions) error to array & increment count

ReDim Preserve arErr(ctrErr) : arErr(ctrErr) = oDir.Path

ctrErr = ctrErr + 1

End If

 

End Sub

 

 

 

 

'WVa Enabled Scheduled Task (XML file) Parser

Function ESTParse (strESTFN)

 

Dim strCLSID, strCLSIDTitle, strIPSDLL, strNodeText

Dim strArg, flagIPSFnd

Dim flagDisabled : flagDisabled = False 'disabled flag

 

Dim strHidden : strHidden = ""

 

ESTParse = "" 'by default, return empty string

 

'create XML document

Dim oXMLFi: Set oXMLFi = CreateObject("MSXML2.DOMDocument")

 

'try to open argument (task file)

On Error Resume Next

oXMLFi.Load strESTFN

intErrNum = Err.Number : Err.Clear

On Error Goto 0

 

'exit if file can't be opened

If intErrNum <> 0 Then Exit Function

 

'exit if not a valid XML file or if file cannot be opened due to

'insufficient permissions

'also available: oXMLFi.ParseError.ErrorCode, oXMLFi.ParseError.Reason

If oXMLFi.ParseError.ErrorCode <> 0 Then Exit Function

 

On Error Resume Next

strNodeText = LCase(oXMLFi.SelectSingleNode("//Settings/Enabled").text)

intErrNum = Err.Number : Err.Clear

On Error Goto 0

 

If intErrNum = 0 Then

If strNodeText = "false" Then flagDisabled = True

End If

 

'if task is not disabled

If Not flagDisabled Then

 

'check if hidden

'*MUST* enclose within On Error, set .text property, save error number,

'test error number subsequently and *then* set dependent variable value

On Error Resume Next

strNodeText = LCase(oXMLFi.SelectSingleNode("//Settings/Hidden").text)

intErrNum = Err.Number : Err.Clear

On Error Goto 0

 

If intErrNum = 0 Then

If strNodeText = "true" Then strHidden = "(HIDDEN!)"

End If

 

'look for Custom Handler

'removal of "On Error Resume Next" generated error if CLSID not

' present and caused Function to return, but script did not abort

On Error Resume Next

strCLSID = oXMLFi.SelectSingleNode("//ComHandler/ClassId").text

intErrNum = Err.Number : Err.Clear

On Error Goto 0

 

If intErrNum = 0 Then 'Custom Handler present

 

'add CLSID to output string

ESTParse = DQ & Fso.GetFileName(strESTFN) & DQ &_

" -> " & strHidden & " launches: " & DQ & strCLSID & DQ

 

flagIPSFnd = False 'assume IPS DLL doesn't exist

 

'look for InProcServer32 in HKCU/HKLM

For ctrCH = 0 To 1

 

ResolveCLSID strCLSID, arHives(ctrCH,1), strCLSIDTitle, strIPSDLL

 

'if IPS found

If strIPSDLL <> "" Then

 

flagIPSFnd = True 'toggle flag

 

'append IPS string to output string

ESTParse = ESTParse & vbCRLF &_

" -> {" & arHives(ctrCH,0) & "...CLSID} = " &_

strCLSIDTitle & vbCRLF & Space(19) & "\InProcServer32\(Default) = " &_

StringFilter(strIPSDLL,True) & CoName(IDExe(strIPSDLL))

 

End If 'strIPSDLL exists?

 

Next 'CLSID hive

 

'if IPS not found, say it and return

If Not flagIPSFnd Then ESTParse = ESTParse & DQ &_

" [inProcServer32 entry not found]"

 

End If 'Custom Handler present?

 

'look for executable command

'removal of "On Error Resume Next" generated error if CLSID not

' present and caused Function to return, but script did not abort

On Error Resume Next

strCmd = oXMLFi.SelectSingleNode("//Command").text

intErrNum = Err.Number : Err.Clear

On Error Goto 0

 

'if command exists, save to output

If intErrNum = 0 Then

ESTParse = DQ & Fso.GetFileName(strESTFN) & DQ &_

" -> " & strHidden & " launches: " & DQ & strCmd

 

strCN = CoName(IDExe(strCmd)) 'find CoName

 

'look for executable arguments

'removal of "On Error Resume Next" generated error if CLSID not

' present and caused Function to return, but script did not abort

On Error Resume Next

strArg = oXMLFi.SelectSingleNode("//Arguments").text

intErrNum1 = Err.Number : Err.Clear

On Error Goto 0

 

'if arguments exist, add to output and return

If intErrNum1 = 0 Then

ESTParse = ESTParse & Space(1) & strArg & DQ & strCN

ElseIf ESTParse <> "" Then 'otherwise terminate output string

ESTParse = ESTParse & DQ & strCN

End If

 

End If 'command exists?

 

End If 'task not disabled?

 

End Function

 

 

 

 

'hex hive, registry key

Sub GPRecognizer (hHive, strKey)

 

'error number, counters x 2, Known Setting Index,

'Group Policy setting location string, value type

Dim intErrNum, i, j, intKSI, intISI, strGPLoc, strType

Dim flagIgnore

Dim arNames(), arType() 'returned array of value names/types

 

Const UCFG = "{User Configuration|"

Const CCFG = "{Computer Configuration|"

 

strSubSubTitle = "HKCU\" & strKey & "\"

If hHive = HKLM Then strSubSubTitle = SOCA("HKLM\" & strKey & "\")

 

'set up GPO type

Dim strGPOT : strGPOT = UCFG 'GPO Type

If hHive = HKLM Then strGPOT = CCFG

 

'obtain arrays of value names & types

intErrNum = oReg.EnumValues (hHive, strKey, arNames, arType)

 

'if array returned (exc for WS2K3)

If intErrNum = 0 And IsArray(arNames) Then

 

On Error Resume Next 'WS2K3 will throw error if no values exist

 

'for every member of the names array

For i = 0 To UBound(arNames)

 

'if not default value

If arNames(i) <> "" Then

 

flagIgnore = False 'assume name not approved

 

'retrieve the value as a string

strValue = RtnValue (hHive, strKey, arNames(i), arType(i))

'save the value type as a string

strType = RtnType (arType(i))

 

'compare name/value pair to approved names/values

For j = 0 To UBound(arAllowedNames,1)

 

'for approved names and equivalent or any values,

'toggle flag and exit

If LCase(Trim(arNames(i))) = LCase(arAllowedNames(j,0)) Then

 

If ((LCase(strValue) = LCase(arAllowedNames(j,3))) Or _

arAllowedNames(j,3) = "***") And Not flagShowAll Then

 

flagIgnore = True : intISI = j : Exit For

 

Else 'approved name, but unapproved value or ShowAll

 

'form output string and write to file, avoid add'l output

strGPLoc = strGPOT & arAllowedNames(j,1) & vbCRLF

'if GP not used here or GP editor doesn't contain this value,

'set location string to LBr

If Not flagGP Or arAllowedNames(j,1) = "" Then strGPLoc = LBr

TitleLineWrite

oFN.WriteLine vbCRLF & DQ & arNames(i) & DQ & " = (" & strType & ") " &_

strValue & vbCRLF & strGPLoc & arAllowedNames(j,2)

flagIgnore = True

 

End If 'approved value?

 

End If 'approved name?

 

Next 'arAllowedNames member

 

'if name/value not approved

If Not flagIgnore Then

 

flagFound = False 'assume name not recognized

 

'for every recognized name

For j = 0 To UBound(arRecNames,1)

 

'if name on recognized list, toggle flag and save array index

If LCase(Trim(arNames(i))) = LCase(arRecNames(j,0)) Then

flagFound = True : intKSI = j : Exit For

End If

 

Next 'recognized name array member

 

If flagFound Then 'if name recognized

 

'form output string and write to file

strGPLoc = strGPOT & arRecNames(intKSI,1) & vbCRLF

'if GP not used here or GP editor doesn't contain this value,

'set location string to LBr

If Not flagGP Or arRecNames(intKSI,1) = "" Then strGPLoc = LBr

TitleLineWrite

oFN.WriteLine vbCRLF & DQ & arNames(i) & DQ & " = (" & strType & ") " &_

strValue & vbCRLF & strGPLoc & arRecNames(intKSI,2)

 

Else 'name not recognized

 

TitleLineWrite

oFN.WriteLine vbCRLF & DQ & arNames(i) & DQ & " = (" & strType & ") " &_

strValue & vbCRLF & "{unrecognized setting}"

 

End If 'name recognized?

 

End If 'not approved name/value?

 

End If 'default name?

 

Next 'next arNames member

 

On Error Goto 0

 

'output reg-key title if absent or empty and ShowAll

ElseIf flagShowAll Then

 

TitleLineWrite

 

End If 'reg key has values?

 

End Sub

 

 

 

 

Sub ReDimGPOArrays

 

ReDim arRecNames(0,0) : arRecNames(0,0) = ""

ReDim arAllowedNames(0,0) : arAllowedNames(0,0) = ""

 

End Sub

 

 

 

 

Function SecTest

 

Dim i

 

SecTest = False

 

'check section status if in testing mode

If flagTest Then

 

For i = 0 To UBound(arSecTest)

 

'if section number in arSecTest, toggle function

If arSecTest(i) = intSection Then

SecTest = True : Exit For

End If 'this section in arSecTest?

 

Next

 

End If 'flagTest?

 

End Function

 

 

 

 

Sub StrParse2Unique (strIn)

 

Dim i 'counter

Dim intStrLen : intStrLen = Len(strIn) 'input string Length

Dim cntChr : cntChr = 0 'number of chrs in executable string

Dim intStartChr : intStartChr = 1 'start of component name in string

 

'for every chr in input string

For i = 1 To intStrLen

 

'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

 

AppUnique2DynArr strIn,intStartChr,cntChr

intStartChr = i + 1 'reset the executable string start to next chr

 

End If

 

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

 

AppUnique2DynArr strIn,intStartChr,cntChr

 

End If 'exec string found at end of line?

 

End Sub

 

 

 

 

'APPendUNIQUE2DYNamicARRay

Sub AppUnique2DynArr (strIn,intStart,intLen)

 

Dim i 'counter

Dim strCName : strCName = Mid(strIn,intStart,intLen) 'extract the component from the input string

intLen = 0 'reset the executable counter

Dim flagNew : flagNew = True 'true if extracted component not already in array

 

If intUB >= 0 Then

 

For i = 0 To intUB

 

If LCase(arAcc(i)) = LCase(strCName) Then

flagNew = False : Exit For

End If

 

Next

 

End If

 

If flagNew Then

 

intUB = intUB + 1 : ReDim Preserve arAcc(intUB)

arAcc(intUB) = strCName 'add the component to the output array

 

End If

 

End Sub

 

 

 

 

'SOftWare CAse

Function SOCA (strIn)

 

SOCA = strIn

 

If InStr(strIn,"HKCU\SOFTWARE") > 0 Then _

SOCA = Replace(strIn,"HKCU\SOFTWARE","HKCU\Software")

 

If InStr(strIn,"HKLM\Software") > 0 And strOSLong <> "Windows 98" Then

SOCA = Replace(strIn,"HKLM\Software","HKLM\SOFTWARE")

ElseIf InStr(strIn,"HKLM\SOFTWARE") > 0 And strOSLong = "Windows 98" Then

SOCA = Replace(strIn,"HKLM\SOFTWARE","HKLM\Software")

End If

 

End Function

 

 

 

 

'SYstem CAse

Function SYCA (strIn)

 

SYCA = strIn

 

If InStr(strIn,"HKLM\System") And strOS <> "W98" And strOS <> "WME" Then _

SYCA = Replace(strIn,"HKLM\System","HKLM\SYSTEM")

 

If InStr(strIn,"HKLM\SYSTEM") And (strOS = "W98" Or strOS = "WME") Then _

SYCA = Replace(strIn,"HKLM\SYSTEM","HKLM\System")

 

End Function

 

 

 

 

Function IsCLSID (strIn)

 

'{########-####-####-####-############}

 

'set default value

IsCLSID = False

 

Dim strWork, i

Dim arHexAlpha : arHexAlpha = Array("a","b","c","d","e","f")

 

'check length, first & last chrs

If Len(strIn) = 38 And Left(strIn,1) = "{" And Right(strIn,1) = "}" Then

 

strWork = strIn

 

'change all digits to 0

For i = 1 To 9

strWork = Replace (strWork,i,"0")

Next

 

'change all letters to 0

For i = 0 To UBound(arHexAlpha)

strWork = Replace (LCase(strWork),arHexAlpha(i),"0")

Next

 

'check replaced string, flip function value and exit

If strWork = "{00000000-0000-0000-0000-000000000000}" Then

IsCLSID = True : Exit Function

End If

 

End If 'len, 1st/last chrs OK?

 

'exit with default value if land here

 

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

'new section IV: HKLM...Shell Extensions\Approved, renumbered V-XV

'restricted output in sections II, V, XIV

'added flagShowAll and "-all" command line parameter

'added header and footer comments, {++} indicator in non-default mode

' for HKCU/HKLM...Run keys

'subkey enumeration (EnumKey) via IsArray followed by For Each

'enabled WS2K3 operation, extended final popup to 5 seconds

 

'R29

'redirected browser to RED version in case of CreateTextFile error

'appended wscsvc to arMSSvc for WXP

'checked for null string returned by oReg.GetStringValue

'fixed bug under XP for script not stored in default script directory --

' CoName was always "file not found"

'in Section II (HKLM... Active Setup\Installed Components), avoid code

' section if HKLM Version name doesn't exist or value not set (exc for (W2K!)

'in Section III (HKLM... Explorer\Browser Helper Objects\), avoid

' output if InProcServer32 default value not set

'in Section V (HKLM... Explorer\SharedTaskScheduler), avoid code if

' IPS doesn't exist

'rewrote IDExe & revised CoName functions, eliminated CNCall

 

'R30

'added FmtHMS function, removed FmtTime function

'added hh.mm.ss to report file name

'use unique time for report title, removed launch time from report header

'default flagOut = "C" if neither WSCRIPT nor CSCRIPT detected

'in Section XIII, for executable in SU directory, send Path to IDExe

' instead of Name

'in IDExe & WSL functions, return Path property of GetFile object so path

' included if file located in VBS CurrentDirectory

'standardized CLSID InProcServer32 output line in Sections III, IV, V, VI to:

' " -> {CLSID}\InProcServer32\(Default) = "

 

'R31

'added instructions for WXP if Fso connection fails

'added instructions for W2K/WXP if WMI connection fails

'added StringFilter function to filter unwritable default values

'added to section VII: Policies\System\Shell for W2K

'added to section X: cmd, scr; added arExpVal (expected value array);

' get filetype from extension default value and check filetype

' shell\open\command

'removed DefExeTitles function

'added section XI: scrnsave.exe for NT4/W2K/WXP

'added to section XII: scrnsave.exe in SYSTEM.INI

'added section XVII: Winsock2 Service Provider DLLs

'modified IDExe to use common environment variables

'added section XVIII: IE URL prefixes

 

'R31.1

'added home page URL to report header

 

'R32

'removed quotes surrounding key\value name output in following sections:

' HKLM... Active Setup\Installed Components

' HKLM...Winlogon\Notify\

'added section X: HKCR\Protocols\Filter

'modified output format in Screen Saver section

 

'R33

'section II: HKLM-to-HKCU Active Setup/Installed Components key names

' made non-case-specific

'added to section VII: Winlogon\Taskman

'added to section XII: Wallpaper

'allowed URL\Prefixes names to contain trailing periods

'moved Services to next-to-last section (XX)

'trapped error & quit if running services can't be counted

'added section XIX: HOSTS

'added section XXI: Keyboard Driver Filters

'added sub: SRClose

 

'R34

'added section XVIII: Toolbars, Explorer Bars (active & dormant), Extensions

'section XX: detect tabs [Chr(09)] in addition to spaces as HOSTS file delimiter

'section XXI: moved DIM of two variables to main (errors not thrown

' by Option Explicit!)

'added flagPad to StringFilter function

'retrieved all InProcServer32 default values via GetExpandedStringValue

' instead of GetStringValue

 

'R35

'revised R34 notes

'introduced MS constant

'section V: added HKLM...Explorer\ShellExecuteHooks, modified allowed

' logic

'section VIII: added "&Discuss" to allowed Explorer Bars

'section XV: added INFECTION WARNING if executable located in startup directory

'changed flagPad to flagEmbedQ in StringFilter function

 

'R36

'added flagTest

'added section IX: HKLM...Windows NT\CurrentVersion\Image File Execution Options

'section XXI: checked HOSTS file location at HKLM...Tcpip\Parameters\DataBasePath

 

'R37

'added W95 & WMe compatibility

'sections III & XX: if ShowAll, write section titles if hive keys absent

'added section XIII: System/Group Policies

'moved wallpaper ahead of screen saver in section XIV

'in RegDataChk, sent "shell" line to LRParse for ID of malware CoName

 

'R38

'added script startup popup

'replaced EnumKeyData with EnumNVP and RtnValue functions, renamed

' ScrIP to ScrIFP

'added IERESETCounter, ResolveCLSID, TitleLineWrite functions

'section XIII: added Control Panel applet removal + 2 toolbar entries

' to Explorer values; added Policies\Microsoft\Internet Explorer

' subsection

'section XX (IE Toolbars, Explorer Bars, Extensions): moved CLSID

' titles (default values) to the CLSID line

'added section XXII: misc IE hijack points (IERESET.INF,

' URLSearchHooks, AboutURLS)

'section XXIII: detect tabs preceding spaces as HOST file delimiters

'added "--" tail to ShowAll report

'removed Messenger from allowed IE extensions (Messenger has

' vulnerable versions)

 

'R38.1

'section XXII: determined IERESET.INF format by reading 1st 2 chrs

'before opening to compare with local copy

 

'R39

'performed housekeeping on all opened objects

'section XIII: added Explorer\NoFolderOptions, NoWindowsUpdate,

' and DisableWindowsUpdateAccess; HKLM... Windows NT\SystemRestore

'added section XII: context menu shell extensions

'added section XVIII: DESKTOP.INI in local fixed drive directory

'added -supp command line parameter to skip DESKTOP.INI and dormant

' Explorer Bar sections

'SRClose: added -supp advisory and reformatted

'section XXIV: added IERESET.INF minimum size requirement

'section XXVI: added 5 services for W2KS & 1 for WXP

'report footer: added total run time, DESKTOP.INI folder search time,

' dormant Explorer Bar search time

'added popup to select -supp parameter

'fixed intMB Dim placement bug

 

'R40

'moved WMI installation detection after VBScript version & OS version

' detection

'switched supp search msgbox buttons so that "Yes" is default instead of "No"

'suppressed menu display time when using CSCRIPT.EXE

'section XIV: for WXP SP2, added NoExtensionManagement

'section XVIII: trapped error if letter assigned to RAW data

' (ex: Linux) partition

'section XXIV: added On Error trap for IERESET.INF lines

'function IDExe: simplified use of ExpandEnvironmentStrings

'function CoName: added StringFilter for Unicode names

 

'R40.1

'edited SRClose footer to cite pressing "No" instead of "Yes" at first

'msgbox for -supp option

 

'R41

'section VII: check for existence of BootExecute value before

' validating

'added section XXVIII: Print Monitors

 

'R42

'added WINVER.EXE file version for W95 SR2 (OEM)

'lengthened final Popup time from 5 to 20 seconds

 

'R43

'section XII: added HKLM... Control\SafeBoot\Option\UseAlternateShell

 

'R44

'sections III-IV-V-VI-XI-XII-XVIII-XXII-XXIV: modified CLSID\InProcServer32

' search to use HKCU, then HKLM

'section XI: modified Classes\PROTOCOLS\Filter search to use HKCU, then HKLM

'section XII: added ColumnHandlers

'section XIII: rewrote to output non-default values in HKCU/HKLM

'section XXV: improved function logic, added ExpandEnvironmentStrings

' to DataBasePath value

'added SOCValue sub and StrOutCR function

'WriteValueData function: protected strName with StringFilter

'CoName function: removed StringFilter for findable file with Unicode name

 

'R45

'added colOS WMI error trap

'section VII: added WOW\cmdline and WOW\wowcmdline values

'modified function RegDataChk to handle empty string or missing

' name/value pair

'changed "(no data)" to "(value not found)"

 

'R46

'section VII: removed output of BootExecute strLine on WriteLine error

'section XIII, SOCValue sub: added check for shell default value

'added DDEX sub to look for open\ddeexec value in SOCValue sub

 

'R47

'section VIII: added wgalogon to Winlogon\Notify allowed entries

'section XIII: output default executable string via StringFilter

'section XXI: arTSPFi (TSP output array) initial REDIM statement

' changed from (2,0) to (3,0)

'section XXVI: tested service pathname returned by WMI for null or

' empty string before storing in array

'for compatibility with IE 7 RC1, modified sections:

' IV (Shell Extensions)

' V (SharedTaskScheduler)

' XXIV (bypass of IERESET.INF check, AboutURLs)

 

'R48

'section VII: added HKLM\System\CurrentControlSet\Control\SecurityProviders\SecurityProviders

 

'R49

'added message box to confirm choice of supplementary search

'added IWarn/HWarn strings with explanatory footer note if present

'abandoned roman numerals for section numbers

'added SecTest for section testing

'changed OS version error e-mail address

'section 1: added W95-specific matrix; HKCU...RunOnceEx for all OS's

' Policies/Explorer/Run for WMe, Run/RunOnce subkey launch for WMe,

' removed Policies/Explorer/Run & RunOnce/Setup warnings for NT4

'section 12: added AllFilesystemObjects

'section 14: removed Policy hierarchization, added registry

' keys, added GPRCaller and GPReconizer subs

'section 15: due to Policy hierarchization changes, lost detection of

' Active Desktop status

'section 20: added XML parsing for WVa

'section 22: restored "dormant" IE explorer bars to default

' operation, removed "dormant" label

'RtnValue function fixed for REG_BINARY & REG_MULTI_SZ, added REG_QWORD

'StrOutCR function renamed to StrOutSep, 3rd arg is sep character

'all sections: ensured compatibility with Vista RC1

 

'R50

'section 10: added FileSysPath to script directory even if script file

' not found (due to disconnection from domain)

'section 13: added StringFilter to every occurrence of strOut in

' SOCValue & DDEX subs

'section 26: added WXP httpfilter service

 

'R51

'renamed "Vista RC1" to "Vista"

'section 19: checked for error on retrieval of startup folders

'added script launch time to report footer

 

'R52

'protected NDAR/NDTAR from corrupt binary values

 

'R53

'modified section titles to match top comments section

'updated Configuration Detection Section line numbers

'section 13: added HKCU FileExt loop for WMe/W2K/WXP, modified main loop logic

'section 26: removed UtilMan from W2K default list, added 3 services

' to WVa default list

'added section 27: Accessibility Tools

'modified RtnValue function (DWORD value displays "dword:" instead of "hex:"),

' StringFilter function, SOCValue Sub

 

'R54

'section 7: added HKLM... Windows NT... Aedebug

'section 27: toggled flagIWarn for report footer

'capitalized HKLM\Software if HKCU\Software unaffected

 

'R55

'section 4: added 30 shell extensions from Vista Home Premium

'section 7: revised Winlogon name/value logic, added Winlogon\VmApplet

'section 26: removed 1 duplicate Vista service, improved Vista ServiceDll identification

'added functions SOCA/SYCA to manage display of "Software" & "System"

'replaced Chr(34) by DQ

 

'R56

'section 7: added HKLM\SYSTEM\CurrentControlSet\Control\BootVerificationProgram\ImagePath

' HKLM\SYSTEM\CurrentControlSet\Control\Lsa\Authentication Packages

' HKLM\SYSTEM\CurrentControlSet\Control\Session Manager\Execute

' HKLM\SYSTEM\CurrentControlSet\Control\Session Manager\SetupExecute

'section 25: treated "::1" as localhost

'modified RtnValue function (returns "value not set" if registry read

' throws error)

'replaced RegDataChk sub with RegDataChk_v2

 

'R57

'made testing alert sensitive to flagOut

'changed strOS to Public variable

'section 5: added Explorer\DeviceNotificationCallbacks\ for WVa

'added section 18: HKLM... Explorer\AutoplayHandlers\Handlers\

'section 27: added Network Provisioning Service (xmlprov.dll) to default XP services

'added IsCLSID & CLSIDPop functions

'rewrote SOCA/SYCA functions

 

'R58

'section 16: added IniFileMapping

'StringFilter function: trap Asc = 160 as corrupt character

'added ChkDefaultValue & ChkNameValues subs

 

 

'** Update Revision Number on line #15 **

[jgarcia 1]

Opa MAcgYvER everyONE,

 

O log do Silent está incompleto. Um log completo apresenta esta conjuntura aqui (Post #5).

 

Execute o SilentRunners novamente e poste um novo log. ;)

 

Abraços.

[MAcgYvER everyONE 0]

eh esse post #5 q falta?

'#5. HKLM... Explorer\DeviceNotificationCallbacks/SharedTaskScheduler/ShellExecuteHooks

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

Dim arAllowedCLSID(), ctrLow

 

ReDim arKeys(2)

arKeys(0) = "Software\Microsoft\Windows\CurrentVersion\Explorer\DeviceNotificationCallbacks"

arKeys(1) = "Software\Microsoft\Windows\CurrentVersion\Explorer\SharedTaskScheduler"

arKeys(2) = "Software\Microsoft\Windows\CurrentVersion\Explorer\ShellExecuteHooks"

 

ctrLow = 1

If strOS = "WVA" Then ctrLow = 0

 

'for each Explorer sub-key

For i = ctrLow To UBound(arKeys)

 

strSubTitle = SOCA("HKLM" & "\" & arKeys(i) & "\")

 

'set up allowed CLSID's & IPS names for each sub-key

If i = 0 Then 'DeviceNotificationCallbacks

 

ReDim arAllowedCLSID(0,1)

arAllowedCLSID(0,0) = "{8E25992B-373E-486E-80E5-BD23AE417E66}"

arAllowedCLSID(0,1) = "SyncCenter.dll"

 

ElseIf i = 1 Then 'SharedTaskScheduler

 

ReDim arAllowedCLSID(2,1)

arAllowedCLSID(0,0) = "{438755C2-A8BA-11D1-B96B-00A0C90312E1}"

arAllowedCLSID(0,1) = "browseui.dll"

arAllowedCLSID(1,0) = "{8C7461EF-2B13-11d2-BE35-3078302C2030}"

arAllowedCLSID(1,1) = "browseui.dll"

arAllowedCLSID(2,0) = "{553858A7-4922-4e7e-B1C1-97140C1C16EF}" 'IE 7

arAllowedCLSID(2,1) = "ieframe.dll"

 

ElseIf i = 2 Then 'ShellExecuteHooks

 

ReDim arAllowedCLSID(0,1)

arAllowedCLSID(0,0) = "{AEB6717E-7E19-11d0-97EE-00C04FD91972}"

arAllowedCLSID(0,1) = "shell32.dll"

 

End If 'which Explorer sub-key?

 

'find all the names in the Explorer key

oReg.EnumValues HKLM, arKeys(i), arNames, arType

 

'enumerate data if present

If IsArray(arNames) Then

 

'for each name

For Each strName In arNames

 

flagTitle = False

 

CLSIDLocTitle HKLM, arKeys(i), strName, strLocTitle

 

For ctrCH = intCLL To 1

 

ResolveCLSID strName, arHives(ctrCH,1), strCLSIDTitle, strIPSDLL

 

If strIPSDLL <> "" Then

 

flagFound = False

strCN = CoName(IDExe(strIPSDLL))

 

'for every CLSID

'see if CLSID, IPS filename are allowed & IPS CoName = "MS" & hive = HKLM

For j = 0 To UBound(arAllowedCLSID,1)

 

If LCase(strName) = LCase(arAllowedCLSID(j,0)) And _

LCase(Fso.GetFileName(strIPSDLL)) = LCase(arAllowedCLSID(j,1)) And _

strCN = MS And ctrCH = 1 Then

flagFound = True : strWarn = "" : Exit For

End If

 

Next 'allowed CLSID & IPS file name

 

If Not flagFound Then

strWarn = IWarn : flagIWarn = True

End If

 

'if IPS not allowed or ShowAll, output name & value

If Not flagFound Or flagShowAll Then

 

'output the title line if not already done

TitleLineWrite

 

If Not flagTitle Then

 

On Error Resume Next

oFN.WriteLine strWarn & DQ & strName & DQ &_

" = " & strLocTitle

'error check for W2K if SharedTaskScheduler value not set

intErrNum = Err.Number : Err.Clear

If intErrNum <> 0 Then oFN.WriteLine DQ & strName & DQ &_

" = (no title provided)"

flagTitle = True

On Error GoTo 0

 

End If

 

'output CLSID title, InProcServer32 DLL & CoName

oFN.WriteLine " -> {" & arHives(ctrCH,0) & "...CLSID} = " &_

strCLSIDTitle & vbCRLF & Space(19) & "\InProcServer32\(Default) = " &_

StringFilter(strIPSDLL,True) & strCN

 

End If 'unexpected data or ShowAll?

 

End If 'IPS exists?

 

Next 'CLSID Hive

 

Next 'arNames array member

 

Else 'arNames array not returned

 

'if ShowAll, output key name

If flagShowAll Then TitleLineWrite

 

End If 'arNames array exists

 

Next 'Explorer sub-key

 

'reset flags

flagFound = False

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

'recover array memory

ReDim arAllowedCLSID(0)

ReDim arKeys(0)

ReDim arNames(0)

 

End If 'SecTest?

[jgarcia 1]

eh esse post #5 q falta?

Não. Preciso que você poste um log igual ao contido no post citado.

[MAcgYvER everyONE 0]

http://rapidshare.com/files/146067114/Sile...unners.vbs.html

coloquei o log ai no rapidshare pra fica mais facil

[Mário Monteiro 179]

MAcgYvER everyONE, acredito que seja melhor sempre postar aqui os logs

[MAcgYvER everyONE 0]

'Silent Runners.vbs -- find out what starts up with Windows!

'(compatible with Windows 95/98/Millennium/NT 4.0/2000 Pro/XP Home & Pro/Vista)

'

'DO NOT REMOVE THIS HEADER!

'

'Copyright Andrew ARONOFF 18 May 2008, http://www.silentrunners.org/

'This script is provided without any warranty, either express or implied

'It may not be copied or distributed without permission

'

'** YOU RUN THIS SCRIPT AT YOUR OWN RISK! ** (END OF HEADER)

 

 

Option Explicit

 

Dim strRevNo : strRevNo = "58"

 

Public flagTest : flagTest = False 'True if in testing mode

'flagTest = True 'Uncomment to put in testing mode

Public arSecTest : arSecTest = Array() 'array of section numbers to test

 

Public intSection : intSection = 0 'section counter

 

'This script is divided into 29 sections.

 

'malware launch points:

' registry keys (1-12, 15)

' INI/INF-files (16-18)

' folders (19)

' enabled scheduled tasks (20)

' Winsock2 service provider DLLs (21)

' IE toolbars, explorer bars, extensions (22)

' started services (26)

' accessibility tools (27)

' keyboard driver filters (28)

' printer monitors (29)

 

'hijack points:

' System/Group Policies (14)

' prefixes for IE URLs (23)

' misc IE points (24)

' HOSTS file (25)

 

'Output is suppressed if deemed normal unless the -all parameter is used

'Section XVIII is skipped unless the -supp/-all parameters are used or

'the first message box is answered "No" and the next message box "Yes"

 

' 1. HKCU/HKLM... Run/RunOnce/RunOnce\Setup/RunOnceEx

' HKLM... RunServices/RunServicesOnce

' HKCU/HKLM... Policies\Explorer\Run

' 2. HKLM... Active Setup\Installed Components\

' HKCU... Active Setup\Installed Components\

' (StubPath <> "" And HKLM version # > HKCU version #)

' 3. HKLM... Explorer\Browser Helper Objects\

' 4. HKLM... Shell Extensions\Approved\

' 5. HKLM... Explorer\DeviceNotificationCallbacks/SharedTaskScheduler/ShellExecuteHooks

' 6. HKCU/HKLM... ShellServiceObjectDelayLoad\

' 7. HKCU/HKLM... Command Processor\AutoRun

' HKCU... Policies\System\Shell (W2K/WXP/WVa only)

' HKCU... Windows\load & run

' HKLM... Windows\AppInit_DLLs

' HKLM... Windows NT... Aedebug\

' HKCU/HKLM... Windows NT... Winlogon\Shell

' HKLM... Windows NT... Winlogon\Userinit, System, Ginadll, Taskman, VmApplet

' HKLM... Control\BootVerificationProgram\ImagePath

' HKLM... Control\Lsa\Authentication Packages

' HKLM... Control\SafeBoot\Option\UseAlternateShell

' HKLM... Control\SecurityProviders\SecurityProviders

' HKLM... Control\Session Manager\BootExecute

' HKLM... Control\Session Manager\Execute

' HKLM... Control\Session Manager\SetupExecute

' HKLM... Control\Session Manager\WOW\cmdline, wowcmdline

' 8. HKLM... Windows NT... Winlogon\Notify\ (subkey names/DLLName values <> O/S-specific dictionary data)

' 9. HKLM... Windows NT... Image File Execution Options ("Debugger" subkeys)

'10. HKCU/HKLM... Policies... Startup/Shutdown, Logon/Logoff scripts (W2K/WXP/WVa)

'11. HKCU/HKLM Protocols\Filter

'12. Context menu shell extensions

'13. HKCU/HKLM executable file type (bat/cmd/com/exe/hta/pif/scr)

'14. System/Group Policies

'15. Enabled Wallpaper & Screen Saver

'16. WIN.INI load/run, SYSTEM.INI shell/scrnsave.exe, WINSTART.BAT, IniFileMapping

'17. AUTORUN.INF in root directory of local fixed disks

'18. HKLM... Explorer\AutoplayHandlers\Handlers

'19. DESKTOP.INI in any local fixed disk directory (section skipped by default)

'20. Startup Directories

'21. Enabled Scheduled Tasks

'22. Winsock2 Service Provider DLLs

'23. Internet Explorer Toolbars, Explorer Bars, Extensions

'24. Internet Explorer URL Prefixes

'25. Misc. IE Hijack Points

'26. HOSTS file

'27. Started Services

'28. Accessibility Tools

'29. Keyboard Driver Filters

'30. Print Monitors

 

Dim Wshso : Set Wshso = WScript.CreateObject("WScript.Shell")

Dim WshoArgs : Set WshoArgs = WScript.Arguments

Dim intErrNum, intMB, intMB1 'Err.Number, MsgBox return value x 2

 

Const DQ = """"

 

'Configuration Detection Section

 

' FileSystemObject creation error (117)

' CScript/WScript (155)

' Dim (171)

' GetFileVersion(WinVer.exe) (VBScript 5.1) (186)

' OS version (233)

' WMI (294)

' Dim (390)

' command line arguments (463)

' supplementary search MsgBox (561)

' startup MsgBox (598)

' CreateTextFile error (627)

' output file header (663)

' WXP SP2 (677)

 

On Error Resume Next

Dim Fso : Set Fso = CreateObject("Scripting.FileSystemObject")

intErrNum = Err.Number : Err.Clear

On Error Goto 0

 

If intErrNum <> 0 Then

 

strURL = "http://tinyurl.com/7nn6"

 

intMB = MsgBox (DQ & "Silent Runners" & DQ &_

" cannot access file services critical to" & vbCRLF &_

"proper script operation." & vbCRLF & vbCRLF &_

"If you are running Windows XP, make sure that the" &_

vbCRLF & DQ & "Cryptographic Services" & DQ &_

" service is started." & vbCRLF & vbCRLF &_

"You can also try reinstalling the latest version of the MS" &_

vbCRLF & "Windows Script Host." & vbCRLF & vbCRLF &_

"Press " & DQ & "OK" & DQ & " to direct your browser to " &_

"the download site or" & vbCRLF & Space(10) & DQ & "Cancel" &_

DQ & " to quit.", vbOKCancel + vbCritical, _

"Can't access the FileSystemObject!")

 

'if dl wanted now, send browser to dl site

If intMB = 1 Then Wshso.Run strURL

 

WScript.Quit

 

End If

 

Dim oNetwk : Set oNetwk = WScript.CreateObject("WScript.Network")

 

Const HKLM = &H80000002, HKCU = &H80000001

Const strHKLM = "HKLM", strHKCU = "HKCU"

Const REG_SZ=1, REG_EXPAND_SZ=2, REG_BINARY=3, REG_DWORD=4, REG_MULTI_SZ=7

Const REG_SZ_NO_CN=9 'create this reg value type to avoid CoName

'search for strings that are not file names

Const REG_QWORD = 11

Const MS = " [MS]"

Const LBr = "{"

Const IWarn = "<<!>> ", HWarn = "<<H>> "

 

'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 'echo and continue if it works

flagOut = "C" 'assume CScript-compatible

WScript.Echo "Neither " & DQ & "WSCRIPT.EXE" & DQ & " nor " &_

DQ & "CSCRIPT.EXE" & DQ & " was detected as " &_

"the script host." & vbCRLF & DQ & "Silent Runners" & DQ &_

" will assume that the script host is CSCRIPT-compatible and will" & vbCRLF &_

"use WScript.Echo for all messages."

End If 'script host

 

Dim strflagTest : strflagTest = ""

If flagTest Then

strflagTest = "TEST "

 

If flagOut = "W" Then

Wshso.Popup "Silent Runners is in testing mode.",1, _

"Testing, testing, 1-2-3...", vbOKOnly + vbExclamation

Else

WScript.Echo "Silent Runners is in testing mode." & vbCRLF

End If 'flagOut?

End If 'flagTest?

 

Const SysFolder = 1 : Const WinFolder = 0

Public strOS : strOS = "Unknown"

Public strOSLong : strOSLong = "Unknown"

Public strOSXP : strOSXP = "Windows XP Home" 'XP Home or Pro

Public strWinDir : strWinDir = Wshso.ExpandEnvironmentStrings("%WINDIR%")

Public strPgmFilesDir : strPgmFilesDir = Wshso.ExpandEnvironmentStrings("%PROGRAMFILES%")

Public strFPSF : strFPSF = Fso.GetSpecialFolder(SysFolder).Path 'FullPathSystemFolder

Public strFPWF : strFPWF = Fso.GetSpecialFolder(WinFolder).Path 'FullPathWindowsFolder

Public strExeBareName 'bare file name w/o windows or system folder prefixes

Dim strSysVer 'Winver.exe version number

Dim intErrNum1, intErrNum2, intErrNum3, intErrNum4, intErrNum5, intErrNum6 'error number

Dim intLenValue 'value length

Dim strURL 'download URL

'assume Group Policies cannot be set in the O/S

Dim flagGP : flagGP = False

'HKCU/HKLM CLSID Lower Limit, default is HKLM for O/S <= NT4

Dim intCLL : intCLL = 1

 

'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 : Err.Clear

On Error Goto 0

 

'if GetFileVersion returns error due to old WSH 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 Windows Script Host (WSH) 5.1 " &_

"or higher to run." & vbCRLF & vbCRLF & "Press " & DQ & "OK" &_

DQ & " to direct your browser to the WSH download site or " &_

DQ & "Cancel" & DQ & " to quit." & vbCRLF & vbCRLF &_

"(WMI is also required. If it's missing, download instructions " &_

"will appear later.)", vbOKCancel + vbExclamation, _

"Unsupported Windows Script Host 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 DQ & "Silent Runners" & DQ & " requires " &_

"Windows Script Host 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 'VBScript version 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"

 

ElseIf Instr(Left(strSysVer,8),"4.0.0.11") > 0 Then

strOS = "W98" : strOSLong = "Windows 95 SR2 (OEM)"

 

ElseIf Instr(Left(strSysVer,3),"5.0") > 0 Then

strOS = "W2K" : strOSLong = "Windows 2000" : : intCLL = 0 : flagGP = True

 

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" : intCLL = 0

 

If Instr(strSysVer,".2180") > 0 Then strOSLong = "Windows XP SP2"

 

ElseIf Instr(Left(strSysVer,3),"4.9") > 0 Then

strOS = "WME" : strOSLong = "Windows Me (Millennium Edition)"

 

ElseIf Instr(Left(strSysVer,3),"5.2") > 0 Then

strOS = "WXP" : strOSLong = "Windows Server 2003 (interpreted as Windows XP)"

flagGP = True : intCLL = 0

 

ElseIf Instr(Left(strSysVer,3),"6.0") > 0 Then

strOS = "WVA" : strOSLong = "Windows Vista"

flagGP = True : intCLL = 0

 

Else 'unknown strSysVer

 

If flagOut = "W" Then

 

intMB = MsgBox ("The " & DQ & "Silent Runners" & DQ &_

" script cannot determine the operating system." & vbCRLF & vbCRLF &_

"Click " & DQ & "OK" & DQ & " to send an e-mail to the " &_

"author, providing the following information:" & vbCRLF & vbCRLF &_

"WINVER.EXE file version = " & strSysVer & vbCRLF & vbCRLF &_

"or click " & DQ & "Cancel" & DQ & " to quit.", _

49,"O/S Unknown!")

 

If intMB = 1 Then Wshso.Run "mailto:Andrew%20Aronoff%20" &_

"<%6F%73.%76%65%72.%65%72%72%6F%72@%73%69%6C%65%6E%74%72%75%6E%6E%65%72%73.%6F%72%67>?" &_

"subject=Silent%20Runners%20OS%20Version%20Error&body=WINVER.EXE" &_

"%20file%20version%20=%20" & strSysVer

 

Else 'flagOut = "C"

 

WScript.Echo DQ & "Silent Runners" & DQ & " cannot " &_

"determine the operating system." & vbCRLF & vbCRLF & "This script will exit."

 

End If 'flagOut?

 

WScript.Quit

 

End If 'OS id'd from strSysVer?

 

'use WMI to connect to the registry

On Error Resume Next

Dim oReg : Set oReg = GetObject("winmgmts:\root\default:StdRegProv")

intErrNum = Err.Number : Err.Clear

On Error Goto 0

 

'detect WMI connection error

If intErrNum <> 0 Then

 

strURL = ""

 

'for W98/NT4, assume WMI not installed and direct to d/l URL

If strOS = "W98" Or strOS = "NT4" Then

 

If strOS = "W98" Then strURL = "http://tinyurl.com/jbxe"

If strOS = "NT4" Then strURL = "http://tinyurl.com/7wd7"

 

'invite user to download WMI & quit

If flagOut = "W" Then

 

intMB = MsgBox ("This script requires " & DQ & "WMI" &_

DQ & ", Windows Management Instrumentation, to run." &_

vbCRLF & vbCRLF & "It can be downloaded at: " & strURL &_

vbCRLF & vbCRLF & "Press " & DQ & "OK" & DQ &_

" to direct your browser to the download site or " &_

DQ & "Cancel" & DQ & " to quit.",_

vbOKCancel + vbCritical,"WMI Not Installed!")

 

If intMB = 1 Then Wshso.Run strURL

 

'at command line, explain & quit

Else 'flagOut = "C"

 

WScript.Echo DQ & "Silent Runners" & DQ & " requires " &_

DQ & "WMI" & DQ & ", Windows Management Instrumentation, " &_

"to run." & vbCRLF & vbCRLF & "It can be downloaded at: " & strURL

 

End If

 

'for W2K/WXP/WVa, explain how to start the WMI service

ElseIf strOS = "W2K" Or strOS = "WXP" or strOS = "WVA" Then

 

If strOS = "W2K" Then strLine = "Settings | Control Panel | "

If strOS = "WXP" Then strLine = "Control Panel | "

If strOS = "WVA" Then strLine = "Control Panel | Classic View | "

 

'explain how to turn on WMI service

If flagOut = "W" Then

 

MsgBox "This script requires Windows Management Instrumentation" &_

" to run." & vbCRLF & vbCRLF & "Click on Start | " & strLine &_

"Administrative Tools | Services," & vbCRLF &_

"and start the " & DQ & "Windows Management Instrumentation" &_

DQ & " service.",vbOKOnly + vbCritical,"WMI Service not running!"

 

'at command line, explain & quit

Else 'flagOut = "C"

 

WScript.Echo DQ & "Silent Runners" & DQ & " requires " &_

"Windows Management Instrumentation to run." & vbCRLF & vbCRLF &_

"Click on Start | " & strLine & "Administrative " &_

"Tools | Services" & vbCRLF & "and start the " & DQ &_

"Windows Management Instrumentation" & DQ & " service."

 

End If 'flagOut?

 

Else 'WMe

 

'say there's a WMI problem

If flagOut = "W" Then

 

MsgBox "This script requires WMI (Windows Management Instrumentation)" &_

" to run," & vbCRLF & "but WMI is not running correctly.", _

vbOKOnly + vbCritical,"WMI problem!"

 

'at command line, explain & quit

Else 'flagOut = "C"

 

WScript.Echo DQ & "Silent Runners" & DQ & " requires " &_

"WMI (Windows Management Instrumentation) to run," & vbCRLF &_

"but WMI is not running correctly."

 

End If 'flagOut?

 

End If 'which O/S?

 

WScript.Quit

 

End If 'WMI execution error

 

'array of Run keys, counter x 10, hive member, startup folder file,

'startup file shortcut, IERESET.INF file

Dim arRunKeys, i, j, k, l, ii, jj, kk, ll, mm, nn, oHiveElmt, oSUFi, oSUSC

'dictionary, keys, items, hard disk collection

Dim arSK, arSKk, arSKi, colDisks

 

'arrays: Run key names, keys, sub-keys, value type, SecurityProviders,

' Protocol filters, values

Dim arNames(), arKeys(), arSubKeys(), arType, arSP, arFilter(), arValues

'Sub-Directory DeskTop.Ini array, Sub-Directory Error array, Error array

'Recognized GP names, allowed GP names, accessibility tools

Public arSDDTI(), arSDErr(), arErr(), arRecNames(), arAllowedNames(), arAcc()

 

'DeskTop.Ini counter, Error counter x 2, Classes data Hive counter

Public ctrArDTI, ctrArErr, ctrErr, ctrCH

Public ctrFo : ctrFo = 0 'folder counter

 

'name member, key array member x 4, O/S, drive root directory, work file

Dim oName, oKey, oKey2, strMemKey, strMemSubKey, oOS, oRoot, oFileWk

'values x 11

Dim strValue, strValue1, strValue2, strValue3, strValue4, strValue5, strValue6

Dim strVal, intValue, intValue1, intValue2, strCmd

'name, single character, startup folder name & display name,

'startup folder, array member, temp var

Dim strName, strChr, arSUFN, arSUFDN, oSUF, strArMember, strTmp, strTmp2

'output string x 3

Public strOut, strOut1, strOut2

 

'output file msg x 2, warning string, title line

Dim strLine, strLine1, strLine2, strWarn, strTitleLine

'infection/hijack warning detection flags -- add footer note if True

Public flagIWarn : flagIWarn = False

Public flagHWarn : flagHWarn = False

'register key x 4, sub-key, CLSID key

Dim strKey, strKey1, strKey2, strKey3, strSubKey, strCLSIDKey

'output file name string (incl. path), file name (wo path),

'PIF path string, single binary character

Dim strFN, strFNNP, strPIFTgt, bin1C

Public datLaunch : datLaunch = Now 'script launch time

Public intCnt 'counter

'ref time, time taken by 2 pop-up boxes

Public datRef : datRef = 0

Public datPUB1 : datPUB1 = 0 : Public datPUB2 : datPUB2 = 0

 

'TRUE if show all output (default values not filtered)

Public flagShowAll : flagShowAll = False

Dim strRptOutput : strRptOutput = "Output limited to non-default values, " &_

"except where indicated by " & DQ & "{++}" & DQ 'output file string

Public strTitle : strTitle = ""

Public strSubTitle : strSubTitle = ""

Public strSubSubTitle : strSubSubTitle = ""

Public flagNVP : flagNVP = False 'existence of name/value pairs in a key

Public flagInfect : flagInfect = False 'flag infected condition

Dim flagMatch 'flag matching keys

Dim flagAllow 'flag key on approved list

Dim flagFound 'flag something that exists

Public flagValueFound 'flag value that exists in Registry

Dim flagDirArg : flagDirArg = False 'presence of output directory argument

Dim flagIsCLSID : flagIsCLSID = False 'true if argument in CLSID format

Dim flagTitle 'True if title has already been written

Dim flagAllArg : flagAllArg = False 'presence of all output argument

Dim flagArray 'flag array containing elements

Public flagSupp : flagSupp = False 'do *not* check for DESKTOP.INI in all

'directories of local fixed disks

Dim intLBSP 'Last BackSlash Position in path string

Dim intSS 'lowest sort subscript

Dim intType 'value type

Dim strDLL, strCN 'DLL name, company name

'string to signal all output by default

Public strAllOutDefault : strAllOutDefault = ""

 

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

 

'hive array

Public arHives(1,1)

arHives(0,0) = "HKCU" : arHives(1,0) = "HKLM"

arHives(0,1) = &H80000001 : arHives(1,1) = &H80000002

 

'set up argument usage message string

 

Dim strLSp, strCSp 'Leading Spaces, Centering Spaces

strLSp = Space(4) : strCSp = Space(33) 'WScript spacing

If flagOut = "C" Then 'CScript spacing

strLsp = Space(3) : strCSp = Space(28)

End If

 

Dim strMsg : strMsg = "Only two arguments are permitted:" &_

vbCRLF & vbCRLF &_

"1. the name of an existing directory for the output report" &_

vbCRLF & strLSp & "(embed in quotes if it contains spaces)" &_

vbCRLF & vbCRLF & strCSp & "AND:" & vbCRLF & vbCRLF &_

"2. " & DQ & "-supp" & DQ & " to search " &_

"all directories for DESKTOP.INI DLL" & vbCRLF &_

strLSp & "launch points" &_

vbCRLF & vbCRLF & strCSp & "-OR-" & vbCRLF & vbCRLF &_

"3. " & DQ & "-all" & DQ & " to output all non-empty " &_

"values and all launch" & vbCRLF & strLSp & "points checked"

 

'check if output directory or "-all" or "-supp" was supplied as argument

If WshoArgs.length > 0 And WshoArgs.length <= 2 Then

 

For i = 0 To WshoArgs.length-1

 

'if directory arg not already passed and arg directory exists

If Not flagDirArg And Fso.FolderExists(WshoArgs(i)) Then

 

'get the path & toggle the directory arg flag

Dim oOFFo : Set oOFFo = Fso.GetFolder(WshoArgs(i))

strPathOFFo = oOFFo.Path : flagDirArg = True

If Right(strPathOFFo,1) <> "\" Then strPathOFFo = strPathOFFo & "\"

Set oOFFo=Nothing

 

'if -all arg not already passed and is this arg

ElseIf Not flagAllArg And LCase(WshoArgs(i)) = "-all" Then

 

'toggle ShowAll flag, toggle the all arg flag, fill report string

flagShowAll = True : flagAllArg = True

strRptOutput = "Output of all locations checked and all values found."

 

'if -all arg not already passed and is this arg

ElseIf Not flagAllArg And LCase(WshoArgs(i)) = "-supp" Then

flagSupp = True : flagAllArg = True

strRptOutput = "Search enabled of all directories on local fixed " &_

"drives for DESKTOP.INI" & vbCRLF & " DLL launch points" &_

vbCRLF & strRptOutput

 

'argument can't be interpreted, so explain & quit

Else

 

If flagOut = "W" Then 'pop up a message window

 

Wshso.Popup "The argument:" & vbCRLF &_

DQ & UCase(WshoArgs(i)) & DQ & vbCRLF &_

"... can't be interpreted." & vbCRLF & vbCRLF &_

strMsg,10,"Bad Script Argument", vbOKOnly + vbExclamation

 

Else 'flagOut = "C" 'write the message to the console

 

WScript.Echo vbCRLF & "The argument: " &_

DQ & UCase(WshoArgs(i)) & DQ &_

" can't be interpreted." & vbCRLF & vbCRLF &_

strMsg & vbCRLF

 

End If 'WScript host?

 

WScript.Quit

 

End If 'argument can be interpreted?

 

Next 'argument

 

'too many args passed

ElseIf WshoArgs.length > 2 Then

 

'explain & quit

If flagOut = "W" Then 'pop up a message window

 

Wshso.Popup "Too many arguments (" & WshoArgs.length & ") were passed." &_

vbCRLF & vbCRLF & strMsg,10,"Too Many Arguments",_

vbOKOnly + vbCritical

 

Else 'flagOut = "C" 'write the message to the console

 

WScript.Echo "Too many arguments (" & WshoArgs.length & ") were passed." &_

vbCRLF & vbCRLF & strMsg & vbCRLF

 

End If 'WScript host?

 

WScript.Quit

 

End If 'directory arguments passed?

 

Set WshoArgs=Nothing

 

datRef = Now

 

'if no cmd line argument for flagSupp and not testing, show popup

If Not flagTest And Not flagShowAll And Not flagSupp And flagOut = "W" Then

 

intMB = Wshso.Popup ("Do you want to skip the supplementary search?" &_

vbCRLF & "(It typically takes several minutes.)" & vbCRLF & vbCRLF &_

"Press " & DQ & "Yes" & DQ & Space(5) &_

" to skip the supplementary search (default)" & vbCRLF & vbCRLF &_

Space(10) & DQ & "No" & DQ & Space(6) &_

" to perform it, or" & vbCRLF & vbCRLF &_

Space(10) & DQ & "Cancel" & DQ &_

" to get more information at the web site" & vbCRLF &_

Space(25) & "and exit the script.",_

15,"Skip supplementary search?",_

vbYesNoCancel + vbQuestion + vbDefaultButton1 + vbSystemModal)

 

If intMB = vbNo Then

 

flagSupp = True

 

intMB1 = MsgBox ("Are you SURE you want to run the supplementary " &_

"search?" & vbCRLF & vbCRLF & "It's _rarely_ necessary " &_

"and it takes a *long* time." & vbCRLF & vbCRLF & "Press " & DQ &_

"Yes" & DQ & " to confirm running the supplementary search, " &_

"or" & vbCRLF & Space(10) & DQ & "No" & DQ & " to run without it.", _

vbYesNo + vbQuestion + vbDefaultButton2 + vbSystemModal,"Are you sure?")

 

If intMB1 = vbNo Then flagSupp = False

 

ElseIf intMB = vbCancel Then

Wshso.Run "http://www.silentrunners.org/sr_thescript.html#supp"

WScript.Quit

End If

 

End If

 

datPUB1 = DateDiff("s",datRef,Now) : datRef = Now

 

'inform user that script has started

If Not flagTest Then

If flagOut = "W" Then

Wshso.PopUp DQ & "Silent Runners" & DQ & " has started." &_

vbCRLF & vbCRLF & "A message box like this one will appear " &_

"when it's done." & vbCRLF & vbCRLF & "Please be patient...",3,_

"Silent Runners R" & strRevNo & " startup", _

vbOKOnly + vbInformation + vbSystemModal

Else

WScript.Echo DQ & "Silent Runners" & DQ & " has started." &_

" Please be patient..." & vbCRLF

End If 'flagOut?

End If 'flagTest?

 

datPUB2 = DateDiff("s",datRef,Now)

 

'create output file name with computer name & today's date

'Startup Programs (pc_name_here) yyyy-mm-dd.txt

 

strFNNP = "Startup Programs (" & oNetwk.ComputerName & ") " &_

FmtDate(datLaunch) & " " & FmtHMS(datLaunch) & ".txt"

strFN = strPathOFFo & strflagTest & strFNNP

On Error Resume Next

If Fso.FileExists(strFN) Then Fso.DeleteFile(strFN)

Err.Clear

Public oFN : Set oFN = Fso.CreateTextFile(strFN,True)

intErrNum = Err.Number : Err.Clear

On Error Goto 0

 

'if can't create report file

If intErrNum > 0 Then

 

strURL = "http://www.silentrunners.org/Silent%20Runners%20RED.vbs"

 

'invite user to run RED version & quit

If flagOut = "W" Then

 

intMB = MsgBox ("The script cannot create its report file. " &_

"This is a known, intermittent" & vbCRLF & "problem under " &_

strOSLong & "." & vbCRLF & vbCRLF &_

"An alternative script version is available for download. " &_

"After it runs, " & vbCRLF & "the script you're using now will " &_

"run correctly." & vbCRLF & vbCRLF &_

"Press " & DQ & "OK" & DQ & " to direct your browser " &_

"to the alternate script location, or" & vbCRLF & Space(10) &_

DQ & "Cancel" & DQ & " to quit.",49,"CreateTextFile Error!")

 

'if alternative script wanted now, send browser to dl site

If intMB = 1 Then Wshso.Run strURL

 

'explain & quit

Else 'flagOut = "C"

 

WScript.Echo DQ & "Silent Runners" & DQ & " cannot " &_

"create the report file." & vbCRLF & vbCRLF &_

"An alternative script is available. Run it, then rerun this version." &_

vbCRLF & "The alternative script can be downloaded at: " & vbCRLF &_

vbCRLF & strURL

 

End If

 

WScript.Quit

 

End If 'report file creation error?

 

'add report header

Set oNetwk=Nothing

 

oFN.WriteLine DQ & "Silent Runners.vbs" & DQ &_

", revision " & strRevNo & ", http://www.silentrunners.org/" &_

vbCRLF & "Operating System: " & strOSLong & vbCRLF & strRptOutput

 

'test for WMI corruption and use WMI to differentiate between

'WXP Home & WXP Pro

 

'get the O/S collection

Dim colOS : Set colOS = GetObject("winmgmts:\root\cimv2").ExecQuery _

("Select * from Win32_OperatingSystem")

 

On Error Resume Next

 

Err.Clear

 

For Each oOS in colOS

 

If strOS = "WXP" Then

 

'modify strOSXP if O/S = Pro

If InStr(1,LCase(oOS.Name),"professional",1) > 0 Then

strOSXP = "Windows XP Professional"

flagGP = True

End If

'modify strOSXP if SP2

If Right(strOSLong,3) = "SP2" Then strOSXP = strOSXP & " SP2"

 

End If 'WXP?

 

Next 'oOS

 

If Err.Number <> 0 Then

 

strURL = "http://go.microsoft.com/fwlink/?LinkId=62562"

 

oFN.WriteLine vbCRLF & "FATAL ERROR!" & vbCRLF & String(12,"-") &_

vbCRLF & vbCRLF & DQ & "Silent Runners" & DQ &_

" cannot use WMI to identify the operating system." &_

vbCRLF & "This is caused by corruption of the WMI installation." &_

vbCRLF & vbCRLF &_

"WMI is complex and it is recommended that you use a Microsoft" &_

vbCRLF & "tool, " & DQ & "WMIDiag.vbs," & DQ & " to diagnose WMI " &_

"on your system." & vbCRLF & vbCRLF & "It can be downloaded here:" &_

vbCRLF & vbCRLF & strURL

 

intMB = MsgBox (DQ & "Silent Runners" & DQ & " cannot use WMI to " &_

"identify the operating system." & vbCRLF & "This is caused by " &_

"corruption of the WMI installation." &_

vbCRLF & vbCRLF &_

"WMI is complex and it is recommended that you use a Microsoft" &_

vbCRLF & "tool, " & DQ & "WMIDiag.vbs," & DQ & " to diagnose WMI " &_

"on your system." &_

vbCRLF & vbCRLF &_

"Press " & DQ & "OK" & DQ & " to direct your browser to the " &_

"WMIDiag download site or" &_

vbCRLF & Space(10) & DQ & "Cancel" & DQ & " to quit.",_

vbOKCancel + vbCritical + + vbSystemModal + vbDefaultButton2,_

"Can't iterate Win32_OperatingSystem!")

 

'if dl wanted now, send browser to dl site

If intMB = 1 Then Wshso.Run strURL

 

WScript.Quit

 

End If 'Err.Number<>0?

 

On Error Goto 0

 

Set colOS=Nothing

[MAcgYvER everyONE 0]

'#1. HKCU/HKLM... Run/RunOnce/RunOnce\Setup/RunOnceEx

' HKLM... RunServices/RunServicesOnce

' HKCU/HKLM... Policies\Explorer\Run

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

'write registry header lines to file

strTitle = "Startup items buried in registry:"

TitleLineWrite

 

'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

 

'0 Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\Run

'1 Software\Microsoft\Windows\CurrentVersion\Run

'2 Software\Microsoft\Windows\CurrentVersion\RunOnce

'3 Software\Microsoft\Windows\CurrentVersion\RunOnce\Setup

'4 Software\Microsoft\Windows\CurrentVersion\RunOnceEx

'5 Software\Microsoft\Windows\CurrentVersion\RunServices

'6 Software\Microsoft\Windows\CurrentVersion\RunServicesOnce

 

'Hive HKCU - 0 HKLM - 1

'

'Key 0 1 2 3 4 5 6 0 1 2 3 4 5 6

'Index

 

'O/S:

'W95 0,0 2,0 2,0 0,0 2,1 0,0 0,0 0,0 2,0 2,0 0,0 2,1 2,0 2,0

'W98 0,0 2,0 2,0 0,0 2,1 0,0 0,0 0,0 2,0 2,0 2,0 2,1 2,0 2,0

'WMe 2,1 2,1 2,0 2,0 2,1 0,0 0,0 2,1 2,1 2,0 2,0 2,1 2,0 2,0

'NT4 0,0 2,0 2,0 0,0 2,1 0,0 0,0 0,0 2,0 2,0 0,0 2,1 0,0 0,0

'W2K 2,1 2,1 2,1 0,0 2,1 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 2,1 0,0 0,0 2,0 2,0 2,0 0,0 2,1 0,0 0,0

'WS2K3 ??? <-------------------- ??? --------------------> ???

'WVa 2,0 2,0 2,0 0,0 2,1 0,0 0,0 2,0 2,0 2,0 0,0 2,1 0,0 0,0

 

'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

If strOS = "W98" Then

arRegFlag(0,1,0) = 2 'HKCU,Run = no-warn

arRegFlag(0,2,0) = 2 'HKCU,RunOnce = no-warn

arRegFlag(0,4,0) = 2 'HKCU,RunOnceEx = no-warn

arRegFlag(0,4,1) = 1 'HKCU,RunOnceEx = sub-keys

arRegFlag(1,1,0) = 2 'HKLM,Run = no-warn

arRegFlag(1,2,0) = 2 'HKLM,RunOnce = no-warn

'don't set HKLM,RunOnce\Setup for W95

If strOSLong = "Windows 98" Then _

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

 

If strOS = "WME" 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,3,0) = 2 'HKCU,RunOnce\Setup = no-warn

arRegFlag(0,4,0) = 2 'HKCU,RunOnceEx = no-warn

arRegFlag(0,4,1) = 1 'HKCU,RunOnceEx = 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,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

If strOS = "NT4" Then

arRegFlag(0,1,0) = 2 'HKCU,Run = no-warn

arRegFlag(0,2,0) = 2 'HKCU,RunOnce = no-warn

arRegFlag(0,4,0) = 2 'HKCU,RunOnceEx = no-warn

arRegFlag(0,4,1) = 1 'HKCU,RunOnceEx = sub-keys

arRegFlag(1,1,0) = 2 'HKLM,Run = no-warn

arRegFlag(1,2,0) = 2 'HKLM,RunOnce = no-warn

arRegFlag(1,4,0) = 2 'HKLM,RunOnceEx = no-warn

arRegFlag(1,4,1) = 1 'HKLM,RunOnceEx = sub-keys

End If

 

'W2K

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 (incl. Setup)

arRegFlag(0,4,0) = 2 'HKCU,RunOnceEx = no-warn

arRegFlag(0,4,1) = 1 'HKCU,RunOnceEx = 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 (incl. Setup)

arRegFlag(1,4,0) = 2 'HKLM,RunOnceEx = no-warn

arRegFlag(1,4,1) = 1 'HKLM,RunOnceEx = sub-keys

End If

 

'WXP/WVa

If strOs = "WXP" Or strOS = "WVA" 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(0,4,0) = 2 'HKLM,RunOnceEx = no-warn

arRegFlag(0,4,1) = 1 'HKLM,RunOnceEx = sub-keys

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,4,0) = 2 'HKLM,RunOnceEx = no-warn

arRegFlag(1,4,1) = 1 'HKLM,RunOnceEx = sub-keys

End If

 

'for each hive

For i = 0 To 1

 

'for each key

For j = 0 To 6

 

'if not ShowAll, show all output for Run keys

If j = 1 And Not flagShowAll Then strAllOutDefault = " {++}"

 

'if key is not ignored

If arRegFlag(i,j,0) > 0 Then

 

flagNVP = False

 

'intialize string with warning if necessary

strWarn = ""

If arRegFlag(i,j,0) = 1 Then strWarn = "EXECUTION UNLIKELY: "

 

'INFO

'with no name/value pairs (sub-keys are identical)

' IsArray TypeName UBound

'W98 True "Variant()" -1

'WMe True "Variant()" -1

'NT4 True "Variant()" -1

'W2K False "Null" error (--)

'WXP False "Null" error (--)

'WS2K3 True "Variant()" error (--)

'WVa False "Null" error (--)

 

EnumNVP arHives(i,1), arRunKeys(j), arNames, arType

 

If flagNVP Then 'name/value pairs exist

 

'write the full key name

oFN.WriteLine vbCRLF & SOCA(arHives(i,0) & "\" & arRunKeys(j) &_

"\" & strAllOutDefault)

 

'for each data type in the names array

For k = LBound(arNames) To UBound(arNames)

 

'use the type to find the value

strValue = RtnValue (arHives(i,1), arRunKeys(j), arNames(k), arType(k))

'write the name & value

WriteValueData arNames(k), strValue, arType(k), strWarn

 

Next 'member of names array

 

Else 'no name/value pairs

 

If flagShowAll Then _

oFN.WriteLine vbCRLF & SOCA(arHives(i,0) & "\" & arRunKeys(j) & "\")

 

End If 'flagNVP?

 

'recurse subkeys if necessary

If arRegFlag(i,j,1) = 1 Then

 

'put all subkeys into array

oReg.EnumKey arHives(i,1),arRunKeys(j),arKeys

 

'excludes W2K/WXP/WVa with no sub-keys

If IsArray(arKeys) Then

 

'excludes W98/WMe/NT4/WS2K3 with no sub-keys

For Each strMemKey in arKeys

 

flagNVP = False

strSubKey = arRunKeys(j) & "\" & strMemKey

 

EnumNVP arHives(i,1), arRunKeys(j) & "\" & strMemKey,arNames,arType

 

If flagNVP Then 'if name/value pairs exist

 

'write the full key name

oFN.WriteLine vbCRLF & SOCA(arHives(i,0) & "\" & strSubKey &_

"\" & strAllOutDefault)

 

'for each data type in the names array

For k = LBound(arNames) To UBound(arNames)

 

'use the type to find the value

strValue = RtnValue (arHives(i,1), strSubKey, arNames(k), arType(k))

'write the name & value

WriteValueData arNames(k), strValue, arType(k), strWarn

 

Next 'member of names array

 

Else 'no name/value pairs

 

If flagShowAll Then _

oFN.WriteLine vbCRLF & SOCA(arHives(i,0) & "\" & strSubKey & "\")

 

End If 'flagNVP?

 

Next 'sub-key

 

End If 'sub-keys exist? W2K/WXP/WS2K3/WVa

 

End If 'enum sub-keys?

 

End If 'arRegFlag(i,j,0) > 0

 

Next 'Run key

 

Next 'Hive

 

strAllOutDefault = "" : flagNVP = False

 

'recover array memory

ReDim arRunKeys(0)

ReDim arKeys(0)

ReDim arRegFlag(0)

 

End If 'flagTest And SecTest?

 

 

 

 

'#2. HKLM... Active Setup\Installed Components\

' HKCU... Active Setup\Installed Components\

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

'flags True if only numeric & comma chrs in Version values

Dim flagHKLMVer, flagHKCUVer

'StubPath Value string, HKLM Version value, HKCU Version value, HKLM program name

Dim strSPV, strHKLMVer, strHKCUVer, strPgmName

Dim arHKLMKeys, arHKCUKeys, strHKLMKey, strHKCUKey

 

strKey = "Software\Microsoft\Active Setup\Installed Components"

 

strSubTitle = SOCA("HKLM" & "\" & strKey & "\")

 

'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 strHKLMKey In arHKLMKeys

 

'INFO

'Default Value not set:

'W98/WMe: returns 0, strValue = ""

'NT4/W2K/WXP/WVa: returns non-zero, strValue = Null

 

'Non-Default name inexistent:

'W98/WMe/NT4/W2K/WXP/WVa: returns non-zero, strValue = Null

 

'Non-Default Value not set:

'W2K: returns 0, strValue = unwritable string

'W98/WMe/NT4/WXP/WVa: returns 0, strValue = ""

 

'get the StubPath value

intErrNum = oReg.GetStringValue (HKLM,strKey & "\" & strHKLMKey,"StubPath",strSPV)

 

'if the StubPath name exists And value set (exc for W2K!)

If intErrNum = 0 And strSPV <> "" Then

 

flagMatch = False

 

'if HKCU keys present

If IsArray(arHKCUKeys) Then

 

'for each HKCU key

For Each strHKCUKey in arHKCUKeys

 

'if identical HKLM key exists

If LCase(strHKLMKey) = LCase(strHKCUKey) Then

 

'assume Version fmts are OK

flagHKLMVer = True : flagHKCUVer = True

 

'get HKLM & HKCU Version values

intErrNum1 = oReg.GetStringValue (HKLM,strKey & "\" & strHKLMKey, _

"Version",strHKLMVer) 'HKLM Version #

intErrNum2 = oReg.GetStringValue (HKCU,strKey & "\" & strHKCUKey, _

"Version",strHKCUVer) 'HKCU Version #

 

'if HKLM Version name exists And value set (exc for W2K!)

If intErrNum1 = 0 And 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

 

'if HKCU Version name exists And value set (exc for W2K!)

If intErrNum2 = 0 And 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 assigned) 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 Then flagMatch = True

If flagHKLMVer And flagHKCUVer And strHKCUVer >= strHKLMVer Then flagMatch = True

 

Else 'HKLM Version name doesn't exist Or value not set (exc for W2K!)

 

flagMatch = True

 

End If 'HKLM Version name exists And value set (exc for W2K!)?

 

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

 

flagAllow = False 'assume StubPath DLL not on approved list

strCN = CoName(IDExe(strSPV))

 

'test for approved StubPath DLL

If LCase(strHKLMKey) = ">{22d6f312-b0f6-11d0-94ab-0080c74c7e95}" And _

(InStr(LCase(strSPV),"wmpocm.exe") > 0 Or _

InStr(LCase(strSPV),"unregmp2.exe") > 0) And _

strCN = MS And Not flagShowAll Then flagAllow = True

 

'StubPath DLL not approved

If Not flagAllow Then

 

'get the default value (program name)

intErrNum3 = oReg.GetStringValue (HKLM,strKey & "\" & strHKLMKey,"",strPgmName)

'enclose pgm name in quotes if name exists and default value isn't empty

If intErrNum3 = 0 And strPgmName <> "" Then

strPgmName = DQ & strPgmName & DQ

Else

strPgmName = "(no title provided)"

End If

 

TitleLineWrite

 

'output the CLSID & pgm name

oFN.WriteLine strHKLMKey & "\(Default) = " &_

StringFilter(strPgmName,False)

 

On Error Resume Next

'output the StubPath value

oFN.WriteLine Space(Len(strHKLMKey)+1) & "\StubPath = " &_

DQ & strSPV & DQ & strCN

'error check for W2K if StubPath value not set

If Err.Number <> 0 Then oFN.WriteLine Space(Len(strHKLMKey)+1) & "\StubPath = " &_

"(value not set)"

Err.Clear

On Error GoTo 0

 

End If 'flagAllow false?

 

End If 'flagMatch false?

 

End If 'StubPath value exists?

 

Next 'HKLM Installed Components subkey

 

End If 'HKLM Installed Components subkeys exist?

 

If flagShowAll Then TitleLineWrite

 

'recover array memory

ReDim arHKLMKeys(0)

ReDim arHKCUKeys(0)

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

End If 'SecTest?

 

 

 

 

'#3. HKLM... Explorer\Browser Helper Objects\

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

strKey = "Software\Microsoft\Windows\CurrentVersion\Explorer\Browser Helper Objects"

strSubTitle = SOCA("HKLM" & "\" & strKey & "\")

 

'find all the subkeys

oReg.EnumKey HKLM, strKey, arSubKeys

 

'enumerate data if present

If IsArray(arSubKeys) Then

 

'for each key

For Each strSubKey In arSubKeys

 

flagTitle = False

 

CLSIDLocTitle HKLM, strKey & "\" & strSubKey, "", strLocTitle

 

For ctrCH = intCLL To 1

 

ResolveCLSID strSubKey, arHives(ctrCH,1), strCLSIDTitle, strIPSDLL

 

If strIPSDLL <> "" Then

 

'output the title line if not already done

TitleLineWrite

 

If Not flagTitle Then

 

'error check for W2K if value not set

On Error Resume Next

oFN.WriteLine strSubKey & "\(Default) = " & strLocTitle

intErrNum = Err.Number : Err.Clear

If intErrNum <> 0 Then oFN.WriteLine strSubKey &_

"\(Default) = (no title provided)"

flagTitle = True

On Error GoTo 0

 

End If

 

'output CLSID title, InProcServer32 DLL & CoName

oFN.WriteLine " -> {" & arHives(ctrCH,0) & "...CLSID} = " &_

strCLSIDTitle & vbCRLF & Space(19) & "\InProcServer32\(Default) = " &_

StringFilter(strIPSDLL,True) & CoName(IDExe(strIPSDLL))

 

End If 'strIPSDLL exists?

 

Next 'CLSID hive

 

Next 'BHO subkey

 

End If 'BHO subkeys exist?

 

'if ShowAll, output the key name if not already done

If flagShowAll Then TitleLineWrite

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

'recover array memory

ReDim arSubKeys(0)

 

End If 'SecTest?

 

 

 

 

'#4. HKLM... Shell Extensions\Approved\

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

'CLSID value, InProcessServer32 DLL name & output file version,

'CLSID Key Title display flag

Dim strCLSID, strIPSDLL, strIPSDLLOut, strCLSIDTitle, strLocTitle

 

'Shell Extension Approved array

Dim arSEA()

ReDim arSEA(418,1)

'WXP

arSEA(0,0) = "{00022613-0000-0000-C000-000000000046}" : arSEA(0,1) = "mmsys.cpl"

arSEA(1,0) = "{176d6597-26d3-11d1-b350-080036a75b03}" : arSEA(1,1) = "icmui.dll"

arSEA(2,0) = "{1F2E5C40-9550-11CE-99D2-00AA006E086C}" : arSEA(2,1) = "rshx32.dll"

arSEA(3,0) = "{3EA48300-8CF6-101B-84FB-666CCB9BCD32}" : arSEA(3,1) = "docprop.dll"

arSEA(4,0) = "{40dd6e20-7c17-11ce-a804-00aa003ca9f6}" : arSEA(4,1) = "ntshrui.dll"

arSEA(5,0) = "{41E300E0-78B6-11ce-849B-444553540000}" : arSEA(5,1) = "themeui.dll"

arSEA(6,0) = "{42071712-76d4-11d1-8b24-00a0c9068ff3}" : arSEA(6,1) = "deskadp.dll"

arSEA(7,0) = "{42071713-76d4-11d1-8b24-00a0c9068ff3}" : arSEA(7,1) = "deskmon.dll"

arSEA(8,0) = "{42071714-76d4-11d1-8b24-00a0c9068ff3}" : arSEA(8,1) = "deskpan.dll"

arSEA(9,0) = "{4E40F770-369C-11d0-8922-00A024AB2DBB}" : arSEA(9,1) = "dssec.dll"

arSEA(10,0) = "{513D916F-2A8E-4F51-AEAB-0CBC76FB1AF8}" : arSEA(10,1) = "SlayerXP.dll"

arSEA(11,0) = "{56117100-C0CD-101B-81E2-00AA004AE837}" : arSEA(11,1) = "shscrap.dll"

arSEA(12,0) = "{59099400-57FF-11CE-BD94-0020AF85B590}" : arSEA(12,1) = "diskcopy.dll"

arSEA(13,0) = "{59be4990-f85c-11ce-aff7-00aa003ca9f6}" : arSEA(13,1) = "ntlanui2.dll"

arSEA(14,0) = "{5DB2625A-54DF-11D0-B6C4-0800091AA605}" : arSEA(14,1) = "icmui.dll"

arSEA(15,0) = "{675F097E-4C4D-11D0-B6C1-0800091AA605}" : arSEA(15,1) = "icmui.dll"

arSEA(16,0) = "{764BF0E1-F219-11ce-972D-00AA00A14F56}" : arSEA(16,1) = ""

arSEA(17,0) = "{77597368-7b15-11d0-a0c2-080036af3f03}" : arSEA(17,1) = "printui.dll"

arSEA(18,0) = "{7988B573-EC89-11cf-9C00-00AA00A14F56}" : arSEA(18,1) = "dskquoui.dll"

arSEA(19,0) = "{853FE2B1-B769-11d0-9C4E-00C04FB6C6FA}" : arSEA(19,1) = ""

arSEA(20,0) = "{85BBD920-42A0-1069-A2E4-08002B30309D}" : arSEA(20,1) = "syncui.dll"

arSEA(21,0) = "{88895560-9AA2-1069-930E-00AA0030EBC8}" : arSEA(21,1) = "hticons.dll"

arSEA(22,0) = "{BD84B380-8CA2-1069-AB1D-08000948F534}" : arSEA(22,1) = "fontext.dll"

arSEA(23,0) = "{DBCE2480-C732-101B-BE72-BA78E9AD5B27}" : arSEA(23,1) = "icmui.dll"

arSEA(24,0) = "{F37C5810-4D3F-11d0-B4BF-00AA00BBB723}" : arSEA(24,1) = "rshx32.dll"

arSEA(25,0) = "{f81e9010-6ea4-11ce-a7ff-00aa003ca9f6}" : arSEA(25,1) = "ntshrui.dll"

arSEA(26,0) = "{f92e8c40-3d33-11d2-b1aa-080036a75b03}" : arSEA(26,1) = "deskperf.dll"

arSEA(27,0) = "{7444C717-39BF-11D1-8CD9-00C04FC29D45}" : arSEA(27,1) = "cryptext.dll"

arSEA(28,0) = "{7444C719-39BF-11D1-8CD9-00C04FC29D45}" : arSEA(28,1) = "cryptext.dll"

arSEA(29,0) = "{7007ACC7-3202-11D1-AAD2-00805FC1270E}" : arSEA(29,1) = "NETSHELL.dll"

arSEA(30,0) = "{992CFFA0-F557-101A-88EC-00DD010CCC48}" : arSEA(30,1) = "NETSHELL.dll"

arSEA(31,0) = "{E211B736-43FD-11D1-9EFB-0000F8757FCD}" : arSEA(31,1) = "wiashext.dll"

arSEA(32,0) = "{FB0C9C8A-6C50-11D1-9F1D-0000F8757FCD}" : arSEA(32,1) = "wiashext.dll"

arSEA(33,0) = "{905667aa-acd6-11d2-8080-00805f6596d2}" : arSEA(33,1) = "wiashext.dll"

arSEA(34,0) = "{3F953603-1008-4f6e-A73A-04AAC7A992F1}" : arSEA(34,1) = "wiashext.dll"

arSEA(35,0) = "{83bbcbf3-b28a-4919-a5aa-73027445d672}" : arSEA(35,1) = "wiashext.dll"

arSEA(36,0) = "{F0152790-D56E-4445-850E-4F3117DB740C}" : arSEA(36,1) = "remotepg.dll"

arSEA(37,0) = "{5F327514-6C5E-4d60-8F16-D07FA08A78ED}" : arSEA(37,1) = "wuaucpl.cpl"

arSEA(38,0) = "{60254CA5-953B-11CF-8C96-00AA00B8708C}" : arSEA(38,1) = "wshext.dll"

arSEA(39,0) = "{2206CDB2-19C1-11D1-89E0-00C04FD7A829}" : arSEA(39,1) = "oledb32.dll"

arSEA(40,0) = "{DD2110F0-9EEF-11cf-8D8E-00AA0060F5BF}" : arSEA(40,1) = "mstask.dll"

arSEA(41,0) = "{797F1E90-9EDD-11cf-8D8E-00AA0060F5BF}" : arSEA(41,1) = "mstask.dll"

arSEA(42,0) = "{D6277990-4C6A-11CF-8D87-00AA0060F5BF}" : arSEA(42,1) = "mstask.dll"

arSEA(43,0) = "{0DF44EAA-FF21-4412-828E-260A8728E7F1}" : arSEA(43,1) = ""

arSEA(44,0) = "{2559a1f0-21d7-11d4-bdaf-00c04f60b9f0}" : arSEA(44,1) = "shdocvw.dll"

arSEA(45,0) = "{2559a1f1-21d7-11d4-bdaf-00c04f60b9f0}" : arSEA(45,1) = "shdocvw.dll"

arSEA(46,0) = "{2559a1f2-21d7-11d4-bdaf-00c04f60b9f0}" : arSEA(46,1) = "shdocvw.dll"

arSEA(47,0) = "{2559a1f3-21d7-11d4-bdaf-00c04f60b9f0}" : arSEA(47,1) = "shdocvw.dll"

arSEA(48,0) = "{2559a1f4-21d7-11d4-bdaf-00c04f60b9f0}" : arSEA(48,1) = "shdocvw.dll"

arSEA(49,0) = "{2559a1f5-21d7-11d4-bdaf-00c04f60b9f0}" : arSEA(49,1) = "shdocvw.dll"

arSEA(50,0) = "{D20EA4E1-3957-11d2-A40B-0C5020524152}" : arSEA(50,1) = "shdocvw.dll"

arSEA(51,0) = "{D20EA4E1-3957-11d2-A40B-0C5020524153}" : arSEA(51,1) = "shdocvw.dll"

arSEA(52,0) = "{875CB1A1-0F29-45de-A1AE-CFB4950D0B78}" : arSEA(52,1) = "shmedia.dll"

arSEA(53,0) = "{40C3D757-D6E4-4b49-BB41-0E5BBEA28817}" : arSEA(53,1) = "shmedia.dll"

arSEA(54,0) = "{E4B29F9D-D390-480b-92FD-7DDB47101D71}" : arSEA(54,1) = "shmedia.dll"

arSEA(55,0) = "{87D62D94-71B3-4b9a-9489-5FE6850DC73E}" : arSEA(55,1) = "shmedia.dll"

arSEA(56,0) = "{A6FD9E45-6E44-43f9-8644-08598F5A74D9}" : arSEA(56,1) = "shmedia.dll"

arSEA(57,0) = "{c5a40261-cd64-4ccf-84cb-c394da41d590}" : arSEA(57,1) = "shmedia.dll"

arSEA(58,0) = "{5E6AB780-7743-11CF-A12B-00AA004AE837}" : arSEA(58,1) = "browseui.dll"

arSEA(59,0) = "{22BF0C20-6DA7-11D0-B373-00A0C9034938}" : arSEA(59,1) = "browseui.dll"

arSEA(60,0) = "{91EA3F8B-C99B-11d0-9815-00C04FD91972}" : arSEA(60,1) = "browseui.dll"

arSEA(61,0) = "{6413BA2C-B461-11d1-A18A-080036B11A03}" : arSEA(61,1) = "browseui.dll"

arSEA(62,0) = "{F61FFEC1-754F-11d0-80CA-00AA005B4383}" : arSEA(62,1) = "browseui.dll"

arSEA(63,0) = "{7BA4C742-9E81-11CF-99D3-00AA004AE837}" : arSEA(63,1) = "browseui.dll"

arSEA(64,0) = "{30D02401-6A81-11d0-8274-00C04FD5AE38}" : arSEA(64,1) = "browseui.dll"

arSEA(65,0) = "{32683183-48a0-441b-a342-7c2a440a9478}" : arSEA(65,1) = "browseui.dll"

arSEA(66,0) = "{169A0691-8DF9-11d1-A1C4-00C04FD75D13}" : arSEA(66,1) = "browseui.dll"

arSEA(67,0) = "{07798131-AF23-11d1-9111-00A0C98BA67D}" : arSEA(67,1) = "browseui.dll"

arSEA(68,0) = "{AF4F6510-F982-11d0-8595-00AA004CD6D8}" : arSEA(68,1) = "browseui.dll"

arSEA(69,0) = "{01E04581-4EEE-11d0-BFE9-00AA005B4383}" : arSEA(69,1) = "browseui.dll"

arSEA(70,0) = "{A08C11D2-A228-11d0-825B-00AA005B4383}" : arSEA(70,1) = "browseui.dll"

arSEA(71,0) = "{00BB2763-6A77-11D0-A535-00C04FD7D062}" : arSEA(71,1) = "browseui.dll"

arSEA(72,0) = "{7376D660-C583-11d0-A3A5-00C04FD706EC}" : arSEA(72,1) = "browseui.dll"

arSEA(73,0) = "{6756A641-DE71-11d0-831B-00AA005B4383}" : arSEA(73,1) = "browseui.dll"

arSEA(74,0) = "{6935DB93-21E8-4ccc-BEB9-9FE3C77A297A}" : arSEA(74,1) = "browseui.dll"

arSEA(75,0) = "{7e653215-fa25-46bd-a339-34a2790f3cb7}" : arSEA(75,1) = "browseui.dll"

arSEA(76,0) = "{acf35015-526e-4230-9596-becbe19f0ac9}" : arSEA(76,1) = "browseui.dll"

arSEA(77,0) = "{E0E11A09-5CB8-4B6C-8332-E00720A168F2}" : arSEA(77,1) = "browseui.dll"

arSEA(78,0) = "{00BB2764-6A77-11D0-A535-00C04FD7D062}" : arSEA(78,1) = "browseui.dll"

arSEA(79,0) = "{03C036F1-A186-11D0-824A-00AA005B4383}" : arSEA(79,1) = "browseui.dll"

arSEA(80,0) = "{00BB2765-6A77-11D0-A535-00C04FD7D062}" : arSEA(80,1) = "browseui.dll"

arSEA(81,0) = "{ECD4FC4E-521C-11D0-B792-00A0C90312E1}" : arSEA(81,1) = "browseui.dll"

arSEA(82,0) = "{3CCF8A41-5C85-11d0-9796-00AA00B90ADF}" : arSEA(82,1) = "browseui.dll"

arSEA(83,0) = "{ECD4FC4C-521C-11D0-B792-00A0C90312E1}" : arSEA(83,1) = "browseui.dll"

arSEA(84,0) = "{ECD4FC4D-521C-11D0-B792-00A0C90312E1}" : arSEA(84,1) = "browseui.dll"

arSEA(85,0) = "{DD313E04-FEFF-11d1-8ECD-0000F87A470C}" : arSEA(85,1) = "browseui.dll"

arSEA(86,0) = "{EF8AD2D1-AE36-11D1-B2D2-006097DF8C11}" : arSEA(86,1) = "browseui.dll"

arSEA(87,0) = "{EFA24E61-B078-11d0-89E4-00C04FC9E26E}" : arSEA(87,1) = "shdocvw.dll"

arSEA(88,0) = "{0A89A860-D7B1-11CE-8350-444553540000}" : arSEA(88,1) = "shdocvw.dll"

arSEA(89,0) = "{E7E4BC40-E76A-11CE-A9BB-00AA004AE837}" : arSEA(89,1) = "shdocvw.dll"

arSEA(90,0) = "{A5E46E3A-8849-11D1-9D8C-00C04FC99D61}" : arSEA(90,1) = "shdocvw.dll"

arSEA(91,0) = "{FBF23B40-E3F0-101B-8488-00AA003E56F8}" : arSEA(91,1) = "shdocvw.dll"

arSEA(92,0) = "{3C374A40-BAE4-11CF-BF7D-00AA006946EE}" : arSEA(92,1) = "shdocvw.dll"

arSEA(93,0) = "{FF393560-C2A7-11CF-BFF4-444553540000}" : arSEA(93,1) = "shdocvw.dll"

arSEA(94,0) = "{7BD29E00-76C1-11CF-9DD0-00A0C9034933}" : arSEA(94,1) = "shdocvw.dll"

arSEA(95,0) = "{7BD29E01-76C1-11CF-9DD0-00A0C9034933}" : arSEA(95,1) = "shdocvw.dll"

arSEA(96,0) = "{CFBFAE00-17A6-11D0-99CB-00C04FD64497}" : arSEA(96,1) = "shdocvw.dll"

arSEA(97,0) = "{A2B0DD40-CC59-11d0-A3A5-00C04FD706EC}" : arSEA(97,1) = "shdocvw.dll"

arSEA(98,0) = "{67EA19A0-CCEF-11d0-8024-00C04FD75D13}" : arSEA(98,1) = "shdocvw.dll"

arSEA(99,0) = "{131A6951-7F78-11D0-A979-00C04FD705A2}" : arSEA(99,1) = "shdocvw.dll"

arSEA(100,0) = "{9461b922-3c5a-11d2-bf8b-00c04fb93661}" : arSEA(100,1) = "shdocvw.dll"

arSEA(101,0) = "{3DC7A020-0ACD-11CF-A9BB-00AA004AE837}" : arSEA(101,1) = "shdocvw.dll"

arSEA(102,0) = "{871C5380-42A0-1069-A2EA-08002B30309D}" : arSEA(102,1) = "shdocvw.dll"

arSEA(103,0) = "{EFA24E64-B078-11d0-89E4-00C04FC9E26E}" : arSEA(103,1) = "shdocvw.dll"

arSEA(104,0) = "{9E56BE60-C50F-11CF-9A2C-00A0C90A90CE}" : arSEA(104,1) = "sendmail.dll"

arSEA(105,0) = "{9E56BE61-C50F-11CF-9A2C-00A0C90A90CE}" : arSEA(105,1) = "sendmail.dll"

arSEA(106,0) = "{88C6C381-2E85-11D0-94DE-444553540000}" : arSEA(106,1) = "occache.dll"

arSEA(107,0) = "{E6FB5E20-DE35-11CF-9C87-00AA005127ED}" : arSEA(107,1) = "webcheck.dll"

arSEA(108,0) = "{ABBE31D0-6DAE-11D0-BECA-00C04FD940BE}" : arSEA(108,1) = "webcheck.dll"

arSEA(109,0) = "{F5175861-2688-11d0-9C5E-00AA00A45957}" : arSEA(109,1) = "webcheck.dll"

arSEA(110,0) = "{08165EA0-E946-11CF-9C87-00AA005127ED}" : arSEA(110,1) = "webcheck.dll"

arSEA(111,0) = "{E3A8BDE6-ABCE-11d0-BC4B-00C04FD929DB}" : arSEA(111,1) = "webcheck.dll"

arSEA(112,0) = "{E8BB6DC0-6B4E-11d0-92DB-00A0C90C2BD7}" : arSEA(112,1) = "webcheck.dll"

arSEA(113,0) = "{7D559C10-9FE9-11d0-93F7-00AA0059CE02}" : arSEA(113,1) = "webcheck.dll"

arSEA(114,0) = "{E6CC6978-6B6E-11D0-BECA-00C04FD940BE}" : arSEA(114,1) = "webcheck.dll"

arSEA(115,0) = "{D8BD2030-6FC9-11D0-864F-00AA006809D9}" : arSEA(115,1) = "webcheck.dll"

arSEA(116,0) = "{7FC0B86E-5FA7-11d1-BC7C-00C04FD929DB}" : arSEA(116,1) = "webcheck.dll"

arSEA(117,0) = "{352EC2B7-8B9A-11D1-B8AE-006008059382}" : arSEA(117,1) = "appwiz.cpl"

arSEA(118,0) = "{0B124F8F-91F0-11D1-B8B5-006008059382}" : arSEA(118,1) = "appwiz.cpl"

arSEA(119,0) = "{CFCCC7A0-A282-11D1-9082-006008059382}" : arSEA(119,1) = "appwiz.cpl"

arSEA(120,0) = "{e84fda7c-1d6a-45f6-b725-cb260c236066}" : arSEA(120,1) = "shimgvw.dll"

arSEA(121,0) = "{66e4e4fb-f385-4dd0-8d74-a2efd1bc6178}" : arSEA(121,1) = "shimgvw.dll"

arSEA(122,0) = "{3F30C968-480A-4C6C-862D-EFC0897BB84B}" : arSEA(122,1) = "shimgvw.dll"

arSEA(123,0) = "{9DBD2C50-62AD-11d0-B806-00C04FD706EC}" : arSEA(123,1) = "shimgvw.dll"

arSEA(124,0) = "{EAB841A0-9550-11cf-8C16-00805F1408F3}" : arSEA(124,1) = "shimgvw.dll"

arSEA(125,0) = "{eb9b1153-3b57-4e68-959a-a3266bc3d7fe}" : arSEA(125,1) = "shimgvw.dll"

arSEA(126,0) = "{CC6EEFFB-43F6-46c5-9619-51D571967F7D}" : arSEA(126,1) = "netplwiz.dll"

arSEA(127,0) = "{add36aa8-751a-4579-a266-d66f5202ccbb}" : arSEA(127,1) = "netplwiz.dll"

arSEA(128,0) = "{6b33163c-76a5-4b6c-bf21-45de9cd503a1}" : arSEA(128,1) = "netplwiz.dll"

arSEA(129,0) = "{58f1f272-9240-4f51-b6d4-fd63d1618591}" : arSEA(129,1) = "netplwiz.dll"

arSEA(130,0) = "{7A9D77BD-5403-11d2-8785-2E0420524153}" : arSEA(130,1) = ""

arSEA(131,0) = "{E88DCCE0-B7B3-11d1-A9F0-00AA0060FA31}" : arSEA(131,1) = "zipfldr.dll"

arSEA(132,0) = "{BD472F60-27FA-11cf-B8B4-444553540000}" : arSEA(132,1) = "zipfldr.dll"

arSEA(133,0) = "{888DCA60-FC0A-11CF-8F0F-00C04FD7D062}" : arSEA(133,1) = "zipfldr.dll"

arSEA(134,0) = "{f39a0dc0-9cc8-11d0-a599-00c04fd64433}" : arSEA(134,1) = "cdfview.dll"

arSEA(135,0) = "{f3aa0dc0-9cc8-11d0-a599-00c04fd64434}" : arSEA(135,1) = "cdfview.dll"

arSEA(136,0) = "{f3ba0dc0-9cc8-11d0-a599-00c04fd64435}" : arSEA(136,1) = "cdfview.dll"

arSEA(137,0) = "{f3da0dc0-9cc8-11d0-a599-00c04fd64437}" : arSEA(137,1) = "cdfview.dll"

arSEA(138,0) = "{f3ea0dc0-9cc8-11d0-a599-00c04fd64438}" : arSEA(138,1) = "cdfview.dll"

arSEA(139,0) = "{63da6ec0-2e98-11cf-8d82-444553540000}" : arSEA(139,1) = "msieftp.dll"

arSEA(140,0) = "{883373C3-BF89-11D1-BE35-080036B11A03}" : arSEA(140,1) = "docprop2.dll"

arSEA(141,0) = "{A9CF0EAE-901A-4739-A481-E35B73E47F6D}" : arSEA(141,1) = "docprop2.dll"

arSEA(142,0) = "{8EE97210-FD1F-4B19-91DA-67914005F020}" : arSEA(142,1) = "docprop2.dll"

arSEA(143,0) = "{0EEA25CC-4362-4A12-850B-86EE61B0D3EB}" : arSEA(143,1) = "docprop2.dll"

arSEA(144,0) = "{6A205B57-2567-4A2C-B881-F787FAB579A3}" : arSEA(144,1) = "docprop2.dll"

arSEA(145,0) = "{28F8A4AC-BBB3-4D9B-B177-82BFC914FA33}" : arSEA(145,1) = "docprop2.dll"

arSEA(146,0) = "{8A23E65E-31C2-11d0-891C-00A024AB2DBB}" : arSEA(146,1) = "dsquery.dll"

arSEA(147,0) = "{9E51E0D0-6E0F-11d2-9601-00C04FA31A86}" : arSEA(147,1) = "dsquery.dll"

arSEA(148,0) = "{163FDC20-2ABC-11d0-88F0-00A024AB2DBB}" : arSEA(148,1) = "dsquery.dll"

arSEA(149,0) = "{F020E586-5264-11d1-A532-0000F8757D7E}" : arSEA(149,1) = "dsquery.dll"

arSEA(150,0) = "{0D45D530-764B-11d0-A1CA-00AA00C16E65}" : arSEA(150,1) = "dsuiext.dll"

arSEA(151,0) = "{62AE1F9A-126A-11D0-A14B-0800361B1103}" : arSEA(151,1) = "dsuiext.dll"

arSEA(152,0) = "{ECF03A33-103D-11d2-854D-006008059367}" : arSEA(152,1) = "mydocs.dll"

arSEA(153,0) = "{ECF03A32-103D-11d2-854D-006008059367}" : arSEA(153,1) = "mydocs.dll"

arSEA(154,0) = "{4a7ded0a-ad25-11d0-98a8-0800361b1103}" : arSEA(154,1) = "mydocs.dll"

arSEA(155,0) = "{750fdf0e-2a26-11d1-a3ea-080036587f03}" : arSEA(155,1) = "cscui.dll"

arSEA(156,0) = "{10CFC467-4392-11d2-8DB4-00C04FA31A66}" : arSEA(156,1) = "cscui.dll"

arSEA(157,0) = "{AFDB1F70-2A4C-11d2-9039-00C04F8EEB3E}" : arSEA(157,1) = "cscui.dll"

arSEA(158,0) = "{143A62C8-C33B-11D1-84FE-00C04FA34A14}" : arSEA(158,1) = "agentpsh.dll"

arSEA(159,0) = "{ECCDF543-45CC-11CE-B9BF-0080C87CDBA6}" : arSEA(159,1) = "dfsshlex.dll"

arSEA(160,0) = "{60fd46de-f830-4894-a628-6fa81bc0190d}" : arSEA(160,1) = "photowiz.dll"

arSEA(161,0) = "{7A80E4A8-8005-11D2-BCF8-00C04F72C717}" : arSEA(161,1) = "mmcshext.dll"

arSEA(162,0) = "{0CD7A5C0-9F37-11CE-AE65-08002B2E1262}" : arSEA(162,1) = "cabview.dll"

arSEA(163,0) = "{32714800-2E5F-11d0-8B85-00AA0044F941}" : arSEA(163,1) = "wabfind.dll"

arSEA(164,0) = "{8DD448E6-C188-4aed-AF92-44956194EB1F}" : arSEA(164,1) = "wmpshell.dll"

arSEA(165,0) = "{CE3FB1D1-02AE-4a5f-A6E9-D9F1B4073E6C}" : arSEA(165,1) = "wmpshell.dll"

arSEA(166,0) = "{F1B9284F-E9DC-4e68-9D7E-42362A59F0FD}" : arSEA(166,1) = "wmpshell.dll"

'W2K

arSEA(167,0) = "{41E300E0-78B6-11ce-849B-444553540000}" : arSEA(167,1) = "plustab.dll"

arSEA(168,0) = "{1A9BA3A0-143A-11CF-8350-444553540000}" : arSEA(168,1) = "shell32.dll"

arSEA(169,0) = "{20D04FE0-3AEA-1069-A2D8-08002B30309D}" : arSEA(169,1) = "shell32.dll"

arSEA(170,0) = "{86747AC0-42A0-1069-A2E6-08002B30309D}" : arSEA(170,1) = "shell32.dll"

arSEA(171,0) = "{0AFACED1-E828-11D1-9187-B532F1E9575D}" : arSEA(171,1) = "shell32.dll"

arSEA(172,0) = "{12518493-00B2-11d2-9FA5-9E3420524153}" : arSEA(172,1) = "shell32.dll"

arSEA(173,0) = "{21B22460-3AEA-1069-A2DC-08002B30309D}" : arSEA(173,1) = "shell32.dll"

arSEA(174,0) = "{B091E540-83E3-11CF-A713-0020AFD79762}" : arSEA(174,1) = "shell32.dll"

arSEA(175,0) = "{FBF23B41-E3F0-101B-8488-00AA003E56F8}" : arSEA(175,1) = "shell32.dll"

arSEA(176,0) = "{C2FBB630-2971-11d1-A18C-00C04FD75D13}" : arSEA(176,1) = "shell32.dll"

arSEA(177,0) = "{C2FBB631-2971-11d1-A18C-00C04FD75D13}" : arSEA(177,1) = "shell32.dll"

arSEA(178,0) = "{13709620-C279-11CE-A49E-444553540000}" : arSEA(178,1) = "shell32.dll"

arSEA(179,0) = "{62112AA1-EBE4-11cf-A5FB-0020AFE7292D}" : arSEA(179,1) = "shell32.dll"

arSEA(180,0) = "{4622AD11-FF23-11d0-8D34-00A0C90F2719}" : arSEA(180,1) = "shell32.dll"

arSEA(181,0) = "{7BA4C740-9E81-11CF-99D3-00AA004AE837}" : arSEA(181,1) = "shell32.dll"

arSEA(182,0) = "{D969A300-E7FF-11d0-A93B-00A0C90F2719}" : arSEA(182,1) = "shell32.dll"

arSEA(183,0) = "{09799AFB-AD67-11d1-ABCD-00C04FC30936}" : arSEA(183,1) = "shell32.dll"

arSEA(184,0) = "{3FC0B520-68A9-11D0-8D77-00C04FD70822}" : arSEA(184,1) = "shell32.dll"

arSEA(185,0) = "{75048700-EF1F-11D0-9888-006097DEACF9}" : arSEA(185,1) = "shell32.dll"

arSEA(186,0) = "{6D5313C0-8C62-11D1-B2CD-006097DF8C11}" : arSEA(186,1) = "shell32.dll"

arSEA(187,0) = "{57651662-CE3E-11D0-8D77-00C04FC99D61}" : arSEA(187,1) = "shell32.dll"

arSEA(188,0) = "{4657278A-411B-11d2-839A-00C04FD918D0}" : arSEA(188,1) = "shell32.dll"

arSEA(189,0) = "{A470F8CF-A1E8-4f65-8335-227475AA5C46}" : arSEA(189,1) = "shell32.dll"

arSEA(190,0) = "{568804CA-CBD7-11d0-9816-00C04FD91972}" : arSEA(190,1) = "browseui.dll"

arSEA(191,0) = "{5b4dae26-b807-11d0-9815-00c04fd91972}" : arSEA(191,1) = "browseui.dll"

arSEA(192,0) = "{8278F931-2A3E-11d2-838F-00C04FD918D0}" : arSEA(192,1) = "browseui.dll"

arSEA(193,0) = "{E13EF4E4-D2F2-11d0-9816-00C04FD91972}" : arSEA(193,1) = "browseui.dll"

arSEA(194,0) = "{ECD4FC4F-521C-11D0-B792-00A0C90312E1}" : arSEA(194,1) = "browseui.dll"

arSEA(195,0) = "{D82BE2B0-5764-11D0-A96E-00C04FD705A2}" : arSEA(195,1) = "browseui.dll"

arSEA(196,0) = "{0E5CBF21-D15F-11d0-8301-00AA005B4383}" : arSEA(196,1) = "browseui.dll"

arSEA(197,0) = "{7487cd30-f71a-11d0-9ea7-00805f714772}" : arSEA(197,1) = "browseui.dll"

arSEA(198,0) = "{8BEBB290-52D0-11D0-B7F4-00C04FD706EC}" : arSEA(198,1) = "thumbvw.dll"

arSEA(199,0) = "{EAB841A0-9550-11CF-8C16-00805F1408F3}" : arSEA(199,1) = "thumbvw.dll"

arSEA(200,0) = "{1AEB1360-5AFC-11D0-B806-00C04FD706EC}" : arSEA(200,1) = "thumbvw.dll"

arSEA(201,0) = "{9DBD2C50-62AD-11D0-B806-00C04FD706EC}" : arSEA(201,1) = "thumbvw.dll"

arSEA(202,0) = "{500202A0-731E-11D0-B829-00C04FD706EC}" : arSEA(202,1) = "thumbvw.dll"

arSEA(203,0) = "{0B124F8C-91F0-11D1-B8B5-006008059382}" : arSEA(203,1) = "appwiz.cpl"

arSEA(204,0) = "{fe1290f0-cfbd-11cf-a330-00aa00c16e65}" : arSEA(204,1) = "dsfolder.dll"

arSEA(205,0) = "{9E51E0D0-6E0F-11d2-9601-00C04FA31A86}" : arSEA(205,1) = "dsfolder.dll"

arSEA(206,0) = "{450D8FBA-AD25-11D0-98A8-0800361B1103}" : arSEA(206,1) = "mydocs.dll"

'WXP SP2

arSEA(207,0) = "{2559a1f7-21d7-11d4-bdaf-00c04f60b9f0}" : arSEA(207,1) = "shdocvw.dll"

arSEA(208,0) = "{596AB062-B4D2-4215-9F74-E9109B0A8153}" : arSEA(208,1) = "twext.dll"

arSEA(209,0) = "{9DB7A13C-F208-4981-8353-73CC61AE2783}" : arSEA(209,1) = "twext.dll"

arSEA(210,0) = "{692F0339-CBAA-47e6-B5B5-3B84DB604E87}" : arSEA(210,1) = "extmgr.dll"

'NT4

arSEA(211,0) = "{764BF0E1-F219-11ce-972D-00AA00A14F56}" : arSEA(211,1) = "shcompui.dll"

arSEA(212,0) = "{8DE56A0D-E58B-41FE-9F80-3563CDCB2C22}" : arSEA(212,1) = "thumbvw.dll"

arSEA(213,0) = "{13709620-C279-11CE-A49E-444553540000}" : arSEA(213,1) = "SHDOC401.DLL"

arSEA(214,0) = "{62112AA1-EBE4-11cf-A5FB-0020AFE7292D}" : arSEA(214,1) = "SHDOC401.DLL"

arSEA(215,0) = "{7BA4C740-9E81-11CF-99D3-00AA004AE837}" : arSEA(215,1) = "SHDOC401.DLL"

arSEA(216,0) = "{D969A300-E7FF-11d0-A93B-00A0C90F2719}" : arSEA(216,1) = "SHDOC401.DLL"

arSEA(217,0) = "{4622AD11-FF23-11d0-8D34-00A0C90F2719}" : arSEA(217,1) = "SHDOC401.DLL"

arSEA(218,0) = "{3AD1E410-AAB9-11d0-89D7-00C04FC9E26E}" : arSEA(218,1) = "SHDOCVW.DLL"

arSEA(219,0) = "{57651662-CE3E-11D0-8D77-00C04FC99D61}" : arSEA(219,1) = "SHDOC401.DLL"

arSEA(220,0) = "{B091E540-83E3-11CF-A713-0020AFD79762}" : arSEA(220,1) = "SHDOC401.DLL"

arSEA(221,0) = "{3FC0B520-68A9-11D0-8D77-00C04FD70822}" : arSEA(221,1) = "SHDOC401.DLL"

arSEA(222,0) = "{7D688A77-C613-11D0-999B-00C04FD655E1}" : arSEA(222,1) = "SHELL32.dll"

arSEA(223,0) = "{BDEADF00-C265-11d0-BCED-00A0C90AB50F}" : arSEA(223,1) = "MSONSEXT.DLL"

arSEA(224,0) = "{C2FBB630-2971-11d1-A18C-00C04FD75D13}" : arSEA(224,1) = "SHDOC401.DLL"

arSEA(225,0) = "{C2FBB631-2971-11d1-A18C-00C04FD75D13}" : arSEA(225,1) = "SHDOC401.DLL"

arSEA(226,0) = "{75048700-EF1F-11D0-9888-006097DEACF9}" : arSEA(226,1) = "SHDOC401.DLL"

arSEA(227,0) = "{6D5313C0-8C62-11D1-B2CD-006097DF8C11}" : arSEA(227,1) = "SHDOC401.DLL"

arSEA(228,0) = "{FBF23B41-E3F0-101B-8488-00AA003E56F8}" : arSEA(228,1) = "SHDOC401.DLL"

arSEA(229,0) = "{5a61f7a0-cde1-11cf-9113-00aa00425c62}" : arSEA(229,1) = "w3ext.dll"

'WMe

arSEA(230,0) = "{3F30C968-480A-4C6C-862D-EFC0897BB84B}" : arSEA(230,1) = "THUMBVW.DLL" 'see (122)

arSEA(231,0) = "{53C74826-AB99-4d33-ACA4-3117F51D3788}" : arSEA(231,1) = "SHELL32.DLL"

arSEA(232,0) = "{992CFFA0-F557-101A-88EC-00DD010CCC48}" : arSEA(232,1) = "rnaui.dll" 'see (30)

arSEA(233,0) = "{FEF10FA2-355E-4e06-9381-9B24D7F7CC88}" : arSEA(233,1) = "SHELL32.DLL"

'MS PowerToys

arSEA(234,0) = "{AA7C7080-860A-11CE-8424-08002B2CFF76}" : arSEA(234,1) = "SENDTOX.DLL"

arSEA(235,0) = "{7BB70120-6C78-11CF-BFC7-444553540000}" : arSEA(235,1) = "SENDTOX.DLL"

arSEA(236,0) = "{7BB70122-6C78-11CF-BFC7-444553540000}" : arSEA(236,1) = "SENDTOX.DLL"

arSEA(237,0) = "{7BB70121-6C78-11CF-BFC7-444553540000}" : arSEA(237,1) = "SENDTOX.DLL"

arSEA(238,0) = "{7BB70123-6C78-11CF-BFC7-444553540000}" : arSEA(238,1) = "SENDTOX.DLL"

arSEA(239,0) = "{9E56BE62-C50F-11CF-9A2C-00A0C90A90CE}" : arSEA(239,1) = "SENDTOX.DLL"

arSEA(240,0) = "{90A756E0-AFCF-11CE-927B-0800095AE340}" : arSEA(240,1) = "target.dll"

arSEA(241,0) = "{afc638f0-e8a4-11ce-9ade-00aa00a42d2e}" : arSEA(241,1) = "TTFExtNT.dll"

'etc

arSEA(242,0) = "{1D2680C9-0E2A-469d-B787-065558BC7D43}" : arSEA(242,1) = "mscoree.dll"

arSEA(243,0) = "{5F327514-6C5E-4d60-8F16-D07FA08A78ED}" : arSEA(243,1) = "wuaueng.dll"

'WXP IE 7

arSEA(244,0) = "{07C45BB1-4A8C-4642-A1F5-237E7215FF66}" : arSEA(244,1) = "ieframe.dll"

arSEA(245,0) = "{1C1EDB47-CE22-4bbb-B608-77B48F83C823}" : arSEA(245,1) = "ieframe.dll"

arSEA(246,0) = "{205D7A97-F16D-4691-86EF-F3075DCCA57D}" : arSEA(246,1) = "ieframe.dll"

arSEA(247,0) = "{3028902F-6374-48b2-8DC6-9725E775B926}" : arSEA(247,1) = "ieframe.dll"

arSEA(248,0) = "{30D02401-6A81-11d0-8274-00C04FD5AE38}" : arSEA(248,1) = "ieframe.dll"

arSEA(249,0) = "{3C374A40-BAE4-11CF-BF7D-00AA006946EE}" : arSEA(249,1) = "ieframe.dll"

arSEA(250,0) = "{3DC7A020-0ACD-11CF-A9BB-00AA004AE837}" : arSEA(250,1) = "ieframe.dll"

arSEA(251,0) = "{43886CD5-6529-41c4-A707-7B3C92C05E68}" : arSEA(251,1) = "ieframe.dll"

arSEA(252,0) = "{44C76ECD-F7FA-411c-9929-1B77BA77F524}" : arSEA(252,1) = "ieframe.dll"

arSEA(253,0) = "{4B78D326-D922-44f9-AF2A-07805C2A3560}" : arSEA(253,1) = "ieframe.dll"

arSEA(254,0) = "{6038EF75-ABFC-4e59-AB6F-12D397F6568D}" : arSEA(254,1) = "ieframe.dll"

arSEA(255,0) = "{6B4ECC4F-16D1-4474-94AB-5A763F2A54AE}" : arSEA(255,1) = "ieframe.dll"

arSEA(256,0) = "{6CF48EF8-44CD-45d2-8832-A16EA016311B}" : arSEA(256,1) = "ieframe.dll"

arSEA(257,0) = "{73CFD649-CD48-4fd8-A272-2070EA56526B}" : arSEA(257,1) = "ieframe.dll"

arSEA(258,0) = "{7BD29E00-76C1-11CF-9DD0-00A0C9034933}" : arSEA(258,1) = "ieframe.dll"

arSEA(259,0) = "{7BD29E01-76C1-11CF-9DD0-00A0C9034933}" : arSEA(259,1) = "ieframe.dll"

arSEA(260,0) = "{871C5380-42A0-1069-A2EA-08002B30309D}" : arSEA(260,1) = "ieframe.dll"

arSEA(261,0) = "{98FF6D4B-6387-4b0a-8FBD-C5C4BB17B4F8}" : arSEA(261,1) = "ieframe.dll"

arSEA(262,0) = "{9a096bb5-9dc3-4d1c-8526-c3cbf991ea4e}" : arSEA(262,1) = "ieframe.dll"

arSEA(263,0) = "{9D958C62-3954-4b44-8FAB-C4670C1DB4C2}" : arSEA(263,1) = "ieframe.dll"

arSEA(264,0) = "{B31C5FAE-961F-415b-BAF0-E697A5178B94}" : arSEA(264,1) = "ieframe.dll"

arSEA(265,0) = "{BC476F4C-D9D7-4100-8D4E-E043F6DEC409}" : arSEA(265,1) = "ieframe.dll"

arSEA(266,0) = "{BFAD62EE-9D54-4b2a-BF3B-76F90697BD2A}" : arSEA(266,1) = "ieframe.dll"

arSEA(267,0) = "{CFBFAE00-17A6-11D0-99CB-00C04FD64497}" : arSEA(267,1) = "ieframe.dll"

arSEA(268,0) = "{E6EE9AAC-F76B-4947-8260-A9F136138E11}" : arSEA(268,1) = "ieframe.dll"

arSEA(269,0) = "{E7E4BC40-E76A-11CE-A9BB-00AA004AE837}" : arSEA(269,1) = "ieframe.dll"

arSEA(270,0) = "{F0353E1D-FEEC-474e-A984-1E5C6865E380}" : arSEA(270,1) = "ieframe.dll"

arSEA(271,0) = "{F2CF5485-4E02-4f68-819C-B92DE9277049}" : arSEA(271,1) = "ieframe.dll"

arSEA(272,0) = "{F83DAC1C-9BB9-4f2b-B619-09819DA81B0E}" : arSEA(272,1) = "ieframe.dll"

arSEA(273,0) = "{FAC3CBF6-8697-43d0-BAB9-DCD1FCE19D75}" : arSEA(273,1) = "ieframe.dll"

arSEA(274,0) = "{FBF23B40-E3F0-101B-8488-00AA003E56F8}" : arSEA(274,1) = "ieframe.dll"

arSEA(275,0) = "{FDE7673D-2E19-4145-8376-BBD58C4BC7BA}" : arSEA(275,1) = "ieframe.dll"

arSEA(276,0) = "{FF393560-C2A7-11CF-BFF4-444553540000}" : arSEA(276,1) = "ieframe.dll"

'WVa

arSEA(277,0) = "{00021401-0000-0000-C000-000000000046}" : arSEA(277,1) = "shell32.dll"

arSEA(278,0) = "{00f20eb5-8fd6-4d9d-b75e-36801766c8f1}" : arSEA(278,1) = "PhotoAcq.dll"

arSEA(279,0) = "{025A5937-A6BE-4686-A844-36FE4BEC8B6D}" : arSEA(279,1) = "shdocvw.dll"

arSEA(280,0) = "{056440FD-8568-48e7-A632-72157243B55B}" : arSEA(280,1) = "browseui.dll"

arSEA(281,0) = "{0a4286ea-e355-44fb-8086-af3df7645bd9}" : arSEA(281,1) = "wmpband.dll"

arSEA(282,0) = "{0AFCCBA6-BF90-4A4E-8482-0AC960981F5B}" : arSEA(282,1) = "shell32.dll"

arSEA(283,0) = "{0BFCF7B7-E7B6-433a-B205-2904FCF040DD}" : arSEA(283,1) = "appwiz.cpl"

arSEA(284,0) = "{11dbb47c-a525-400b-9e80-a54615a090c0}" : arSEA(284,1) = "ExplorerFrame.dll"

arSEA(285,0) = "{13D3C4B8-B179-4ebb-BF62-F704173E7448}" : arSEA(285,1) = "wab32.dll"

arSEA(286,0) = "{1531d583-8375-4d3f-b5fb-d23bbd169f22}" : arSEA(286,1) = "shell32.dll"

arSEA(287,0) = "{15D633E2-AD00-465b-9EC7-F56B7CDF8E27}" : arSEA(287,1) = "TipBand.dll"

arSEA(288,0) = "{15eae92e-f17a-4431-9f28-805e482dafd4}" : arSEA(288,1) = "appwiz.cpl"

arSEA(289,0) = "{16C2C29D-0E5F-45f3-A445-03E03F587B7D}" : arSEA(289,1) = "wab32.dll"

arSEA(290,0) = "{176d6597-26d3-11d1-b350-080036a75b03}" : arSEA(290,1) = "colorui.dll"

arSEA(291,0) = "{17cd9488-1228-4b2f-88ce-4298e93e0966}" : arSEA(291,1) = "shdocvw.dll"

arSEA(292,0) = "{1a184871-359e-4f67-aad9-5b9905d62232}" : arSEA(292,1) = "fontext.dll"

arSEA(293,0) = "{1FA9085F-25A2-489B-85D4-86326EEDCD87}" : arSEA(293,1) = "wlanpref.dll"

arSEA(294,0) = "{21569614-B795-46b1-85F4-E737A8DC09AD}" : arSEA(294,1) = "browseui.dll"

arSEA(295,0) = "{21ec2020-3aea-1069-a2dd-08002b30309d}" : arSEA(295,1) = "shell32.dll"

arSEA(296,0) = "{25336920-03f9-11cf-8fd0-00aa00686f13}" : arSEA(296,1) = "mshtml.dll"

arSEA(297,0) = "{25585dc7-4da0-438d-ad04-e42c8d2d64b9}" : arSEA(297,1) = "shell32.dll"

arSEA(298,0) = "{2559a1f6-21d7-11d4-bdaf-00c04f60b9f0}" : arSEA(298,1) = "shdocvw.dll"

arSEA(299,0) = "{2781761E-28E0-4109-99FE-B9D127C57AFE}" : arSEA(299,1) = "MpOav.dll"

arSEA(300,0) = "{289978AC-A101-4341-A817-21EBA7FD046D}" : arSEA(300,1) = "SyncCenter.dll"

arSEA(301,0) = "{2BC0DA0E-F1BC-43AB-B4B5-738EB6B51E7E}" : arSEA(301,1) = "fontext.dll"

arSEA(302,0) = "{2E9E59C0-B437-4981-A647-9C34B9B90891}" : arSEA(302,1) = "SyncCenter.dll"

arSEA(303,0) = "{3050f3d9-98b5-11cf-bb82-00aa00bdce0b}" : arSEA(303,1) = "mshtml.dll"

arSEA(304,0) = "{3080F90D-D7AD-11D9-BD98-0000947B0257}" : arSEA(304,1) = "shdocvw.dll"

arSEA(305,0) = "{3080F90E-D7AD-11D9-BD98-0000947B0257}" : arSEA(305,1) = "shdocvw.dll"

arSEA(306,0) = "{328B0346-7EAF-4BBE-A479-7CB88A095F5B}" : arSEA(306,1) = "shell32.dll"

arSEA(307,0) = "{335a31dd-f04b-4d76-a925-d6b47cf360df}" : arSEA(307,1) = "shdocvw.dll"

arSEA(308,0) = "{35786D3C-B075-49b9-88DD-029876E11C01}" : arSEA(308,1) = "wpdshext.dll"

arSEA(309,0) = "{36eef7db-88ad-4e81-ad49-0e313f0c35f8}" : arSEA(309,1) = "shdocvw.dll"

arSEA(310,0) = "{3c2654c6-7372-4f6b-b310-55d6128f49d2}" : arSEA(310,1) = "shell32.dll"

arSEA(311,0) = "{3F30C968-480A-4C6C-862D-EFC0897BB84B}" : arSEA(311,1) = "PhotoMetadataHandler.dll"

arSEA(312,0) = "{40C3D757-D6E4-4b49-BB41-0E5BBEA28817}" : arSEA(312,1) = "mediametadatahandler.dll"

arSEA(313,0) = "{4336a54d-038b-4685-ab02-99bb52d3fb8b}" : arSEA(313,1) = "shdocvw.dll"

arSEA(314,0) = "{437ff9c0-a07f-4fa0-af80-84b6c6440a16}" : arSEA(314,1) = "shell32.dll"

arSEA(315,0) = "{44121072-A222-48f2-A58A-6D9AD51EBBE9}" : arSEA(315,1) = "XPSSHHDR.DLL"

arSEA(316,0) = "{44f3dab6-4392-4186-bb7b-6282ccb7a9f6}" : arSEA(316,1) = "mydocs.dll"

arSEA(317,0) = "{45670FA8-ED97-4F44-BC93-305082590BFB}" : arSEA(317,1) = "XPSSHHDR.DLL"

arSEA(318,0) = "{474C98EE-CF3D-41f5-80E3-4AAB0AB04301}" : arSEA(318,1) = "cscui.dll"

arSEA(319,0) = "{4A1E5ACD-A108-4100-9E26-D2FAFA1BA486}" : arSEA(319,1) = "icsigd.dll"

arSEA(320,0) = "{4B534112-3AF6-4697-A77C-D62CE9B9E7CF}" : arSEA(320,1) = "SyncCenter.dll"

arSEA(321,0) = "{4D1209BD-36E2-4e2f-840D-6C7FB879DD9E}" : arSEA(321,1) = "shdocvw.dll"

arSEA(322,0) = "{4d5c8c2a-d075-11d0-b416-00c04fb90376}" : arSEA(322,1) = "browseui.dll"

arSEA(323,0) = "{4E5BFBF8-F59A-4e87-9805-1F9B42CC254A}" : arSEA(323,1) = "gameux.dll"

arSEA(324,0) = "{4E77131D-3629-431c-9818-C5679DC83E81}" : arSEA(324,1) = "cscui.dll"

arSEA(325,0) = "{4F58F63F-244B-4c07-B29F-210BE59BE9B4}" : arSEA(325,1) = "wab32.dll"

arSEA(326,0) = "{513D916F-2A8E-4F51-AEAB-0CBC76FB1AF8}" : arSEA(326,1) = "acppage.dll"

arSEA(327,0) = "{53BEDF0B-4E5B-4183-8DC9-B844344FA104}" : arSEA(327,1) = "mssvp.dll"

arSEA(328,0) = "{576C9E85-1300-4EF5-BF6B-D00509F4EDCD}" : arSEA(328,1) = "SyncCenter.dll"

arSEA(329,0) = "{58E3C745-D971-4081-9034-86E34B30836A}" : arSEA(329,1) = "shdocvw.dll"

arSEA(330,0) = "{596742A5-1393-4e13-8765-AE1DF71ACAFB}" : arSEA(330,1) = "browseui.dll"

arSEA(331,0) = "{5DB2625A-54DF-11D0-B6C4-0800091AA605}" : arSEA(331,1) = "colorui.dll"

arSEA(332,0) = "{5FA29220-36A1-40f9-89C6-F4B384B7642E}" : arSEA(332,1) = "inetcomm.dll"

arSEA(333,0) = "{60632754-c523-4b62-b45c-4172da012619}" : arSEA(333,1) = "shdocvw.dll"

arSEA(334,0) = "{640167b4-59b0-47a6-b335-a6b3c0695aea}" : arSEA(334,1) = "audiodev.dll"

arSEA(335,0) = "{66742402-F9B9-11D1-A202-0000F81FEDEE}" : arSEA(335,1) = "shell32.dll"

arSEA(336,0) = "{675F097E-4C4D-11D0-B6C1-0800091AA605}" : arSEA(336,1) = "colorui.dll"

arSEA(337,0) = "{6b33163c-76a5-4b6c-bf21-45de9cd503a1}" : arSEA(337,1) = "shwebsvc.dll"

arSEA(338,0) = "{6b9228da-9c15-419e-856c-19e768a13bdc}" : arSEA(338,1) = "sbdrop.dll"

arSEA(339,0) = "{6D8BB3D3-9D87-4a91-AB56-4F30CFFEFE9F}" : arSEA(339,1) = "browseui.dll"

arSEA(340,0) = "{708e1662-b832-42a8-bbe1-0a77121e3908}" : arSEA(340,1) = "shell32.dll"

arSEA(341,0) = "{71D99464-3B6B-475C-B241-E15883207529}" : arSEA(341,1) = "SyncCenter.dll"

arSEA(342,0) = "{71f96385-ddd6-48d3-a0c1-ae06e8b055fb}" : arSEA(342,1) = "shell32.dll"

arSEA(343,0) = "{74246bfc-4c96-11d0-abef-0020af6b0b7a}" : arSEA(343,1) = "devmgr.dll"

arSEA(344,0) = "{78F3955E-3B90-4184-BD14-5397C15F1EFC}" : arSEA(344,1) = "shdocvw.dll"

arSEA(345,0) = "{7A0F6AB7-ED84-46B6-B47E-02AA159A152B}" : arSEA(345,1) = "SyncCenter.dll"

arSEA(346,0) = "{7b81be6a-ce2b-4676-a29e-eb907a5126c5}" : arSEA(346,1) = "appwiz.cpl"

arSEA(347,0) = "{7D4734E6-047E-41e2-AEAA-E763B4739DC4}" : arSEA(347,1) = "wmpshell.dll"

arSEA(348,0) = "{7EFA68C6-086B-43e1-A2D2-55A113531240}" : arSEA(348,1) = "cscui.dll"

arSEA(349,0) = "{8082C5E6-4C27-48ec-A809-B8E1122E8F97}" : arSEA(349,1) = "wab32.dll"

arSEA(350,0) = "{865e5e76-ad83-4dca-a109-50dc2113ce9a}" : arSEA(350,1) = "shell32.dll"

arSEA(351,0) = "{875CB1A1-0F29-45de-A1AE-CFB4950D0B78}" : arSEA(351,1) = "mediametadatahandler.dll"

arSEA(352,0) = "{877ca5ac-cb41-4842-9c69-9136e42d47e2}" : arSEA(352,1) = "sdshext.dll"

arSEA(353,0) = "{8856f961-340a-11d0-a96b-00c04fd705a2}" : arSEA(353,1) = "ieframe.dll"

arSEA(354,0) = "{89D83576-6BD1-4c86-9454-BEB04E94C819}" : arSEA(354,1) = "mssvp.dll"

arSEA(355,0) = "{8A734961-C4AA-4741-AC1E-791ACEBF5B39}" : arSEA(355,1) = "wmpshell.dll"

arSEA(356,0) = "{8a7cae0e-5951-49cb-bf20-ab3fa1e44b01}" : arSEA(356,1) = "fontext.dll"

arSEA(357,0) = "{8E25992B-373E-486E-80E5-BD23AE417E66}" : arSEA(357,1) = "SyncCenter.dll"

arSEA(358,0) = "{8E908FC9-BECC-40f6-915B-F4CA0E70D03D}" : arSEA(358,1) = "shdocvw.dll"

arSEA(359,0) = "{90b9bce2-b6db-4fd3-8451-35917ea1081b}" : arSEA(359,1) = "ExplorerFrame.dll"

arSEA(360,0) = "{90f8c90b-04e0-4e92-a186-e6e9c125d664}" : arSEA(360,1) = "shdocvw.dll"

arSEA(361,0) = "{91ADC906-6722-4B05-A12B-471ADDCCE132}" : arSEA(361,1) = "TouchX.dll"

arSEA(362,0) = "{92337A8C-E11D-11D0-BE48-00C04FC30DF6}" : arSEA(362,1) = "oleprn.dll"

arSEA(363,0) = "{92dbad9f-5025-49b0-9078-2d78f935e341}" : arSEA(363,1) = "inetcomm.dll"

arSEA(364,0) = "{96AE8D84-A250-4520-95A5-A47A7E3C548B}" : arSEA(364,1) = "shdocvw.dll"

arSEA(365,0) = "{97e467b4-98c6-4f19-9588-161b7773d6f6}" : arSEA(365,1) = "propsys.dll"

arSEA(366,0) = "{9C60DE1E-E5FC-40f4-A487-460851A8D915}" : arSEA(366,1) = "shdocvw.dll"

arSEA(367,0) = "{9C73F5E5-7AE7-4E32-A8E8-8D23B85255BF}" : arSEA(367,1) = "SyncCenter.dll"

arSEA(368,0) = "{9DBD2C50-62AD-11d0-B806-00C04FD706EC}" : arSEA(368,1) = "shell32.dll"

arSEA(369,0) = "{a38b883c-1682-497e-97b0-0a3a9e801682}" : arSEA(369,1) = "PhotoMetadataHandler.dll"

arSEA(370,0) = "{a42c2ccb-67d3-46fa-abe6-7d2f3488c7a3}" : arSEA(370,1) = "shell32.dll"

arSEA(371,0) = "{a542e116-8088-4146-a352-b0d06e7f6af6}" : arSEA(371,1) = "browseui.dll"

arSEA(372,0) = "{add36aa8-751a-4579-a266-d66f5202ccbb}" : arSEA(372,1) = "shwebsvc.dll"

arSEA(373,0) = "{b155bdf8-02f0-451e-9a26-ae317cfd7779}" : arSEA(373,1) = "shdocvw.dll"

arSEA(374,0) = "{b2952b16-0e07-4e5a-b993-58c52cb94cae}" : arSEA(374,1) = "shell32.dll"

arSEA(375,0) = "{B32D3949-ED98-4DBB-B347-17A144969BBA}" : arSEA(375,1) = "SyncCenter.dll"

arSEA(376,0) = "{b8cdcb65-b1bf-4b42-9428-1dfdb7ee92af}" : arSEA(376,1) = "zipfldr.dll"

arSEA(377,0) = "{b9815375-5d7f-4ce2-9245-c9d4da436930}" : arSEA(377,1) = "inetcomm.dll"

arSEA(378,0) = "{BB06C0E4-D293-4f75-8A90-CB05B6477EEE}" : arSEA(378,1) = "shdocvw.dll"

arSEA(379,0) = "{BB6B2374-3D79-41DB-87F4-896C91846510}" : arSEA(379,1) = "emdmgmt.dll"

arSEA(380,0) = "{BC48B32F-5910-47F5-8570-5074A8A5636A}" : arSEA(380,1) = "SyncCenter.dll"

arSEA(381,0) = "{BC65FB43-1958-4349-971A-210290480130}" : arSEA(381,1) = "NcdProp.dll"

arSEA(382,0) = "{BD7A2E7B-21CB-41b2-A086-B309680C6B7E}" : arSEA(382,1) = "mssvp.dll"

arSEA(383,0) = "{BE122A0E-4503-11DA-8BDE-F66BAD1E3F3A}" : arSEA(383,1) = "shdocvw.dll"

arSEA(384,0) = "{C0B4E2F3-BA21-4773-8DBA-335EC946EB8B}" : arSEA(384,1) = "comdlg32.dll"

arSEA(385,0) = "{C4EC38BD-4E9E-4b5e-935A-D1BFF237D980}" : arSEA(385,1) = "browseui.dll"

arSEA(386,0) = "{c5a40261-cd64-4ccf-84cb-c394da41d590}" : arSEA(386,1) = "mediametadatahandler.dll"

arSEA(387,0) = "{C73F6F30-97A0-4AD1-A08F-540D4E9BC7B9}" : arSEA(387,1) = "shdocvw.dll"

arSEA(388,0) = "{C7657C4A-9F68-40fa-A4DF-96BC08EB3551}" : arSEA(388,1) = "PhotoMetadataHandler.dll"

arSEA(389,0) = "{CB1B7F8C-C50A-4176-B604-9E24DEE8D4D1}" : arSEA(389,1) = "oobefldr.dll"

arSEA(390,0) = "{CC6EEFFB-43F6-46c5-9619-51D571967F7D}" : arSEA(390,1) = "shwebsvc.dll"

arSEA(391,0) = "{ceefea1b-3e29-4ef1-b34c-fec79c4f70af}" : arSEA(391,1) = "appwiz.cpl"

arSEA(392,0) = "{CF67796C-F57F-45F8-92FB-AD698826C602}" : arSEA(392,1) = "wab32.dll"

arSEA(393,0) = "{D34A6CA6-62C2-4C34-8A7C-14709C1AD938}" : arSEA(393,1) = "shdocvw.dll"

arSEA(394,0) = "{d450a8a1-9568-45c7-9c0e-b4f9fb4537bd}" : arSEA(394,1) = "appwiz.cpl"

arSEA(395,0) = "{D555645E-D4F8-4c29-A827-D93C859C4F2A}" : arSEA(395,1) = "shdocvw.dll"

arSEA(396,0) = "{D6791A63-E7E2-4fee-BF52-5DED8E86E9B8}" : arSEA(396,1) = "wpdshext.dll"

arSEA(397,0) = "{D9EF8727-CAC2-4e60-809E-86F80A666C91}" : arSEA(397,1) = "shdocvw.dll"

arSEA(398,0) = "{DBCE2480-C732-101B-BE72-BA78E9AD5B27}" : arSEA(398,1) = "colorui.dll"

arSEA(399,0) = "{DC1C5A9C-E88A-4dde-A5A1-60F82A20AEF7}" : arSEA(399,1) = "comdlg32.dll"

arSEA(400,0) = "{DFFACDC5-679F-4156-8947-C5C76BC0B67F}" : arSEA(400,1) = "shdocvw.dll"

arSEA(401,0) = "{E37E2028-CE1A-4f42-AF05-6CEABC4E5D75}" : arSEA(401,1) = "dfshim.dll"

arSEA(402,0) = "{E413D040-6788-4C22-957E-175D1C513A34}" : arSEA(402,1) = "SyncCenter.dll"

arSEA(403,0) = "{E598560B-28D5-46aa-A14A-8A3BEA34B576}" : arSEA(403,1) = "PhotoViewer.dll"

arSEA(404,0) = "{E7DE9B1A-7533-4556-9484-B26FB486475E}" : arSEA(404,1) = "shdocvw.dll"

arSEA(405,0) = "{e82a2d71-5b2f-43a0-97b8-81be15854de8}" : arSEA(405,1) = "dfshim.dll"

arSEA(406,0) = "{E95A4861-D57A-4be1-AD0F-35267E261739}" : arSEA(406,1) = "shdocvw.dll"

arSEA(407,0) = "{eb124705-128b-40d4-8dd8-d93ed12589a4}" : arSEA(407,1) = "shdocvw.dll"

arSEA(408,0) = "{ECDD6472-2B9B-4b4b-AE36-F316DF3C8D60}" : arSEA(408,1) = "gameux.dll"

arSEA(409,0) = "{ED228FDF-9EA8-4870-83B1-96B02CFE0D52}" : arSEA(409,1) = "gameux.dll"

arSEA(410,0) = "{ed50fc29-b964-48a9-afb3-15ebb9b97f36}" : arSEA(410,1) = "shdocvw.dll"

arSEA(411,0) = "{ED834ED6-4B5A-4bfe-8F11-A626DCB6A921}" : arSEA(411,1) = "shdocvw.dll"

arSEA(412,0) = "{ed9d80b9-d157-457b-9192-0e7280313bf0}" : arSEA(412,1) = "zipfldr.dll"

arSEA(413,0) = "{F02C1A0D-BE21-4350-88B0-7367FC96EF3C}" : arSEA(413,1) = "NetworkExplorer.dll"

arSEA(414,0) = "{F04CC277-03A2-4277-96A9-77967471BDFF}" : arSEA(414,1) = "SyncCenter.dll"

arSEA(415,0) = "{f8b8412b-dea3-4130-b36c-5e8be73106ac}" : arSEA(415,1) = "inetcomm.dll"

arSEA(416,0) = "{F1390A9A-A3F4-4E5D-9C5F-98F3BD8D935C}" : arSEA(416,1) = "SyncCenter.dll"

arSEA(417,0) = "{fccf70c8-f4d7-4d8b-8c17-cd6715e37fff}" : arSEA(417,1) = "browseui.dll"

arSEA(418,0) = "{FFE2A43C-56B9-4bf5-9A79-CC6D4285608A}" : arSEA(418,1) = "PhotoViewer.dll"

[MAcgYvER everyONE 0]

'set up key name to query

strKey = "Software\Microsoft\Windows\CurrentVersion\Shell Extensions\Approved"

strSubTitle = SOCA("HKLM" & "\" & strKey & "\")

 

'find all the names in the key

intErrNum1 = oReg.EnumValues (HKLM, strKey, arNames, arType)

 

'enumerate data if present

If intErrNum1 = 0 And IsArray(arNames) Then

 

'for each CLSID

For Each strCLSID in arNames

 

flagTitle = False

 

'find CLSID title

CLSIDLocTitle HKLM, strKey, strCLSID, strLocTitle

 

For ctrCH = intCLL To 1

 

'assume CLSID unapproved

flagMatch = False

 

ResolveCLSID strCLSID, arHives(ctrCH,1), strCLSIDTitle, strIPSDLL

 

If strIPSDLL <> "" Then

 

strCN = CoName(IDExe(strIPSDLL))

 

'for every member of approved shellex array in HKLM hive

For i = 0 To UBound(arSEA,1)

 

'if not ShowAll And CLSID's & DLL's identical And CoName = MS, shellex is known

If Not flagShowAll And (LCase(strCLSID) = LCase(arSEA(i,0))) And _

(Fso.GetFileName(LCase(strIPSDLL)) = LCase(arSEA(i,1))) And _

(strCN = MS) And ctrCH = 1 Then

 

'toggle flag & exit for

flagMatch = True : Exit For

 

End If

 

Next 'arSEA member

 

'for ShowAll Or unknown shellex

If flagShowAll Or Not flagMatch Then

 

TitleLineWrite

 

If Not flagTitle Then

 

On Error Resume Next

'output CLSID & title

oFN.WriteLine DQ & strCLSID & DQ & " = " & strLocTitle

intErrNum = Err.Number : Err.Clear

'error check for W2K if title (Approved CLSID) value not set

If intErrNum <> 0 Then _

oFN.WriteLine DQ & strCLSID & DQ & " = (no title provided)"

flagTitle = True

On Error GoTo 0

 

End If

 

'output CLSID title, InProcServer32 DLL & CoName

oFN.WriteLine " -> {" & arHives(ctrCH,0) & "...CLSID} = " &_

strCLSIDTitle & vbCRLF & Space(19) & "\InProcServer32\(Default) = " &_

StringFilter(strIPSDLL,True) & CoName(IDExe(strIPSDLL))

 

End If 'flagMatch Or flagShowAll?

 

End If 'strIPSDLL <> ""?

 

Next 'CLSID Hive

 

Next 'strCLSID

 

Else 'arNames array not returned

 

'if ShowAll, output key name

If flagShowAll Then TitleLineWrite

 

End If 'intErrNum1 = 0 & arNames array exists?

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

'recover array memory

ReDim arSEA(0,0)

 

End If 'SecTest?

 

 

 

 

'#5. HKLM... Explorer\DeviceNotificationCallbacks/SharedTaskScheduler/ShellExecuteHooks

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

Dim arAllowedCLSID(), ctrLow

 

ReDim arKeys(2)

arKeys(0) = "Software\Microsoft\Windows\CurrentVersion\Explorer\DeviceNotificationCallbacks"

arKeys(1) = "Software\Microsoft\Windows\CurrentVersion\Explorer\SharedTaskScheduler"

arKeys(2) = "Software\Microsoft\Windows\CurrentVersion\Explorer\ShellExecuteHooks"

 

ctrLow = 1

If strOS = "WVA" Then ctrLow = 0

 

'for each Explorer sub-key

For i = ctrLow To UBound(arKeys)

 

strSubTitle = SOCA("HKLM" & "\" & arKeys(i) & "\")

 

'set up allowed CLSID's & IPS names for each sub-key

If i = 0 Then 'DeviceNotificationCallbacks

 

ReDim arAllowedCLSID(0,1)

arAllowedCLSID(0,0) = "{8E25992B-373E-486E-80E5-BD23AE417E66}"

arAllowedCLSID(0,1) = "SyncCenter.dll"

 

ElseIf i = 1 Then 'SharedTaskScheduler

 

ReDim arAllowedCLSID(2,1)

arAllowedCLSID(0,0) = "{438755C2-A8BA-11D1-B96B-00A0C90312E1}"

arAllowedCLSID(0,1) = "browseui.dll"

arAllowedCLSID(1,0) = "{8C7461EF-2B13-11d2-BE35-3078302C2030}"

arAllowedCLSID(1,1) = "browseui.dll"

arAllowedCLSID(2,0) = "{553858A7-4922-4e7e-B1C1-97140C1C16EF}" 'IE 7

arAllowedCLSID(2,1) = "ieframe.dll"

 

ElseIf i = 2 Then 'ShellExecuteHooks

 

ReDim arAllowedCLSID(0,1)

arAllowedCLSID(0,0) = "{AEB6717E-7E19-11d0-97EE-00C04FD91972}"

arAllowedCLSID(0,1) = "shell32.dll"

 

End If 'which Explorer sub-key?

 

'find all the names in the Explorer key

oReg.EnumValues HKLM, arKeys(i), arNames, arType

 

'enumerate data if present

If IsArray(arNames) Then

 

'for each name

For Each strName In arNames

 

flagTitle = False

 

CLSIDLocTitle HKLM, arKeys(i), strName, strLocTitle

 

For ctrCH = intCLL To 1

 

ResolveCLSID strName, arHives(ctrCH,1), strCLSIDTitle, strIPSDLL

 

If strIPSDLL <> "" Then

 

flagFound = False

strCN = CoName(IDExe(strIPSDLL))

 

'for every CLSID

'see if CLSID, IPS filename are allowed & IPS CoName = "MS" & hive = HKLM

For j = 0 To UBound(arAllowedCLSID,1)

 

If LCase(strName) = LCase(arAllowedCLSID(j,0)) And _

LCase(Fso.GetFileName(strIPSDLL)) = LCase(arAllowedCLSID(j,1)) And _

strCN = MS And ctrCH = 1 Then

flagFound = True : strWarn = "" : Exit For

End If

 

Next 'allowed CLSID & IPS file name

 

If Not flagFound Then

strWarn = IWarn : flagIWarn = True

End If

 

'if IPS not allowed or ShowAll, output name & value

If Not flagFound Or flagShowAll Then

 

'output the title line if not already done

TitleLineWrite

 

If Not flagTitle Then

 

On Error Resume Next

oFN.WriteLine strWarn & DQ & strName & DQ &_

" = " & strLocTitle

'error check for W2K if SharedTaskScheduler value not set

intErrNum = Err.Number : Err.Clear

If intErrNum <> 0 Then oFN.WriteLine DQ & strName & DQ &_

" = (no title provided)"

flagTitle = True

On Error GoTo 0

 

End If

 

'output CLSID title, InProcServer32 DLL & CoName

oFN.WriteLine " -> {" & arHives(ctrCH,0) & "...CLSID} = " &_

strCLSIDTitle & vbCRLF & Space(19) & "\InProcServer32\(Default) = " &_

StringFilter(strIPSDLL,True) & strCN

 

End If 'unexpected data or ShowAll?

 

End If 'IPS exists?

 

Next 'CLSID Hive

 

Next 'arNames array member

 

Else 'arNames array not returned

 

'if ShowAll, output key name

If flagShowAll Then TitleLineWrite

 

End If 'arNames array exists

 

Next 'Explorer sub-key

 

'reset flags

flagFound = False

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

'recover array memory

ReDim arAllowedCLSID(0)

ReDim arKeys(0)

ReDim arNames(0)

 

End If 'SecTest?

 

 

 

 

'#6. HKCU/HKLM... ShellServiceObjectDelayLoad\

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

strKey = "Software\Microsoft\Windows\CurrentVersion\ShellServiceObjectDelayLoad"

 

Dim arSSODL() 'array of allowable SSODL values

'flagMatch = TRUE if SSODL value is allowable

 

'form array of allowable SSODL values

ReDim arSSODL(6,1)

arSSODL(0,0) = "{35cec8a3-2be6-11d2-8773-92e220524153}" : arSSODL(0,1) = "stobject.dll"

arSSODL(1,0) = "{7007accf-3202-11d1-aad2-00805fc1270e}" : arSSODL(1,1) = "netshell.dll"

arSSODL(2,0) = "{7849596a-48ea-486e-8937-a2a3009f31a9}" : arSSODL(2,1) = "shell32.dll"

arSSODL(3,0) = "{e57ce738-33e8-4c51-8354-bb4de9d215d1}" : arSSODL(3,1) = "upnpui.dll"

arSSODL(4,0) = "{e6fb5e20-de35-11cf-9c87-00aa005127ed}" : arSSODL(4,1) = "webcheck.dll"

arSSODL(5,0) = "{fbeb8a05-beee-4442-804e-409d6c4515e9}" : arSSODL(5,1) = "shell32.dll"

arSSODL(6,0) = "{bcbcd383-3e06-11d3-91a9-00c04f68105c}" : arSSODL(6,1) = "auhook.dll"

 

For i = 0 To 1 'for each hive

 

strSubTitle = SOCA(arHives(i,0) & "\" & strKey & "\")

 

'find all the names in the key

oReg.EnumValues arHives(i,1), strKey, arNames, arType

 

'enumerate data if present

If IsArray(arNames) Then

 

'for each text name

For Each strName In arNames

 

flagMatch = False 'SSODL entry is not allowable

 

'get the SSODL value = {CLSID}

oReg.GetStringValue arHives(i,1),strKey,strName,strCLSID

 

flagTitle = False

 

For ctrCH = intCLL To 1

 

ResolveCLSID strCLSID, arHives(ctrCH,1), strCLSIDTitle, strIPSDLL

 

'if IPS value exists And is not empty

If strIPSDLL <> "" Then

 

strCN = CoName(IDExe(strIPSDLL))

strDLL = Fso.GetFileName(strIPSDLL)

 

'only look for allowable values if output not ShowAll

If Not flagShowAll Then

 

'for every arSSODL member for this O/S

For j = 0 To UBound(arSSODL,1)

 

'check the CLSID, DLL filename, CoName, CLSID hive

If LCase(arSSODL(j,0)) = LCase(strCLSID) And _

LCase(arSSODL(j,1)) = LCase(strDLL) And _

LCase(strCN) = " [ms]" And _

ctrCH = 1 Then

flagMatch = True 'toggle flag if all four criteria satisfied

Exit For

End If

 

Next 'arSSODL member

 

End If 'flagShowAll?

 

'write the quote-delimited name and value to the file if unallowable

If Not flagMatch Then

 

'output title line if not already done

TitleLineWrite

 

If Not flagTitle Then

'output SSODL value

oFN.WriteLine DQ & strName & DQ & " = " &_

DQ & strCLSID & DQ

flagTitle = True

End If

 

oFN.WriteLine " -> {" & arHives(ctrCH,0) & "...CLSID} = " &_

strCLSIDTitle & vbCRLF & Space(19) & "\InProcServer32\(Default) = " &_

StringFilter(strIPSDLL,True) & strCN

 

End If 'flagMatch?

 

End If 'IPS exists?

 

Next 'CLSID hive

 

Next 'SSODL value (strName) in array

 

End If 'arNames array exists

 

'if ShowAll, output key name

If flagShowAll Then TitleLineWrite

 

Next 'hive

 

'reset flags

flagMatch = False

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

strLine = ""

 

'recover array memory

ReDim arType(0)

ReDim arNames(0)

ReDim arSSOLD(0,0)

 

End If 'SecTest?

 

 

 

 

'#7. HKCU/HKLM... Command Processor\AutoRun

' HKCU... Policies\System\Shell (W2K/WXP/WVa only)

' HKCU... Windows\load & run

' HKLM... Windows\AppInit_DLLs

' HKLM... Windows NT... Aedebug\

' HKCU/HKLM... Windows NT... Winlogon\Shell

' HKLM... Windows NT... Winlogon\Userinit, System, Ginadll, Taskman, VmApplet

' HKLM... Control\BootVerificationProgram\ImagePath

' HKLM... Control\Lsa\Authentication Packages

' HKLM... Control\SafeBoot\Option\UseAlternateShell

' HKLM... Control\SecurityProviders\SecurityProviders

' HKLM... Control\Session Manager\BootExecute

' HKLM... Control\Session Manager\Execute

' HKLM... Control\Session Manager\SetupExecute

' HKLM... Control\Session Manager\WOW\cmdline, wowcmdline

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

Dim strSP 'member of SecurityProviders array

 

If strOS <> "W98" And strOS <> "WME" Then

 

'HKCU\Software\Microsoft\Command Processor\AutoRun

strKey = "Software\Microsoft\Command Processor"

strSubTitle = "HKCU\Software\Microsoft\Command Processor\"

RegDataChk_v2 HKCU, strKey, "AutoRun", "", "", True

 

 

If strOS = "W2K" Or strOS = "WXP" Or strOS = "WVA" Then

'HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\System, Shell=""

strKey = "Software\Microsoft\Windows\CurrentVersion\Policies\System"

strSubTitle = "HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\System\"

RegDataChk_v2 HKCU, strKey, "Shell", "", "", True

End If 'W2K/WXP/WVa?

 

 

'HKCU\Software\Microsoft\Windows NT\CurrentVersion\Windows\load & run

strSubTitle = "HKCU\Software\Microsoft\Windows NT\CurrentVersion\Windows\"

strKey = "Software\Microsoft\Windows NT\CurrentVersion\Windows"

RegDataChk_v2 HKCU, strKey, "load", "", "lrp", True

RegDataChk_v2 HKCU, strKey, "run", "", "lrp", True

 

 

'HKCU\Software\Microsoft\Windows NT\CurrentVersion\Winlogon\Shell

strSubTitle = "HKCU\Software\Microsoft\Windows NT\CurrentVersion\Winlogon\"

strKey = "Software\Microsoft\Windows NT\CurrentVersion\Winlogon"

RegDataChk_v2 HKCU, strKey, "Shell", "explorer.exe", "", True

 

 

'HKLM\Software\Microsoft\Command Processor\AutoRun

strSubTitle = SOCA ("HKLM\Software\Microsoft\Command Processor\")

strKey = "Software\Microsoft\Command Processor"

RegDataChk_v2 HKLM, strKey, "AutoRun", "", "", True

 

 

If strOS = "NT4" Or strOS = "W2K" Or strOS = "WXP" Then

 

'HKLM\Software\Microsoft\Windows NT\CurrentVersion\Aedebug\

strSubTitle = SOCA ("HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Aedebug\")

strKey = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Aedebug"

RegDataChk_v2 HKLM, strKey, "Debugger", "drwtsn32 -p %ld -e %ld -g", "", True

 

If strSubTitle = "" Then RegDataChk_v2 HKLM, strKey, "Auto", "all", "", False

 

End If 'NT4/W2K/WXP?

 

 

'HKLM\Software\Microsoft\Windows NT\CurrentVersion\Windows\AppInit_DLLs

strSubTitle = SOCA ("HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Windows\")

strKey = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Windows"

RegDataChk_v2 HKLM, strKey, "AppInit_DLLs", "", "lrp", True

 

 

'Winlogon key name/value pairs

 

'GinaDLL=MSGina.dll

strKey = "Software\Microsoft\Windows NT\CurrentVersion\Winlogon"

strSubTitle = SOCA("HKLM\SOFTWA RE\Microsoft\Windows NT\CurrentVersion\Winlogon\")

RegDataChk_v2 HKLM, strKey, "GinaDLL", "msgina.dll", "", True

 

'Shell=Explorer.exe

RegDataChk_v2 HKLM, strKey, "Shell", "explorer.exe", "", True

 

'System=""

If strOS = "NT4" Then 'if NT4, check for expected value

RegDataChk_v2 HKLM, strKey, "System", "lsass.exe", "", True

Else 'if W2K/WXP/WVA, check for empty string

RegDataChk_v2 HKLM, strKey, "System", "", "", True

End If

 

'Taskman=""

RegDataChk_v2 HKLM, strKey, "Taskman", "", "", True

 

 

'Userinit=userinit,nddeagnt.exe/%SystemRoot%\system32\userinit.exe,

If strOS = "NT4" Then 'Userinit=userinit,nddeagnt.exe

RegDataChk_v2 HKLM, strKey, "Userinit", "userinit,nddeagnt.exe", "userinit", False

Else 'W2K/WXP/WVA Userinit=%SystemRoot%\system32\userinit.exe,

RegDataChk_v2 HKLM, strKey, "Userinit", LCase(strFPSF) & "\userinit.exe", "ui", True

End If

 

'VmApplet=rundll32 shell32,Control_RunDLL "sysdm.cpl"

RegDataChk_v2 HKLM, strKey, "VmApplet", "rundll32 shell32,Control_RunDLL ""sysdm.cpl""", "", False

 

 

'HKLM\System\CurrentControlSet\Control\BootVerificationProgram\ImagePath

strKey = "SYSTEM\CurrentControlSet\Control\BootVerificationProgram"

strSubTitle = SYCA("HKLM" & "\" & strKey & "\")

RegDataChk_v2 HKLM, strKey, "ImagePath", "", "", True

 

 

'HKLM\SYSTEM\CurrentControlSet\Control\Lsa\Authentication Packages = "msv1_0"

strKey = "SYSTEM\CurrentControlSet\Control\Lsa"

strSubTitle = SYCA("HKLM" & "\" & strKey & "\")

RegDataChk_v2 HKLM, strKey, "Authentication Packages", """msv1_0""", "", False

 

'HKLM\System\CurrentControlSet\Control\SafeBoot\Option\UseAlternateShell

If strOS = "W2K" Or strOS = "WXP" Or strOS = "WVA" Then

strKey = "SYSTEM\CurrentControlSet\Control\SafeBoot\Option"

strSubTitle = SYCA("HKLM" & "\" & strKey & "\")

RegDataChk_v2 HKLM, strKey, "UseAlternateShell", "", "", False

 

strKey = "SYSTEM\CurrentControlSet\Control\SafeBoot"

strSubTitle = SYCA("HKLM" & "\" & strKey & "\")

RegDataChk_v2 HKLM, strKey, "AlternateShell", "cmd.exe", "", True

End If 'W2K/WXP/WVa?

 

 

'HKLM\SYSTEM\CurrentControlSet\Control\SecurityProviders\SecurityProviders

strKey = "System\CurrentControlSet\Control\SecurityProviders"

strSubTitle = SYCA("HKLM" & "\" & strKey & "\")

strWarn = ""

 

'set the SecurityProviders array per the OS version

If strOS = "W2K" Or strOS = "WXP" Or strOS = "NT4" Then

arSP = Array ("msapsspc.dll","schannel.dll","digest.dll","msnsspc.dll")

ElseIf strOS = "WVA" Then

arSP = Array ("credssp.dll")

Else

arSP = Array ("msapsspc.dll","digest.dll","msnsspc.dll")

End IF

 

'read the value, split into array

intErrNum = oReg.GetStringValue (HKLM,strKey,"SecurityProviders",strValue)

 

'if value exists (except for W2K!)

If intErrNum = 0 And strValue <> "" Then

 

'split the value into an array using comma delimiters

arValues = Split(strValue, ",", -1, vbTextCompare) 'vbTextCompare = 1

 

flagInfect = False 'assume all DLL's allowed

 

'for every member of the value array

For Each strVal In arValues

 

flagFound = False 'assume DLL is not allowed

 

'for every member of the allowed SP array

For Each strSP In arSP

 

'if names match And CoName is MS

If LCase(Trim(strSP)) = LCase(Trim(strVal)) And _

CoName(IDExe(strVal)) = MS Then

flagFound = True : Exit For 'toggle flag to allowed for this DLL

End If

 

Next 'SP array member

 

'if this DLL not allowed

If Not flagFound Then

 

flagInfect = True 'toggle infected flag for entire value

 

If strWarn = "" Then 'if this is 1st unallowed value

strWarn = IWarn & "(" & DQ & Trim(strVal) & DQ & CoName(IDExe(strVal))

flagIWarn = True

Else 'not the 1st unallowed value

strWarn = strWarn & ", " & DQ & Trim(strVal) & DQ & CoName(IDExe(strVal))

End If

 

End If 'DLL allowed?

 

Next 'value array member

 

'if infection present, terminate warning message

If strWarn <> "" Then strWarn = strWarn & ") "

 

'output if infected or ShowAll

If flagInfect Or flagShowAll Then

On Error Resume Next

TitleLineWrite

oFN.WriteLine strWarn & DQ & "SecurityProviders" & DQ & " = " &_

DQ & strValue & DQ

intErrNum = Err.Number : Err.Clear

On Error Goto 0

If intErrNum <> 0 Then oFN.WriteLine DQ & "SecurityProviders" & DQ &_

" = (value not set)"

End If

 

Else 'value not set

 

TitleLineWrite

oFN.WriteLine DQ & "SecurityProviders" & DQ & " = (value not set)"

 

End If

 

 

'HKLM\System\CurrentControlSet\Control\Session Manager\BootExecute

strKey = "System\CurrentControlSet\Control\Session Manager"

strSubTitle = SYCA("HKLM" & "\" & strKey & "\")

 

intErrNum = oReg.GetMultiStringValue (HKLM,strKey,"BootExecute",arNames)

 

'initialize output strings

strLine = "" : strCN = "" : flagInfect = False : strWarn = ""

 

If intErrNum = 0 Then 'BootExecute value exists

 

'alert if autocheck not in every line of multi-string

For i = 0 To UBound(arNames)

 

'if autocheck not in a line, trim, surround in quotes, look for CoName

If InStr(LCase(arNames(i)),"autocheck") = 0 Then

strWarn = IWarn : flagInfect = True : flagIWarn = True

strLine = StrOutSep(strLine,StringFilter(Trim(arNames(i)),True) & CoName(IDExe(arNames(i))),"|")

Else

'otherwise, trim and surround in quotes

strLine = StrOutSep(strLine,StringFilter(Trim(arNames(i)),True),"|")

End If

 

Next 'arNames member

 

Else 'BootExecute value doesn't exist or not set

 

strLine = "(value not set)"

 

End If 'BootExecute value exists?

 

'output bootexecute value

If flagInfect Or flagShowAll Then

 

'write name and value to file

On Error Resume Next

TitleLineWrite

 

'output final line

oFN.WriteLine strWarn & DQ & "BootExecute" & DQ & " = " & strLine

intErrNum = Err.Number : Err.Clear

On Error GoTo 0

 

'if write error, output warning

If intErrNum <> 0 Then oFN.WriteLine DQ & "BootExecute" & DQ &_

" = (value not set)"

 

End If 'flagInfect Or flagShowAll?

 

 

'HKLM\System\CurrentControlSet\Control\Session Manager\Execute

strKey = "SYSTEM\CurrentControlSet\Control\Session Manager"

RegDataChk_v2 HKLM, strKey, "Execute", "", "", False

 

 

'HKLM\System\CurrentControlSet\Control\Session Manager\SetupExecute

strKey = "SYSTEM\CurrentControlSet\Control\Session Manager"

RegDataChk_v2 HKLM, strKey, "SetupExecute", "", "", False

 

 

'HKLM\System\CurrentControlSet\Control\WOW

'WVa does not contain these values by default

If strOS <> "WVA" Then

strKey = "System\CurrentControlSet\Control\WOW"

strSubTitle = SYCA("HKLM" & "\" & strKey & "\")

RegDataChk_v2 HKLM, strKey, "cmdline", Wshso.ExpandEnvironmentStrings("%SystemRoot%\system32\ntvdm.exe"), "", True

RegDataChk_v2 HKLM, strKey, "wowcmdline", _

Wshso.ExpandEnvironmentStrings("%SystemRoot%\system32\ntvdm.exe -a %SystemRoot%\system32\krnl386"), "", False

End if 'WVa?

 

End If 'not W98/WMe

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

strLine = "" : strWarn = ""

 

End If 'SecTest?

 

 

 

 

'#8. HKLM... Windows NT... Winlogon\Notify\ subkey DLLName values

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

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" 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"

arSK.Add "wgalogon", "wgalogon.dll"

 

End If

 

arSKk = arSK.Keys

arSKi = arSK.Items

 

If strOS <> "W98" And strOS <> "WME" And strOS <> "WVA" Then

 

strKey = "Software\Microsoft\Windows NT\CurrentVersion\Winlogon\Notify"

strSubTitle = SOCA("HKLM" & "\" & strKey & "\")

 

'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

 

'initialize variables

flagInfect = True : strWarn = IWarn

 

'get the DLLName data

intErrNum = oReg.GetStringValue (HKLM,strKey & "\" & oKey,"DLLName",strValue)

 

'if sub-key DLLName name exists And value set (exc for W2K!)

If intErrNum = 0 And strValue <> "" Then

 

'check dictionary for allowed entry

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 : strWarn = "" : Exit For

End If

 

Next 'dictionary key

 

'if DLL not allowed, toggle IWarn flag

If flagInfect Then flagIWarn = True

 

'if flag not found in O/S-specific dictionary or ShowAll

If flagInfect Or flagShowAll Then

 

'output title lines if not already done

TitleLineWrite

 

On Error Resume Next

'write the key, name and value to a file

oFN.WriteLine strWarn & oKey & "\DLLName = " & DQ &_

strValue & DQ & CoName(IDExe(strValue))

intErrNum = Err.Number : Err.Clear

On Error GoTo 0

'error check for W2K if DLLName value not set

If intErrNum <> 0 Then oFN.WriteLine oKey & "\DLLName" &_

" = (value not set)"

 

End If 'flag not found in dictionary or ShowAll?

 

End If 'value missing?

 

Next 'Notify subkey

 

Else 'Notify subkeys don't exist

 

'output title line

If flagShowAll Then TitleLineWrite

 

End If 'Notify subkeys exist?

 

End If 'not W98/WMe/WVa

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

strWarn = "" : strCN = ""

 

'recover array memory

arSK.RemoveAll : Set arSK=Nothing : ReDim arKeys(0)

 

End If 'SecTest?

[MAcgYvER everyONE 0]

'#9. HKLM... Windows NT... Image File Execution Options ("Debugger" subkeys)

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

'ignore W98/WMe/WVa

If strOS <> "W98" And strOS <> "WME" And strOS <> "WVA" Then

 

strKey = "Software\Microsoft\Windows NT\CurrentVersion\Image File Execution Options"

strSubTitle = SOCA("HKLM\" & strKey & "\")

 

'get executable name sub-keys

oReg.EnumKey HKLM,strKey,arSubKeys

 

If IsArray(arSubKeys) Then

 

'for each sub-key

For Each strSubKey in arSubKeys

 

strWarn = ""

 

'skip allowed sub-key unless ShowAll

If LCase(strSubKey) <> LCase("Your Image File Name Here without a path") Or _

flagShowAll Then

 

'look for Debugger value

intErrNum = oReg.GetStringValue (HKLM,strKey & "\" & strSubKey,"Debugger",strValue)

 

'if Debugger value exists

If intErrNum = 0 And strValue <> "" Then

 

'if sub-key is not allowed, set warning

If LCase(strSubKey) <> LCase("Your Image File Name Here without a path") Then

strWarn = IWarn : flagIWarn = True

End If

 

'output title line if not already done

TitleLineWrite

 

'output sub-key, warning, Debugger value

oFN.WriteLine strWarn & strSubKey & "\Debugger = " &_

DQ & strValue & DQ & CoName(IDExe(strValue))

 

End If 'Debugger value exists?

 

End If 'not allowed sub-key or ShowAll?

 

Next 'IFEO sub-key

 

'recover array memory

ReDim arSubKeys(0)

 

End If 'IFEO sub-key array exists?

 

End If 'not W98/WMe?

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

End If 'SecTest?

 

 

 

 

'#10. HKCU/HKLM... Policies... Startup/Shutdown, Logon/Logoff scripts (W2K/WXP/WVa)

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

strCmd = "" 'script command line string

Dim arScrName() : ReDim arScrName(1,1)

arScrName(0,0) = "Logon" : arScrName(0,1) = "Logoff"

arScrName(1,0) = "Startup" : arScrName(1,1) = "Shutdown"

 

'treat WVa analogously to WXP

Dim strOSEq : strOSEQ = strOS

If strOS = "WXP" Or strOS = "WVA" Then strOSEq = "WXP-WVA"

 

Dim strScrDir : strScrDir = strFSP & "\Scripts\"

If strOS = "WVA" Then strScrDir = strFSP & "\GroupPolicy\"

 

Select Case strOSEq

 

Case "W2K"

 

'collection flag

Dim flagColl : flagColl = False

 

'for HKCU, then HKLM

For i = 0 To 1

 

strKey = "Software\Policies\Microsoft\Windows\System\Scripts"

strSubTitle = SOCA(arHives(i,0) & "\" & strKey & "\")

 

'for every script type for the hive

For j = 0 To 1

 

intErrNum = oReg.GetStringValue(arHives(i,1), strKey, arScrName(i,j), strValue)

 

If intErrNum = 0 And strValue <> "" Then

 

'if value points to SCRIPTS.INI, parse the file

If Fso.FileExists(strValue & "\scripts.ini") Then

 

ScrIFP strValue, arScrName(i,j)

 

'value is not empty, so output a warning, or value is not set

ElseIf strValue <> "" Then

 

On Error Resume Next

TitleLineWrite

oFN.WriteLine "WARNING! Either " & DQ & strValue &_

"\scripts.ini" & DQ & vbCRLF & Space(9) & "doesn't " &_

"exist or there " & "is insufficient permission to " &_

"read it!"

intErrNum = Err.Number : Err.Clear

On Error Goto 0

 

If intErrNum <> 0 Then

TitleLineWrite

oFN.WriteLine strName & " = (value not set)"

End If

 

End If 'value points to SCRIPTS.INI or is not empty

 

End If 'HKCU logon/logoff Or HKLM startup/shutdown value exists?

 

Next 'name in Scripts key

 

'if ShowAll, output title line

If flagShowAll Then TitleLineWrite

 

Next 'hive type

 

Case "WXP-WVA"

 

'Base Key string

Dim strBK : strBK = "Software\Policies\Microsoft\Windows\System\Scripts\"

'modify script location for WVa

If strOS = "WVA" Then strBK = "Software\Microsoft\Windows\CurrentVersion\Group Policy\Scripts\"

 

Dim arNKSE 'Numbered (master) Keys containing Script Executable values

'values: DisplayName, FileSysPath, Script, Parameter

Dim strSPXP, strDispName, strFSP, strScript, strParam

 

'for every hive

For i = 0 To 1

 

'for every script type

For j = 0 To 1

 

strSubTitle = SOCA(arHives(i,0) & "\" & strBK & arScrName(i,j) & "\")

 

'look for script type subkeys

oReg.EnumKey arHives(i,1),strBK & arScrName(i,j),arKeys

 

'enumerate data if present

If IsArray(arKeys) Then

 

'for each numbered key header (containing numbered script keys)

For Each strKey in arKeys

 

strSubTitle = SOCA(arHives(i,0) & "\" & strBK & arScrName(i,j) &_

"\" & strKey & "\")

 

'find DisplayName & FileSysPath

intErrNum1 = oReg.GetStringValue (arHives(i,1),strBK & arScrName(i,j) &_

"\" & strKey,"DisplayName",strDispName)

 

'embed existing, non-empty value in quotes

If intErrNum1 = 0 And strDispName <> "" Then

strDispName = DQ & strDispName & DQ

'for missing or empty value

Else

strDispName = "(value not set)"

End If 'DisplayName exists?

 

intErrNum2 = oReg.GetStringValue (arHives(i,1),strBK & arScrName(i,j) &_

"\" & strKey,"FileSysPath",strFSP)

 

'if FileSysPath value exists And not empty

If intErrNum2 = 0 And strFSP <> "" Then

 

'look for numbered script subkeys

oReg.EnumKey arHives(i,1),strBK & arScrName(i,j) & "\" & strKey,arNKSE

 

'enumerate data if present

If IsArray(arNKSE) Then

 

'for each numbered script key

For Each strKey2 in arNKSE

 

strSPXP = "" 'empty the script path

 

'find Parameter value

intErrNum3 = oReg.GetStringValue (arHives(i,1),strBK & arScrName(i,j) &_

"\" & strKey & "\" & strKey2,"Parameters",strParam)

 

'if Parameters name doesn't exist, set value to empty string

If intErrNum3 <> 0 Then strParam = ""

 

'find Script value

intErrNum4 = oReg.GetStringValue (arHives(i,1),strBK & arScrName(i,j) &_

"\" & strKey & "\" & strKey2,"Script",strScript)

 

'if Script value exists And not empty

If intErrNum4 = 0 And strScript <> "" Then

 

'form script executable string

'if script string has no backslash, use

'FileSysPath\Scripts\[script type]\ to locate executable

'if executable not found, it will not launch

If InStr(strScript,"\") = 0 Then _

strSPXP = strFSP & "\Scripts\" & arScrName(i,j) & "\"

 

strCmd = strSPXP & strScript

 

'if parameter string is not empty, append it

If Trim(strParam) <> "" Then strScript = strScript & " " & strParam

 

'write title lines if necessary for this master key

TitleLineWrite

oFN.WriteLine "DisplayName = " & strDispName

 

'write script executable

oFN.WriteLine strKey2 & "\" & " -> launches: " & DQ &_

strCmd & DQ & CoName(IDExe(strCmd))

 

End If 'Script value exists And not empty?

 

Next 'numbered script executable key

 

End If 'script executable key array exists?

 

End If 'FileSysPath exists?

 

Next 'master key

 

End If 'master key array exists?

 

'if ShowAll and no prior output, output key

If flagShowAll Then TitleLineWrite

 

Next 'script type

 

Next 'hive type

 

'recover array memory

ReDim arScrName(0)

 

End Select 'W2K or WXP-WVA?

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

End If 'SecTest?

 

 

 

 

'#11. HKCU/HKLM Protocols\Filter

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

Dim strSKey 'sub-key

 

'10 x 3 arFilter array: filter title, CLSID value, CLSID\InProcServer32 default value

ReDim arFilter(9,2)

 

arFilter(0,0) = "Class Install Handler"

arFilter(0,1) = "{32B533BB-EDAE-11d0-BD5A-00AA00B92AF1}"

arFilter(0,2) = "urlmon.dll"

 

arFilter(1,0) = "deflate"

arFilter(1,1) = "{8f6b0360-b80d-11d0-a9b3-006097942311}"

arFilter(1,2) = "urlmon.dll"

 

arFilter(2,0) = "gzip"

arFilter(2,1) = "{8f6b0360-b80d-11d0-a9b3-006097942311}"

arFilter(2,2) = "urlmon.dll"

 

arFilter(3,0) = "lzdhtml"

arFilter(3,1) = "{8f6b0360-b80d-11d0-a9b3-006097942311}"

arFilter(3,2) = "urlmon.dll"

 

arFilter(4,0) = "text/webviewhtml"

arFilter(4,1) = "{733AC4CB-F1A4-11d0-B951-00A0C90312E1}"

arFilter(4,2) = "shell32.dll"

 

arFilter(5,0) = "text/webviewhtml"

arFilter(5,1) = "{733AC4CB-F1A4-11d0-B951-00A0C90312E1}"

arFilter(5,2) = "shdoc401.dll"

 

arFilter(6,0) = "text/webviewhtml"

arFilter(6,1) = "{733AC4CB-F1A4-11d0-B951-00A0C90312E1}"

arFilter(6,2) = "shdocvw.dll"

 

arFilter(7,0) = "application/octet-stream"

arFilter(7,1) = "{1E66F26B-79EE-11D2-8710-00C04F79ED0D}"

arFilter(7,2) = "mscoree.dll"

 

arFilter(8,0) = "application/x-complus"

arFilter(8,1) = "{1E66F26B-79EE-11D2-8710-00C04F79ED0D}"

arFilter(8,2) = "mscoree.dll"

 

arFilter(9,0) = "application/x-msdownload"

arFilter(9,1) = "{1E66F26B-79EE-11D2-8710-00C04F79ED0D}"

arFilter(9,2) = "mscoree.dll"

 

strKey = "Software\Classes\PROTOCOLS\Filter"

 

'for HKCU & HKLM

For i = 0 To 1

 

strSubTitle = SOCA(arHives(i,0) & "\" & strKey & "\")

 

'find all the subkeys

oReg.EnumKey arHives(i,1), strKey, arKeys

 

'enumerate data if present

If IsArray(arKeys) Then

 

'for each sub-key

For Each strSKey In arKeys

 

'set default values:

'flagMatch = True if filter name, CLSID, InProcServer32 DLL, &

' DLL CoName match allowed values

flagMatch = False

 

'get the Filter CLSID value

intErrNum1 = oReg.GetStringValue (arHives(i,1),strKey & "\" & strSKey, _

"CLSID",strCLSID)

 

'if CLSID name exists And value set (exc for W2K!)

If intErrNum1 = 0 And strCLSID <> "" Then

 

flagTitle = False

 

'for each CLSID hive

For ctrCH = intCLL To 1

 

'retrieve CLSID title & IPSDLL

ResolveCLSID strCLSID, arHives(ctrCH,1), strCLSIDTitle, strIPSDLL

 

'if IPSDLL retrieved

If strIPSDLL <> "" Then

 

strCN = CoName(IDExe(strIPSDLL)) 'find CoName for matching

 

'check array for allowed entry

For j = 0 To UBound(arFilter,1)

 

'if filter name, CLSID value, DLL match arFilter & CoName = MS & hive = HKLM

If LCase(strSKey) = LCase(arFilter(j,0)) And _

LCase(strCLSID) = LCase(arFilter(j,1)) And _

LCase(IDExe(strIPSDLL)) = LCase(strFPSF & "\" & arFilter(j,2)) And _

strCN = MS And ctrCH = 1 Then

 

'toggle flag, empty warning string

flagMatch = True : strWarn = "" : Exit For

 

End If 'filter name & CLSID match arFilter?

 

Next 'arFilter member

 

If Not flagMatch Then

strWarn = IWarn : flagIWarn = True

End If

 

'if filter not in allowed array Or ShowAll

If Not flagMatch Or flagShowAll Then

 

TitleLineWrite

 

If Not flagTitle Then

On Error Resume Next

'write the quote-delimited filter name and CLSID value

oFN.WriteLine strWarn & strSKey & "\CLSID = " & DQ & strCLSID & DQ

intErrNum = Err.Number : Err.Clear : flagTitle = True

On Error Goto 0

End If

 

If intErrNum = 0 Then

oFN.WriteLine " -> {" & arHives(ctrCH,0) & "...CLSID} = " &_

strCLSIDTitle & vbCRLF & Space(19) & "\InProcServer32\(Default) = " &_

StringFilter(strIPSDLL,True) & strCN

Else

oFN.WriteLine strSKey & "\CLSID = (value not set)"

End If

 

End If 'Not flagMatch Or ShowAll?

 

End If 'strIPSDLL exists?

 

Next 'CLSID hive

 

ElseIf flagShowAll Then 'strCLSID doesn't exist & flagShowAll

 

oFN.WriteLine vbCRLF & strSKey & "\CLSID = (value not set)"

 

End If 'strCLSID exists?

 

Next 'Filter subkey

 

End If 'Filter subkeys exist?

 

Next 'PROTOCOLS/Filter hive

 

If flagShowAll Then TitleLineWrite

 

'reset flag

flagMatch = False

 

'reset strings

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

strWarn = ""

 

'recover array memory

ReDim arFilter(0)

 

End If 'SecTest?

 

 

 

 

'#12. Context menu shell extensions

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

Dim arClasses() : ReDim arClasses(3)

arClasses(0) = "*" : arClasses(1) = "Directory" : arClasses(2) = "Folder"

arClasses(3) = "AllFilesystemObjects"

Dim arAllowedDlls ()

 

'ColumnHandlers

 

ReDim arAllowedDlls(2)

arAllowedDlls(0) = "docprop2.dll" : arAllowedDlls(1) = "faxshell.dll"

arAllowedDlls(2) = "shell32.dll"

 

For i = 0 To UBound(arClasses)

 

strSubTitle = SOCA("HKLM\Software\Classes\" & arClasses(i) &_

"\shellex\ColumnHandlers\")

strKey = "Software\Classes\" & arClasses(i) & "\shellex\ColumnHandlers"

intErrNum = oReg.EnumKey(HKLM,strKey,arSubKeys)

 

If intErrNum = 0 And IsArray(arSubKeys) Then

 

For Each strSubKey In arSubKeys

 

flagTitle = False

 

For ctrCH = intCLL To 1

 

CLSIDLocTitle arHives(ctrCH,1), strKey & "\" & strSubKey, "", strLocTitle

ResolveCLSID strSubKey, arHives(ctrCH,1), strCLSIDTitle, strIPSDLL

 

If strIPSDLL <> "" Then 'IPS exists?

 

flagAllow = False

 

For j = 0 To UBound(arAllowedDlls)

 

strCN = CoName(IDExe(strIPSDLL))

If LCase(Trim(Fso.GetFileName(strIPSDLL))) = LCase(arAllowedDlls(j)) And _

strCN = MS And ctrCH = 1 Then

flagAllow = True : Exit For

End If

 

Next 'arAllowedDlls element

 

If Not flagAllow Or flagShowAll Then

 

TitleLineWrite

 

If Not flagTitle Then

oFN.WriteLine strSubKey & "\(Default) = " & strLocTitle

flagTitle = True

End If

 

oFN.WriteLine " -> {" & arHives(ctrCH,0) & "...CLSID} = " &_

strCLSIDTitle & vbCRLF & Space(19) & "\InProcServer32\(Default) = " &_

StringFilter(strIPSDLL,True) & CoName(IDExe(strIPSDLL))

 

End If 'Not flagAllow Or ShowAll?

 

End If 'strIPSDLL not empty?

 

Next 'CLSID hive

 

Next 'sub-key

 

End If 'sub-keys exist?

 

Next 'class

 

 

'ContextMenuHandlers

 

ReDim arAllowedDlls(7)

arAllowedDlls(0) = "syncui.dll" : arAllowedDlls(1) = "cscui.dll"

arAllowedDlls(2) = "shell32.dll" : arAllowedDlls(3) = "runext.dll"

arAllowedDlls(4) = "ntshrui.dll" : arAllowedDlls(5) = "msshrui.dll"

arAllowedDlls(6) = "shcompui.dll" : arAllowedDlls(7) = "shdoc401.dll"

 

'layout.dll, CoName = "Microsoft"

 

For i = 0 To UBound(arClasses)

 

strSubTitle = SOCA("HKLM\Software\Classes\" & arClasses(i) &_

"\shellex\ContextMenuHandlers\" )

strKey = "Software\Classes\" & arClasses(i) & "\shellex\ContextMenuHandlers"

intErrNum = oReg.EnumKey(HKLM,strKey,arSubKeys)

 

If intErrNum = 0 And IsArray(arSubKeys) Then

 

For Each strSubKey In arSubKeys

 

intErrNum2 = oReg.GetStringValue(HKLM,strKey & "\" & strSubKey,"",strCLSID)

If intErrNum2 = 0 And strCLSID <> "" Then

 

flagTitle = False

 

For ctrCH = intCLL To 1

 

ResolveCLSID strCLSID, arHives(ctrCH,1), strCLSIDTitle, strIPSDLL

 

If strIPSDLL <> "" Then 'IPS exists?

 

flagAllow = False

 

For j = 0 To UBound(arAllowedDlls)

 

strCN = CoName(IDExe(strIPSDLL))

If LCase(Trim(Fso.GetFileName(strIPSDLL))) = LCase(arAllowedDlls(j)) And _

strCN = MS And ctrCH = 1 Then

flagAllow = True : Exit For

End If

 

Next 'arAllowedDlls element

 

If Not flagAllow Or flagShowAll Then

 

TitleLineWrite

 

If Not flagTitle Then

oFN.WriteLine strSubKey & "\(Default) = " & DQ & strCLSID & DQ

flagTitle = True

End If

 

oFN.WriteLine " -> {" & arHives(ctrCH,0) & "...CLSID} = " &_

strCLSIDTitle & vbCRLF & Space(19) & "\InProcServer32\(Default) = " &_

StringFilter(strIPSDLL,True) & CoName(IDExe(strIPSDLL))

 

End If 'Not flagAllow Or ShowAll?

 

End If 'strIPSDLL exists?

 

Next 'CLSID hive

 

End If 'CLSID exists?

 

Next 'sub-key

 

End If 'sub-keys exist?

 

Next 'class

 

'recover array memory

ReDim arClasses(0)

 

'reset strings

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

End If 'SecTest?

 

 

 

 

'#13. HKCU/HKLM executable file type (bat/cmd/com/exe/hta/pif/scr)

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

'this section does *not* output what executes -- it only outputs

'what's different from default

 

'set up executables/executable file type/expected value arrays, counter

Dim arExeExt, arExeFT, arExpVal, intLC

 

If strOS = "W98" Or strOS = "WME" Then

arExeExt = Array("bat","com","exe","hta","pif","scr")

arExeFT = Array("batfile","comfile","exefile","htafile","piffile","scrfile")

arExpVal = Array("""%1"" %*","""%1"" %*","""%1"" %*", _

LCase(Fso.GetSpecialFolder(1)) & "\mshta.exe ""%1"" %*", _

"""%1"" %*","""%1"" /s")

Else

arExeExt = Array("bat","cmd","com","exe","hta","pif","scr")

arExeFT = Array("batfile","cmdfile","comfile","exefile","htafile","piffile","scrfile")

arExpVal = Array("""%1"" %*","""%1"" %*","""%1"" %*","""%1"" %*", _

LCase(Fso.GetSpecialFolder(1)) & "\mshta.exe ""%1"" %*", _

"""%1"" %*","""%1"" /s")

End If

 

Dim arFileExtNames 'array of Explorer\FileExt names

Dim arFileExtClass 'array of Class loc'ns for Explorer\FileExt names

 

If strOS = "W2K" Or strOS = "WME" Then

arFileExtNames = Array ("Application")

arFileExtClass = Array ("Applications\")

ElseIf strOs = "WXP" Then

arFileExtNames = Array("ProgID", "Application")

arFileExtClass = Array ("", "Applications\")

End if

 

'alternate hive counter, file type, SOC expected value

Dim ctrCH2, strFileType, strSOCExpVal

 

strTitle = "Default executables:"

 

 

'FileExts loop

 

'WME/W2K/WXP only

If strOS = "WME" Or strOS = "W2K" Or strOS = "WXP" Then

 

'for each ext

For i = 0 To UBound(arExeExt)

 

strKey = "Software\Microsoft\Windows\CurrentVersion\Explorer\FileExts\." & arExeExt(i)

strSubTitle = "HKCU\" & strKey

 

'for Application/ProgID names (per O/S)

For j = 0 To UBound(arFileExtNames)

 

'look for FileExts App/ProgID value

intErrNum = oReg.GetStringValue (HKCU,strKey,arFileExtNames(j),strValue)

 

'output if FileExts App/ProgID value exists

If intErrNum = 0 And strValue <> "" Then

 

strSubTitle = IWarn & "HKCU\" & strKey & "\" & vbCRLF & DQ & arFileExtNames(j) &_

DQ & " = " & StringFilter(strValue,True)

TitleLineWrite

 

'look in both hives except for WMe, which does not use HKCU...Classes\Applications

intLC = intCLL : If strOS = "WME" Then intLC = 1

 

'look for App/ProgID value

For ctrCH2 = intLC to 1

 

strOut = ""

 

'look for App/ProgID value in Classes\Applications

SOCValue arFileExtClass(j) & strValue, ctrCH2, "", False

 

'output if found

If strOut <> "" Then

TitleLineWrite : oFN.WriteLine vbCRLF & strOut

End If

 

'if App/ProgID name is "Application" And value (may be) filename,

'add ".exe" to value and try to find it again

If strOut = "" And arFileExtNames(j) = "Application" Then

 

SOCValue arFileExtClass(j) & strValue & ".exe",ctrCH2,"",False

 

'output if found

If strOut <> "" Then

TitleLineWrite : oFN.WriteLine vbCRLF & strOut

End If

 

End If 'strOut empty & value (may be) filename?

 

Next 'hive

 

End If 'FileExts App/ProgID value found?

 

Next 'possible FileExt value (App/ProgID)

 

'if ShowAll, output FileExts key if not already done

If flagShowAll Then TitleLineWrite

 

Next 'ext

 

'clean up

strSubTitle = "" : strOut = ""

 

End If 'WMe/W2K/WXP?

 

 

'main Classes\.ext loop

 

'for each ext

For i = 0 To UBound(arExeExt)

 

'for each hive

For ctrCH = intCLL To 1

 

'reset variables

strSubTitle = "" : strOut = ""

 

'construct ext key

strKey = "Software\Classes\." & arExeExt(i)

 

'look for ext key default value (file type)

intErrNum = oReg.GetStringValue (arHives(ctrCH,1),strKey,"",strValue)

 

'if ext key file type exists

If intErrNum = 0 And strValue <> "" Then

 

'form subtitle .ext=filetype

strSubTitle = SOCA(arHives(ctrCH,0) & "\" & strKey &_

"\(Default) = " & StringFilter(strValue,True))

 

'output subtitle with warning if in HKCU or value unexpected

If ctrCH = 0 Or strValue <> arExeFT(i) Then

strSubTitle = IWarn & strSubTitle : TitleLineWrite

 

End If

 

'save file type for this hive

strFileType = strValue

 

'search for filetype in each hive

For ctrCH2 = intCLL To 1

 

'prepare expected SOC value for HKLM

strSOCExpVal = ""

If ctrCH2 = 1 Then strSOCExpVal = arExpVal(i)

 

'find file type SOC value in each hive

SOCValue strFileType,ctrCH2,strSOCExpVal,False

 

Next 'hive

 

'look for SOC value/key at ext

SOCValue "." & arExeExt(i), ctrCH, "", False

 

'ext key default value (file type) not set

Else

 

'look for ext key

intErrNum = oReg.EnumValues (arHives(ctrCH,1),strKey,arNames,arType)

 

'if ext key exists

If intErrNum = 0 Then

 

'output ext key

strSubTitle = StrOutSep(strOut,SOCA(arHives(ctrCH,0) & "\" & strKey) &_

"\(Default) = (value not set)",vbCRLF)

 

'look for ext key SOC value/key

SOCValue "." & arExeExt(i), ctrCH, "", False

 

Else 'ext key doesn't exist

 

If ctrCH = 1 Then strSubTitle = StrOutSep(strOut,SOCA(arHives(ctrCH,0) &_

"\" & strKey) & "\ = (key not found)",vbCRLF)

 

End If 'ext key?

 

End If 'ext key file type exists?

 

'write output

If strOut <> "" Or flagShowAll Then

TitleLineWrite

If strOut <> "" Then oFN.WriteLine strOut

End If

 

Next 'Class hive

 

Next 'ext

 

strTitle = "" : strSubTitle = "" : strOut = ""

 

'recover array memory

ReDim arExeExt(0) : ReDim arExtFT(0) : ReDim arExpVal(0)

 

If strOS = "WME" Or strOS = "W2K" Or strOS = "WXP" Then

ReDim arFileExtNames(0) : ReDim arFileExtClass(0)

End If

 

End If 'SecTest?

 

 

 

 

'#14. System/Group Policies

 

' Checked Keys:

'

' HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\ActiveDesktop

' HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\Assocations

' HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\Attachments

' HKCU/HKLM\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer

' HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\DisallowCpl

' HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\System

' HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\WindowsUpdate

' HKCU/HKLM\Software\Policies\Microsoft\Internet Explorer\Control Panel

' HKCU/HKLM\Software\Policies\Microsoft\Internet Explorer\Download

' HKCU/HKLM\Software\Policies\Microsoft\Internet Explorer\Infodelivery\Restrictions

' HKCU/HKLM\Software\Policies\Microsoft\Internet Explorer\Main

' HKCU/HKLM\Software\Policies\Microsoft\Internet Explorer\Main\FeatureControl\FEATURE_WINDOW_RESTRICTIONS

' HKCU/HKLM\Software\Policies\Microsoft\Internet Explorer\PhishingFilter

' HKCU/HKLM\Software\Policies\Microsoft\Internet Explorer\Restrictions

' HKCU/HKLM\Software\Policies\Microsoft\Internet Explorer\Security

' HKCU\Software\Policies\Microsoft\MMC\{8FC0B734-A0E1-11D1-A7D3-0000F87571E3}

' HKCU/HKLM\Software\Policies\Microsoft\Windows\CurrentVersion\Internet Settings\Lockdown_Zones\2

' HKCU/HKLM\Software\Policies\Microsoft\Windows\CurrentVersion\Internet Settings\Lockdown_Zones\3

' HKCU/HKLM\Software\Policies\Microsoft\Windows\CurrentVersion\Internet Settings\Lockdown_Zones\4

' HKCU/HKLM\Software\Policies\Microsoft\Windows\CurrentVersion\Internet Settings\Zones\2

' HKCU/HKLM\Software\Policies\Microsoft\Windows\CurrentVersion\Internet Settings\Zones\3

' HKCU/HKLM\Software\Policies\Microsoft\Windows\CurrentVersion\Internet Settings\Zones\4

' HKCU\Software\Policies\Microsoft\Windows\Network Connections

' HKCU\Software\Policies\Microsoft\Windows\System

' HKCU\Software\Policies\Microsoft\Windows\Task Scheduler5.0

' HKLM\Software\Microsoft\Windows\CurrentVersion\Policies\System

' HKLM\Software\Policies\Microsoft\Windows NT\SystemRestore

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

Const ATPL = "Administrative Templates|"

Const WSSSLP = "Windows Settings|Security Settings|Local Policies|"

Const WC = "Windows Components|"

Const IEX = "Internet Explorer|"

Const MMC = "Microsoft Management Console|"

Const WEX = "Windows Explorer|"

Const SMTB = "Start Menu and Taskbar|"

Const DT = "Desktop|"

Const DAD = "Desktop / Active Desktop|"

Const CP = "Control Panel|"

Const NWK = "Network|"

Const SYS = "System|"

 

'assign System or Group Policy name

Dim strPolName : strPolName = "System "

If strOS = "W2K" Or strOS = "WXP" Or strOS = "WVA" Then strPolName = "Group "

 

Dim arDisCplNames, strDisCplName, strDisCplValue

 

 

'set title line

strTitle = strPolName & "Policies {policy setting}:"

'add GPEdit location to title if GP used (W2K, WXP Pro, WVa)

If flagGP Then strTitle = "Group Policies {GPedit.msc branch and setting}:"

strSubTitle = "Note: detected settings may not have any effect."

 

 

strKey = "Software\Microsoft\Windows\CurrentVersion\Policies\ActiveDesktop"

 

ReDim arRecNames(3,2)

 

arRecNames(0,0) = "NoChangingWallPaper" : arRecNames(0,1) = ATPL & CP & "Display|"

arRecNames(0,2) = "Disable changing wallpaper}"

If strOS = "WXP" Or strOS = "WVA" Then arRecNames(0,2) = "Prevent changing wallpaper}"

 

arRecNames(1,0) = "NoClosingComponents" : arRecNames(1,1) = ATPL & DT & DAD

arRecNames(1,2) = "Prohibit closing items}"

 

arRecNames(2,0) = "NoDeletingComponents" : arRecNames(2,1) = ATPL & DT & DAD

arRecNames(2,2) = "Prohibit deleting items}"

 

arRecNames(3,0) = "NoEditingComponents" : arRecNames(3,1) = ATPL & DT & DAD

arRecNames(3,2) = "Prohibit editing items}"

 

GPRecognizer HKCU, strKey : ReDimGPOArrays

 

 

strKey = "Software\Microsoft\Windows\CurrentVersion\Policies\Associations"

 

ReDim arRecNames(0,2)

 

arRecNames(0,0) = "DefaultFileTypeRisk"

arRecNames(0,1) = ATPL & WC & "Attachment Manager|"

arRecNames(0,2) = "Default risk level for file attachments}"

 

GPRecognizer HKCU, strKey : ReDimGPOArrays

 

 

strKey = "Software\Microsoft\Windows\CurrentVersion\Policies\Attachments"

 

ReDim arRecNames(0,2)

 

arRecNames(0,0) = "ScanWithAntiVirus"

arRecNames(0,1) = ATPL & WC & "Attachment Manager|"

arRecNames(0,2) = "Notify antivirus programs when opening attachments}"

 

GPRecognizer HKCU, strKey : ReDimGPOArrays

 

 

strKey = "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer"

 

ReDim arRecNames(27,2)

 

arRecNames(0,0) = "ClassicShell" : arRecNames(0,1) = ATPL & WC & WEX

arRecNames(0,2) = "Enable Classic Shell / Turn on Classic Shell}"

 

arRecNames(1,0) = "ForceActiveDesktopOn"

arRecNames(1,1) = ATPL & DT & DAD : arRecNames(1,2) = "Enable Active Desktop}"

If strOS = "W98" Or strOS = "NT4" Then

arRecNames(1,1) = "" : arRecNames(1,2) = "unrecognized setting}"

End If

 

arRecNames(2,0) = "NoActiveDesktop" : arRecNames(2,1) = ATPL & DT & DAD

arRecNames(2,2) = "Disable Active Desktop}"

 

arRecNames(3,0) = "NoActiveDesktopChanges" : arRecNames(3,1) = ATPL & DT & DAD

arRecNames(3,2) = "Prohibit changes}"

 

'added by GP, but ignored in practice, presence of DisallowCpl subkey name/value pairs

'sufficient to hide applets, even if this DWORD = 0 or absent

arRecNames(4,0) = "DisallowCpl" : arRecNames(4,1) = ATPL & CP

arRecNames(4,2) = "Hide specified control panel applets / items}"

 

arRecNames(5,0) = "NoToolbarCustomize" : arRecNames(5,1) = ATPL & WC & IEX & "Toolbars|"

arRecNames(5,2) = "Disable customizing browser toolbar buttons}"

 

arRecNames(6,0) = "NoBandCustomize" : arRecNames(6,1) = ATPL & WC & IEX & "Toolbars|"

arRecNames(6,2) = "Disable customizing browser toolbars}"

 

arRecNames(7,0) = "NoFolderOptions" : arRecNames(7,1) = ATPL & WC & WEX

arRecNames(7,2) = "Removes the Folder Options menu item from the Tools menu}"

 

arRecNames(8,0) = "NoWindowsUpdate" : arRecNames(8,1) = ATPL & SMTB

arRecNames(8,2) = "Remove links and access to Windows Update}"

 

arRecNames(9,0) = "NoTrayItemsDisplay" : arRecNames(9,1) = ATPL & SMTB

arRecNames(9,2) = "Hide the notification area}"

 

arRecNames(10,0) = "NoSetTaskbar" : arRecNames(10,1) = ATPL & SMTB

arRecNames(10,2) = "Prevent changes to Taskbar and Start Menu Settings}"

 

arRecNames(11,0) = "TaskbarLockAll" : arRecNames(11,1) = ATPL & SMTB

arRecNames(11,2) = "Lock all taskbar settings}"

 

arRecNames(12,0) = "TaskbarNoAddRemoveToolbar" : arRecNames(12,1) = ATPL & SMTB

arRecNames(12,2) = "Prevent users from adding or removing toolbars}"

 

arRecNames(13,0) = "TaskbarNoDragToolbar" : arRecNames(13,1) = ATPL & SMTB

arRecNames(13,2) = "Prevent users from rearranging toolbars}"

 

arRecNames(14,0) = "NoStartMenuMorePrograms" : arRecNames(14,1) = ATPL & SMTB

arRecNames(14,2) = "Remove All Programs list from the Start menu}"

 

arRecNames(15,0) = "NoSMHelp" : arRecNames(15,1) = ATPL & SMTB

arRecNames(15,2) = "Remove Help menu from Start Menu}"

 

arRecNames(16,0) = "NoAutoUpdate" : arRecNames(16,1) = ATPL & SYS

arRecNames(16,2) = "Windows Automatic Updates}"

 

arRecNames(17,0) = "NoSecurityTab" : arRecNames(17,1) = ATPL & WC & WEX

arRecNames(17,2) = "Remove Security tab}"

 

arRecNames(18,0) = "NoSaveSettings" : arRecNames(18,1) = ATPL & DT

arRecNames(18,2) = "Don't save settings at exit}"

 

arRecNames(19,0) = "NoStartBanner" : arRecNames(19,1) = ""

arRecNames(19,2) = "Remove " & DQ & "Click here to begin" & DQ & " from Start button}"

 

arRecNames(20,0) = "NoFavoritesMenu" : arRecNames(20,1) = ATPL & SMTB

arRecNames(20,2) = "Remove Favorites menu from Start Menu}"

 

arRecNames(21,0) = "NoWinKeys" : arRecNames(21,1) = ""

arRecNames(21,2) = "Disable Windows+X hotkeys}"

 

arRecNames(22,0) = "NoSMMyDocs" : arRecNames(22,1) = ATPL & SMTB

arRecNames(22,2) = "Remove Documents menu from Start Menu}"

 

arRecNames(23,0) = "NoSMMyPictures" : arRecNames(23,1) = ATPL & SMTB

arRecNames(23,2) = "Remove My Pictures icon from Start Menu}"

 

arRecNames(24,0) = "NoNetworkConnections" : arRecNames(24,1) = ATPL & SMTB

arRecNames(24,2) = "Remove Network & Dial-up Connections from Start Menu}"

If strOS = "WXP" Then arRecNames(24,2) = "Remove Network Connections from Start Menu}"

 

arRecNames(25,0) = "NoSharedDocuments" : arRecNames(25,1) = ATPL & WC & WEX

arRecNames(25,2) = "Remove Shared Documents from My Computer}"

 

arRecNames(26,0) = "NoLogoff" : arRecNames(26,1) = ATPL & SYS & "Logon/Logoff|"

arRecNames(26,2) = "Disable Logoff}"

 

arRecNames(27,0) = "NoInternetIcon" : arRecNames(27,1) = ATPL & DT

arRecNames(27,2) = "Hide Internet Explorer icon on desktop}"

 

ReDim arAllowedNames(2,3)

 

arAllowedNames(0,0) = "NoDriveTypeAutoRun" : arAllowedNames(0,1) = ATPL & WC & "AutoPlay Policies|"

arAllowedNames(0,2) = "Turn off Autoplay}"

arAllowedNames(0,3) = "***"

 

arAllowedNames(1,0) = "NoDriveAutoRun" : arAllowedNames(1,1) = ""

arAllowedNames(1,2) = "Turn off autoplay for drive letter}"

arAllowedNames(1,3) = "***"

 

arAllowedNames(2,0) = "MaxRecentDocs" : arAllowedNames(2,1) = ATPL & WC & WEX

arAllowedNames(2,2) = "Maximum number of recent documents}"

arAllowedNames(2,3) = "***"

 

GPRecognizer HKCU, strKey : ReDimGPOArrays

 

 

ReDim arAllowedNames(1,3)

 

arAllowedNames(0,0) = "NoDriveTypeAutoRun" : arAllowedNames(0,1) = ATPL & WC & "AutoPlay Policies|"

arAllowedNames(0,2) = "Turn off Autoplay}"

arAllowedNames(0,3) = "***"

 

arAllowedNames(1,0) = "NoDriveAutoRun" : arAllowedNames(1,1) = ""

arAllowedNames(1,2) = "Turn off autoplay for drive letter}"

arAllowedNames(1,3) = "***"

 

GPRecognizer HKLM, strKey : ReDimGPOArrays

 

'omitted Control Panel applets

strKey = "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\DisallowCpl"

 

GPRecognizer HKCU, strKey : ReDimGPOArrays

 

 

strKey = "Software\Microsoft\Windows\CurrentVersion\Policies\System"

 

ReDim arRecNames(5,2)

 

arRecNames(0,0) = "DisableRegistryTools" : arRecNames(0,1) = ATPL & SYS

arRecNames(0,2) = "Disable registry editing tools}"

If strOS = "WXP" Or strOS = "WVA" Then arRecNames(0,2) = "Prevent access to " &_

"registry editing tools}"

 

arRecNames(1,0) = "NoDispBackgroundPage" : arRecNames(1,1) = ATPL & CP & "Display|"

arRecNames(1,2) = "Hide Background tab}"

If strOS = "WXP" Or strOS = "WVA" Then arRecNames(1,2) = "Hide Desktop tab}"

 

arRecNames(2,0) = "NoDispCpl"

arRecNames(2,1) = ATPL & CP & "Display|"

arRecNames(2,2) = "Disable Display in Control Panel}"

If strOS = "WXP" Or strOS = "WVA" Then arRecNames(2,2) = "Remove Display in Control Panel}"

 

arRecNames(3,0) = "Wallpaper" : arRecNames(3,1) = ATPL & DT & DAD

arRecNames(3,2) = "Active Desktop Wallpaper|Wallpaper Name:}"

If strOS = "WVA" Then arRecNames(3,2) = "Desktop Wallpaper|Wallpaper Name:}"

 

arRecNames(4,0) = "WallpaperStyle" : arRecNames(4,1) = ATPL & DT & DAD

arRecNames(4,2) = "Active Desktop Wallpaper|Wallpaper Style:}"

If strOS = "WVA" Then arRecNames(4,2) = "Desktop Wallpaper|Wallpaper Style:}"

 

arRecNames(5,0) = "DisableTaskMgr"

arRecNames(5,1) = ATPL & SYS & "Ctrl+Alt+Del Options|"

If strOS = "W2K" Then arRecNames(5,1) = ATPL & SYS & "Logon/Logoff|"

arRecNames(5,2) = "Remove Task Manager}"

 

GPRecognizer HKCU, strKey : ReDimGPOArrays

 

 

strKey = "Software\Microsoft\Windows\CurrentVersion\Policies\WindowsUpdate"

 

ReDim arRecNames(0,2)

 

arRecNames(0,0) = "DisableWindowsUpdateAccess"

arRecNames(0,1) = ATPL & WC & "Windows Update|"

arRecNames(0,2) = "Remove access to use all Windows Update features}"

 

GPRecognizer HKCU, strKey : ReDimGPOArrays

 

 

strKey = "Software\Policies\Microsoft\Internet Explorer\Control Panel"

 

ReDim arRecNames(13,2)

 

arRecNames(1,0) = "Advanced" : arRecNames(1,1) = ATPL & WC & IEX

arRecNames(1,2) = "Disable changing Advanced page settings}"

 

arRecNames(2,0) = "AdvancedTab" 'HKLM

arRecNames(2,1) = ATPL & WC & IEX & "Internet Control Panel|"

arRecNames(2,2) = "Disable the Advanced page}"

 

arRecNames(3,0) = "Connection Settings" 'HKLM

arRecNames(3,1) = ATPL & WC & IEX

arRecNames(3,2) = "Disable changing connection settings}"

 

arRecNames(4,0) = "ConnectionsTab" 'HKLM

arRecNames(4,1) = ATPL & WC & IEX & "Internet Control Panel|"

arRecNames(4,2) = "Disable the Connections page}"

 

arRecNames(5,0) = "ContentTab" 'HKLM

arRecNames(5,1) = ATPL & WC & IEX & "Internet Control Panel|"

arRecNames(5,2) = "Disable the Content page}"

 

arRecNames(6,0) = "DisableRIED" 'HKLM

arRecNames(6,1) = ATPL & WC & IEX & "Internet Control Panel|Advanced Page|"

arRecNames(6,2) = "Do not allow resetting Internet Explorer settings}"

 

arRecNames(7,0) = "GeneralTab" 'HKLM

arRecNames(7,1) = ATPL & WC & IEX & "Internet Control Panel|"

arRecNames(7,2) = "Disable the General page}"

 

arRecNames(8,0) = "HomePage" : arRecNames(8,1) = ATPL & WC & IEX

arRecNames(8,2) = "Disable changing home page settings}"

 

arRecNames(9,0) = "PrivacyTab" 'HKLM

arRecNames(9,1) = ATPL & WC & IEX & "Internet Control Panel|"

arRecNames(9,2) = "Disable the Privacy page}"

 

arRecNames(10,0) = "Proxy" 'HKLM

arRecNames(10,1) = ATPL & WC & IEX

arRecNames(10,2) = "Disable changing proxy settings}"

 

arRecNames(11,0) = "ResetWebSettings" : arRecNames(11,1) = ATPL & WC & IEX

arRecNames(11,2) = "Disable the Reset Web Settings feature}"

 

arRecNames(12,0) = "SecurityTab" 'HKLM

arRecNames(12,1) = ATPL & WC & IEX & "Internet Control Panel|"

arRecNames(12,2) = "Disable the Security page}"

 

arRecNames(13,0) = "Settings" : arRecNames(13,1) = ATPL & WC & IEX

arRecNames(13,2) = "Prevent the deletion of temporary Internet files and cookies}"

 

GPRecognizer HKCU, strKey : GPRecognizer HKLM, strKey : ReDimGPOArrays

 

 

strKey = "Software\Policies\Microsoft\Internet Explorer\Download"

 

ReDim arRecNames(1,2)

 

arRecNames(0,0) = "RunInvalidSignatures" 'HKLM

arRecNames(0,1) = ATPL & WC & IEX & "Internet Control Panel|Advanced Page|"

arRecNames(0,2) = "Allow software to run or install even if the signature is invalid}"

 

arRecNames(1,0) = "CheckExeSignatures" 'HKLM

arRecNames(1,1) = ATPL & WC & IEX & "Internet Control Panel|Advanced Page|"

arRecNames(1,2) = "Check for signatures on downloaded programs}"

 

GPRecognizer HKCU, strKey : GPRecognizer HKLM, strKey : ReDimGPOArrays

 

 

strKey = "Software\Policies\Microsoft\Internet Explorer\Infodelivery\Restrictions"

 

ReDim arRecNames(1,2)

 

arRecNames(0,0) = "NoChangeDefaultSearchProvider" 'HKLM

arRecNames(0,1) = ATPL & WC & IEX

arRecNames(0,2) = "Restrict changing the default search provider}"

 

arRecNames(1,0) = "NoSearchCustomization"

arRecNames(1,1) = ATPL & WC & IEX

arRecNames(1,2) = "Search: Disable Search Customization}"

 

GPRecognizer HKCU, strKey : GPRecognizer HKLM, strKey : ReDimGPOArrays

 

 

strKey = "Software\Policies\Microsoft\Internet Explorer\Main"

 

ReDim arRecNames(1,2)

 

arRecNames(0,0) = "Enable Browser Extensions" 'HKLM

arRecNames(0,1) = ATPL & WC & IEX & "Internet Control Panel|Advanced Page|"

arRecNames(0,2) = "Allow third-party browser extensions}"

 

arRecNames(1,0) = "Start Page"

arRecNames(1,1) = ATPL & WC & IEX

arRecNames(1,2) = "Disable changing home page settings -- Home Page imposed by this setting}"

 

GPRecognizer HKCU, strKey : GPRecognizer HKLM, strKey : ReDimGPOArrays

 

 

strKey = "Software\Policies\Microsoft\Internet Explorer\Main\FeatureControl\FEATURE_WINDOW_RESTRICTIONS"

 

ReDim arRecNames(0,2)

 

arRecNames(0,0) = "*" 'HKLM

arRecNames(0,1) = ATPL & WC & IEX & "Security Features|Scripted Window Security Restrictions|"

arRecNames(0,2) = "Internet Explorer Processes}"

 

GPRecognizer HKCU, strKey : GPRecognizer HKLM, strKey : ReDimGPOArrays

 

 

strKey = "Software\Policies\Microsoft\Internet Explorer\PhishingFilter"

 

ReDim arRecNames(0,2)

 

arRecNames(0,0) = "Enabled" 'HKLM

arRecNames(0,1) = ATPL & WC & IEX

arRecNames(0,2) = "Turn off Managing Phishing filter}"

 

GPRecognizer HKCU, strKey : GPRecognizer HKLM, strKey : ReDimGPOArrays

 

 

strKey = "Software\Policies\Microsoft\Internet Explorer\Restrictions"

 

ReDim arRecNames(2,2)

 

arRecNames(0,0) = "NoExtensionManagement" 'HKLM

arRecNames(0,1) = ATPL & WC & IEX

arRecNames(0,2) = "Do not allow users to enable or disable add-ons}"

 

arRecNames(1,0) = "NoPopupManagement" 'HKLM

arRecNames(1,1) = ATPL & WC & IEX

arRecNames(1,2) = "Turn off pop-up management}"

 

arRecNames(2,0) = "NoBrowserOptions"

arRecNames(2,1) = ATPL & WC & IEX & "Browser Menus|"

arRecNames(2,2) = "Tools menu: Disable Internet Options... menu option}"

 

GPRecognizer HKCU, strKey : GPRecognizer HKLM, strKey : ReDimGPOArrays

 

 

strKey = "Software\Policies\Microsoft\Internet Explorer\Security"

 

ReDim arRecNames(1,2)

 

arRecNames(0,0) = "DisableFixSecuritySettings" 'HKLM

arRecNames(0,1) = ATPL & WC & IEX

arRecNames(0,2) = "Do not allow users to enable or disable add-ons}"

 

arRecNames(1,0) = "DisableSecuritySettingsCheck" 'HKLM

arRecNames(1,1) = ATPL & WC & IEX

arRecNames(1,2) = "Turn off the Security Settings Check feature}"

 

GPRecognizer HKCU, strKey : GPRecognizer HKLM, strKey : ReDimGPOArrays

 

 

strKey = "Software\Policies\Microsoft\MMC\{8FC0B734-A0E1-11D1-A7D3-0000F87571E3}"

 

ReDim arRecNames(0,2)

 

arRecNames(0,0) = "Restrict_Run"

arRecNames(0,1) = ATPL & WC & MMC & "Restricted/Permitted snap-ins|Group Policy|"

arRecNames(0,2) = "Group Policy Object Editor}"

 

GPRecognizer HKCU, strKey : ReDimGPOArrays

 

 

strKey = "Software\Policies\Microsoft\Windows\CurrentVersion\Internet Settings\Lockdown_Zones\2"

 

ReDim arRecNames(1,2)

 

arRecNames(0,0) = "1004" 'HKLM

arRecNames(0,1) = ATPL & WC & IEX & "Internet Control Panel|Security Page|Locked-Down Trusted Sites Zone|"

arRecNames(0,2) = "Download unsigned ActiveX controls}"

 

arRecNames(1,0) = "1201" 'HKLM

arRecNames(1,1) = ATPL & WC & IEX & "Internet Control Panel|Security Page|Locked-Down Trusted Sites Zone|"

arRecNames(1,2) = "Initialize and script ActiveX controls not marked as safe}"

 

GPRecognizer HKCU, strKey : GPRecognizer HKLM, strKey : ReDimGPOArrays

 

 

strKey = "Software\Policies\Microsoft\Windows\CurrentVersion\Internet Settings\Lockdown_Zones\3"

 

ReDim arRecNames(1,2)

 

arRecNames(0,0) = "1004" 'HKLM

arRecNames(0,1) = ATPL & WC & IEX & "Internet Control Panel|Security Page|Locked-Down Internet Zone|"

arRecNames(0,2) = "Download unsigned ActiveX controls}"

 

arRecNames(1,0) = "1201" 'HKLM

arRecNames(1,1) = ATPL & WC & IEX & "Internet Control Panel|Security Page|Locked-Down Internet Zone|"

arRecNames(1,2) = "Initialize and script ActiveX controls not marked as safe}"

 

GPRecognizer HKCU, strKey : GPRecognizer HKLM, strKey : ReDimGPOArrays

 

 

strKey = "Software\Policies\Microsoft\Windows\CurrentVersion\Internet Settings\Lockdown_Zones\4"

 

ReDim arRecNames(1,2)

 

arRecNames(0,0) = "1004" 'HKLM

arRecNames(0,1) = ATPL & WC & IEX & "Internet Control Panel|Security Page|Locked-Down Restricted Sites Zone|"

arRecNames(0,2) = "Download unsigned ActiveX controls}"

 

arRecNames(1,0) = "1201" 'HKLM

arRecNames(1,1) = ATPL & WC & IEX & "Internet Control Panel|Security Page|Locked-Down Restricted Sites Zone|"

arRecNames(1,2) = "Initialize and script ActiveX controls not marked as safe}"

 

GPRecognizer HKCU, strKey : GPRecognizer HKLM, strKey : ReDimGPOArrays

 

 

strKey = "Software\Policies\Microsoft\Windows\CurrentVersion\Internet Settings\Zones\2"

 

ReDim arRecNames(1,2)

 

arRecNames(0,0) = "1004" 'HKLM

arRecNames(0,1) = ATPL & WC & IEX & "Internet Control Panel|Security Page|Trusted Sites Zone|"

arRecNames(0,2) = "Download unsigned ActiveX controls}"

 

arRecNames(1,0) = "1201" 'HKLM

arRecNames(1,1) = ATPL & WC & IEX & "Internet Control Panel|Security Page|Trusted Sites Zone|"

arRecNames(1,2) = "Initialize and script ActiveX controls not marked as safe}"

 

GPRecognizer HKCU, strKey : GPRecognizer HKLM, strKey : ReDimGPOArrays

 

 

strKey = "Software\Policies\Microsoft\Windows\CurrentVersion\Internet Settings\Zones\3"

 

ReDim arRecNames(1,2)

 

arRecNames(0,0) = "1004" 'HKLM

arRecNames(0,1) = ATPL & WC & IEX & "Internet Control Panel|Security Page|Internet Zone|"

arRecNames(0,2) = "Download unsigned ActiveX controls}"

 

arRecNames(1,0) = "1201" 'HKLM

arRecNames(1,1) = ATPL & WC & IEX & "Internet Control Panel|Security Page|Internet Zone|"

arRecNames(1,2) = "Initialize and script ActiveX controls not marked as safe}"

 

GPRecognizer HKCU, strKey : GPRecognizer HKLM, strKey : ReDimGPOArrays

 

 

strKey = "Software\Policies\Microsoft\Windows\CurrentVersion\Internet Settings\Zones\4"

 

ReDim arRecNames(1,2)

 

arRecNames(0,0) = "1004" 'HKLM

arRecNames(0,1) = ATPL & WC & IEX & "Internet Control Panel|Security Page|Restricted Sites Zone|"

arRecNames(0,2) = "Download unsigned ActiveX controls}"

 

arRecNames(1,0) = "1201" 'HKLM

arRecNames(1,1) = ATPL & WC & IEX & "Internet Control Panel|Security Page|Restricted Sites Zone|"

arRecNames(1,2) = "Initialize and script ActiveX controls not marked as safe}"

 

GPRecognizer HKCU, strKey : GPRecognizer HKLM, strKey : ReDimGPOArrays

 

 

strKey = "Software\Policies\Microsoft\Windows\Network Connections"

 

ReDim arRecNames(5,2)

 

arRecNames(0,0) = "NC_LanProperties"

arRecNames(0,1) = ATPL & NWK & "Network and Dial-up Connections|"

If strOS = "WVA" Then arRecNames(0,1) = ATPL & NWK & "Network Connections|"

arRecNames(0,2) = "Prohibit access to properties of a LAN connection}"

 

arRecNames(1,0) = "NC_LanChangeProperties"

arRecNames(1,1) = ATPL & NWK & "Network and Dial-up Connections|"

If strOS = "WVA" Then arRecNames(1,1) = ATPL & NWK & "Network Connections|"

arRecNames(1,2) = "Prohibit access to properties of components of a LAN connection}"

 

arRecNames(2,0) = "NC_RasChangeProperties"

arRecNames(2,1) = ATPL & NWK & "Network and Dial-up Connections|"

If strOS = "WVA" Then arRecNames(2,1) = ATPL & NWK & "Network Connections|"

arRecNames(2,2) = "Prohibit access to properties of components of a remote access connection}"

 

arRecNames(3,0) = "NC_AddRemoveComponents"

arRecNames(3,1) = ATPL & NWK & "Network and Dial-up Connections|"

If strOS = "WVA" Then arRecNames(3,1) = ATPL & NWK & "Network Connections|"

arRecNames(3,2) = "Prohibit adding and removing components for a LAN or remote access connection}"

 

arRecNames(4,0) = "NC_DeleteConnection"

arRecNames(4,1) = ATPL & NWK & "Network and Dial-up Connections|"

If strOS = "WVA" Then arRecNames(4,1) = ATPL & NWK & "Network Connections|"

arRecNames(4,2) = "Prohibit deletion of remote access connections}"

 

arRecNames(5,0) = "NC_Statistics"

arRecNames(5,1) = ATPL & NWK & "Network and Dial-up Connections|"

If strOS = "WVA" Then arRecNames(5,1) = ATPL & NWK & "Network Connections|"

arRecNames(5,2) = "Prohibit viewing of status for an active connection}"

 

GPRecognizer HKCU, strKey : ReDimGPOArrays

 

 

strKey = "Software\Policies\Microsoft\Windows\System"

 

ReDim arRecNames(0,2)

 

arRecNames(0,0) = "DisableCMD"

arRecNames(0,1) = ATPL & SYS

arRecNames(0,2) = "Disable the command prompt}"

If strOS = "WVA" Then arRecNames(0,2) = "Prevent access to the command prompt}"

 

GPRecognizer HKCU, strKey : ReDimGPOArrays

 

 

strKey = "Software\Policies\Microsoft\Windows\Task Scheduler5.0"

 

ReDim arRecNames(0,2)

 

arRecNames(0,0) = "Task Deletion" 'HKLM

arRecNames(0,1) = ATPL & WC & "Task Scheduler|"

arRecNames(0,2) = "Prohibit Task deletion}"

 

GPRecognizer HKCU, strKey : GPRecognizer HKLM, strKey : ReDimGPOArrays

 

 

strKey = "Software\Microsoft\Windows\CurrentVersion\Policies\System"

 

ReDim arAllowedNames(15,3)

 

arAllowedNames(0,0) = "ConsentPromptBehaviorAdmin" : arAllowedNames(0,1) = WSSSLP & "Security Options|"

arAllowedNames(0,2) = "User Account Control: Behavior Of The Elevation " &_

"Prompt For Administrators In Admin Approval Mode}" : arAllowedNames(0,3) = "2"

 

arAllowedNames(1,0) = "ConsentPromptBehaviorUser" : arAllowedNames(1,1) = WSSSLP & "Security Options|"

arAllowedNames(1,2) = "User Account Control: Behavior Of The Elevation " &_

"Prompt For Standard Users}" : arAllowedNames(1,3) = "1"

 

arAllowedNames(2,0) = "dontdisplaylastusername" : arAllowedNames(2,1) = WSSSLP & "Security Options|"

arAllowedNames(2,2) = "Interactive logon: Do not display last user name}" : arAllowedNames(2,3) = "***"

 

arAllowedNames(3,0) = "EnableInstallerDetection" : arAllowedNames(3,1) = WSSSLP & "Security Options|"

arAllowedNames(3,2) = "User Account Control: Detect Application " &_

"Installations And Prompt For Elevation}" : arAllowedNames(3,3) = "1"

 

arAllowedNames(4,0) = "EnableLUA" : arAllowedNames(4,1) = WSSSLP & "Security Options|"

arAllowedNames(4,2) = "User Account Control: Run All Administrators " &_

"In Admin Approval Mode}" : arAllowedNames(4,3) = "1"

 

arAllowedNames(5,0) = "EnableSecureUIAPaths" : arAllowedNames(5,1) = WSSSLP & "Security Options|"

arAllowedNames(5,2) = "User Account Control: Only elevate UIAccess " &_

"applications that are installed in secure locations}" : arAllowedNames(5,3) = "1"

 

arAllowedNames(6,0) = "EnableVirtualization" : arAllowedNames(6,1) = WSSSLP & "Security Options|"

arAllowedNames(6,2) = "User Account Control: Virtualize file and registry " &_

"write failures to per-user locations}" : arAllowedNames(6,3) = "1"

 

arAllowedNames(7,0) = "FilterAdministratorToken" : arAllowedNames(7,1) = WSSSLP & "Security Options|"

arAllowedNames(7,2) = "User Account Control: Admin Approval Mode for " &_

"the Built-in Administrator Account}" : arAllowedNames(7,3) = "1"

 

arAllowedNames(8,0) = "legalnoticecaption" : arAllowedNames(8,1) = WSSSLP & "Security Options|"

arAllowedNames(8,2) = "Interactive logon: Message title for users " &_

"attempting to log on}" : arAllowedNames(8,3) = "***"

 

arAllowedNames(9,0) = "legalnoticetext" : arAllowedNames(9,1) = WSSSLP & "Security Options|"

arAllowedNames(9,2) = "Interactive logon: Message text for users " &_

"attempting to log on}" : arAllowedNames(9,3) = "***"

 

arAllowedNames(10,0) = "PromptOnSecureDesktop" : arAllowedNames(10,1) = WSSSLP & "Security Options|"

arAllowedNames(10,2) = "User Account Control: Switch to the secure " & _

"desktop when prompting for elevation}" : arAllowedNames(10,3) = "1"

 

arAllowedNames(11,0) = "scforceoption" : arAllowedNames(11,1) = WSSSLP & "Security Options|"

arAllowedNames(11,2) = "Interactive logon: Require smart card}" : arAllowedNames(11,3) = "***"

 

arAllowedNames(12,0) = "shutdownwithoutlogon" : arAllowedNames(12,1) = WSSSLP & "Security Options|"

arAllowedNames(12,2) = "Shutdown: Allow system to be shut down without " &_

"having to log on}" : arAllowedNames(12,3) = "1"

 

arAllowedNames(13,0) = "undockwithoutlogon" : arAllowedNames(13,1) = WSSSLP & "Security Options|"

arAllowedNames(13,2) = "Devices: Allow undock without having to log on}" : arAllowedNames(13,3) = "1"

 

arAllowedNames(14,0) = "ValidateAdminCodeSignatures" : arAllowedNames(14,1) = WSSSLP & "Security Options|"

arAllowedNames(14,2) = "User Account Control: Only elevate executables " &_

"that are signed and validated}" : arAllowedNames(14,3) = "***"

 

GPRecognizer HKLM, strKey : ReDimGPOArrays

 

 

'has no effect in WMe

If strOS = "WXP" Or strOS = "WVA" Then

 

strKey = "Software\Policies\Microsoft\Windows NT\SystemRestore"

 

ReDim arRecNames(1,2)

 

arRecNames(0,0) = "DisableSR" : arRecNames(0,1) = ATPL & SYS & "System Restore|"

arRecNames(0,2) = "Turn off System Restore}"

 

arRecNames(1,0) = "DisableConfig" : arRecNames(1,1) = ATPL & SYS & "System Restore|"

arRecNames(1,2) = "Turn off Configuration}"

 

GPRecognizer HKLM, strKey : ReDimGPOArrays

 

End If 'WXP/WVa?

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

End If 'SecTest?

[MAcgYvER everyONE 0]

'#15. Enabled Wallpaper & Screen Saver

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

Dim arBValue()

 

'title line string

strTitle = "Active Desktop and Wallpaper:"

 

 

'Active Desktop

 

'Active Desktop flag key

strKey = "Software\Microsoft\Windows\CurrentVersion\Explorer"

 

'get the ShellState binary array

intErrNum = oReg.GetBinaryValue (HKCU,strKey,"ShellState",arBValue)

 

'if array returned

If intErrNum = 0 And IsArray(arBValue) Then

 

'if array contains Active Desktop flag

If UBound(arBValue) >= 4 Then

 

'if 0-based 4th array element contains 64 (AD flag set)

If (arBValue(4) And 64) = 64 Then

ReDim arBValue(0) 'recover array memory

TitleLineWrite

oFN.WriteLine vbCRLF & "Active Desktop may be enabled at this entry:" &_

vbCRLF & "HKCU\" & strKey & "\ShellState"

Else

TitleLineWrite

oFN.WriteLine vbCRLF & "Active Desktop may be disabled at this entry:" &_

vbCRLF & "HKCU\" & strKey & "\ShellState"

End If 'AD enabled?

 

End If 'UBound>=4?

 

Else 'binary value not found

 

If flagShowAll Then

TitleLineWrite : oFN.WriteLine vbCRLF & "Active Desktop is not enabled."

End If

 

End If 'binary value exists?

 

 

'Wallpaper

 

'check for AD wallpaper

strKey = "Software\Microsoft\Internet Explorer\Desktop\General"

strSubTitle = "Displayed if Active Desktop enabled and wallpaper not set by " &_

strPolName & "Policy:" & vbCRLF & "HKCU\" & strKey & "\"

 

intErrNum = oReg.GetStringValue (HKCU,strKey,"Wallpaper",strValue)

 

'if AD wallpaper value set

If intErrNum = 0 And strValue <> "" Then 'exc for W2K!

 

'write value

On Error Resume Next

TitleLineWrite

oFN.WriteLine DQ & "Wallpaper" & DQ & " = " &_

DQ & strValue & DQ

intErrNum1 = Err.Number : Err.Clear

On Error Goto 0

If intErrNum1 <> 0 Then oFN.WriteLine DQ & "Wallpaper" &_

DQ & " = (value not set)"

 

End If 'AD wallpaper value set?

 

 

'retrieve Wallpaper value

strKey = "Control Panel\Desktop"

strSubTitle = "Displayed if Active Desktop disabled and wallpaper not set by " &_

strPolName & "Policy:" & vbCRLF & "HKCU\" & strKey & "\"

 

intErrNum = oReg.GetStringValue (HKCU,strKey,"Wallpaper",strValue)

 

'if value set (exc for W2K!)

If intErrNum = 0 And strValue <> "" Then 'exc for W2K!

 

TitleLineWrite

'output wallpaper value

On Error Resume Next

oFN.WriteLine DQ & "Wallpaper" & DQ & " = " &_

DQ & strValue & DQ

intErrNum2 = Err.Number : Err.Clear

On Error Goto 0

If intErrNum2 <> 0 Then oFN.WriteLine DQ & "Wallpaper" &_

DQ & " = (value not set)"

 

Else 'WP value not present

 

If flagShowAll Then

TitleLineWrite

oFN.WriteLine DQ & "Wallpaper" & DQ & " = (value not set)"

End If

 

End If 'wallpaper value set?

 

 

'web content

 

'look for web content

strKey = "Software\Microsoft\Internet Explorer\Desktop\Components"

intErrNum = oReg.EnumKey(HKCU,strKey,arKeys)

 

'if sub-keys exist

If IsArray(arKeys) Then

 

strSubTitle = "Active Desktop web content (hidden if disabled):"

 

'for each subkey

For Each oKey in arKeys

 

strSubSubTitle = "HKCU\" & strKey & "\" & oKey & "\"

 

'retrieve DWORD containing web content activation flag

intErrNum1 = oReg.GetDWORDValue (HKCU,strKey & "\" & oKey,"Flags",intValue)

 

'if DWORD value set

If intErrNum = 0 And intValue <> 0 Then

 

'if DWORD contains 8192 (web content activation flag set)

If (intValue And 8192) = 8192 Then

 

'get web content descriptive values

oReg.GetStringValue HKCU,strKey & "\" & oKey,"FriendlyName",strValue1

oReg.GetStringValue HKCU,strKey & "\" & oKey,"Source",strValue2

oReg.GetStringValue HKCU,strKey & "\" & oKey,"SubscribedURL",strValue3

 

TitleLineWrite

 

'write web content descriptive values

On Error Resume Next

oFN.WriteLine DQ & "FriendlyName" & DQ & " = " &_

DQ & strValue1 & DQ

intErrNum2 = Err.Number : Err.Clear

If intErrNum2 <> 0 Then oFN.WriteLine DQ & "FriendlyName" &_

DQ & " = (value not set)"

 

oFN.WriteLine DQ & "Source" & DQ & " = " &_

DQ & strValue2 & DQ

intErrNum2 = Err.Number : Err.Clear

If intErrNum2 <> 0 Then oFN.WriteLine DQ & "Source" &_

DQ & " = (value not set)"

 

oFN.WriteLine DQ & "SubscribedURL" & DQ & " = " &_

DQ & strValue3 & DQ

intErrNum2 = Err.Number : Err.Clear

If intErrNum2 <> 0 Then oFN.WriteLine DQ & "SubscribedURL" &_

DQ & " = (value not set)"

On Error Goto 0

 

End If 'web content active?

 

End If 'web content DWORD value set?

 

Next 'web content subkey

 

End If 'web content subkeys exist

 

strSubTitle = "" : strSubSubTitle = ""

 

 

'Screen Saver

 

If strOS <> "W98" And strOS <> "WME" Then

 

Dim strLFN : strLFN = "" 'screen saver LFN

Dim strExt : strExt = "" 'wallpaper file extension

strWarn = ""

 

strTitle = "Enabled Screen Saver:"

 

strKey = "Control Panel\Desktop"

strSubTitle = "HKCU\" & strKey & "\"

 

'get the screen saver name

intErrNum = oReg.GetStringValue (HKCU,strKey,"Scrnsave.exe",strValue)

 

'if Scrnsave.exe value exists And value set (exc for W2K!)

' And value <> "(NONE)" (NT4 default)

If intErrNum = 0 And strValue <> "" And LCase(strValue) <> "(none)" Then

 

'get screen saver LFN if file exists

If Fso.FileExists(strValue) Then

 

'create (but don't save) shortcut

Dim oSC : Set oSC = Wshso.CreateShortcut("getLFN.lnk")

'set & retrieve target path

oSC.TargetPath = strValue

strLFN = Fso.GetFile(oSC.TargetPath).Name

Set oSC=Nothing

 

'set up LFN string if SFN <> LFN

If LCase(strLFN) = LCase(Fso.GetFileName(strValue)) Then

strLFN = ""

Else

strLFN = " (" & strLFN & ")"

End If

 

End If 'screen saver file exists?

 

TitleLineWrite

 

On Error Resume Next

oFN.WriteLine DQ & "SCRNSAVE.EXE" & DQ & " = " &_

DQ & strValue & DQ & strLFN & CoName(IDExe(strValue))

intErrNum = Err.Number : Err.Clear

On Error Goto 0

 

If intErrNum <> 0 Then oFN.WriteLine DQ & "SCRNSAVE.EXE" &_

DQ & " = (value not set)"

 

Else 'Scrnsave.exe value doesn't exist

 

'if ShowAll, output title line

If flagShowAll Then

 

TitleLineWrite

oFN.WriteLine DQ & "SCRNSAVE.EXE" & DQ & " = (value not set)"

 

End If 'flagShowAll

 

End If 'Scrnsave.exe value exists?

 

End If 'strOS <> W98/WME?

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

End If 'SecTest?

 

 

 

 

'#16. WIN.INI load/run, SYSTEM.INI shell/scrnsave.exe, WINSTART.BAT, IniFileMapping

' W98/WMe - check inside WIN.INI (load=, run=), SYSTEM.INI (shell=, scrnsave.exe=)

' W98 - list contents of non-empty WINSTART.BAT

' NT4+ - check for non-default IniFileMapping values

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

If strOS = "W98" Or strOS = "WME" Then

 

strTitle = "WIN.INI & SYSTEM.INI launch points:"

 

Dim oSCF 'System Configuration File

'true if in INI-file section containing targeted lines

Dim flagSection : flagSection = False

 

strSubTitle = "WIN.INI" & vbCRLF & "[windows]"

 

'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 not a blank/comment line And inside [windows] section

If Trim(strLine) <> "" And Left(LTrim(strLine),1) <> ";" Then

 

If flagSection Then

 

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

 

'input line, verb, expected contents, disk

IniInfParse strLine, "load", "", ""

IniInfParse strLine, "run", "", ""

 

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

 

End If 'blank/comment line?

 

Loop 'next line of WIN.INI

 

oSCF.Close 'close WIN.INI

flagSection = False

 

strSubTitle = "SYSTEM.INI" & vbCRLF & "[boot]"

 

'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 not a blank/comment line And inside [windows] section

If Trim(strLine) <> "" And Left(LTrim(strLine),1) <> ";" Then

 

'if inside [boot] section

If flagSection Then

 

If Left(LTrim(strLine),1) = "[" Then

'toggle flagSection and exit

flagSection = False : Exit Do

End If 'shell line?

 

IniInfParse strLine, "shell", "explorer.exe", ""

IniInfParse strLine, "scrnsave.exe", "anything", ""

 

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

 

End If 'blank/comment line?

 

Loop

 

oSCF.Close

 

strSubTitle = ""

 

'for W98 only

If strOS = "W98" Then

 

strTitle = "WINSTART.BAT contents:"

 

'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 strTitle <> "" Then

TitleLineWrite : oFN.WriteBlankLines(1)

End If

oFN.WriteLine strLine

End If

 

Else 'len 1-2

 

TitleLineWrite : oFN.WriteLine strLine

 

End If 'len < 3?

 

End If 'carriage return?

 

Loop 'WINSTART.BAT lines

 

oSCF.Close : Set oSCF=Nothing

 

Else 'WINSTART.BAT doesn't exist

 

'if ShowAll, write title lines

If flagShowAll Then

TitleLineWrite : oFN.WriteLine vbCRLF & "(file not found)"

End If

 

End If 'WINSTART.BAT exists?

 

End If 'W98?

 

Else 'NT4+

 

strTitle = "IniFileMapping Pointers to .INI Files:"

strSubTitle = "HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\IniFileMapping\"

 

'Allowed INI-File Sections & Registry Locations

Dim dictAIFSRL : Set dictAIFSRL = CreateObject("Scripting.Dictionary")

 

strSubSubTitle = "ImageFileExecutionOptions.ini\"

strKey = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\IniFileMapping\ImageFileExecutionOptions.ini"

strValue = "SYS:Microsoft\Windows NT\CurrentVersion\Image File Execution Options"

 

ChkDefaultValue strKey, strValue 'compare default value to strValue

 

strSubSubTitle = "System.ini\"

strKey = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\IniFileMapping\system.ini"

 

If strOS = "WVA" Then 'Vista exception

dictAIFSRL.Add "drivers","SYS:Microsoft\Windows NT\CurrentVersion\Drivers"

Else

dictAIFSRL.Add "drivers","#SYS:Microsoft\Windows NT\CurrentVersion\drivers"

End If

dictAIFSRL.Add "drivers32","SYS:Microsoft\Windows NT\CurrentVersion\Drivers32"

dictAIFSRL.Add "NonWindowsApp","SYS:Microsoft\Windows NT\CurrentVersion\WOW\NonWindowsApp"

dictAIFSRL.Add "standard","SYS:Microsoft\Windows NT\CurrentVersion\WOW\standard"

 

ChkNameValues strKey, dictAIFSRL, False 'compare name/value pairs to allowed

 

dictAIFSRL.RemoveAll

 

strSubSubTitle = "system.ini\boot\"

strKey = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\IniFileMapping\system.ini\boot"

strValue = "SYS:Microsoft\Windows NT\CurrentVersion\WOW\boot"

 

ChkDefaultValue strKey, strValue 'compare default value to strValue

 

dictAIFSRL.Add "SCRNSAVE.EXE","USR:Control Panel\Desktop"

dictAIFSRL.Add "Shell","SYS:Microsoft\Windows NT\CurrentVersion\Winlogon"

 

ChkNameValues strKey, dictAIFSRL, True 'compare name/value pairs to allowed

'resolve unallowed value

 

dictAIFSRL.RemoveAll

 

strSubSubTitle = "win.ini\"

strKey = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\IniFileMapping\win.ini"

 

dictAIFSRL.Add "AeDebug","SYS:Microsoft\Windows NT\CurrentVersion\AeDebug"

dictAIFSRL.Add "Devices","USR:Software\Microsoft\Windows NT\CurrentVersion\Devices"

dictAIFSRL.Add "Winlogon","SYS:Microsoft\Windows NT\CurrentVersion\Winlogon"

 

ChkNameValues strKey, dictAIFSRL, False 'compare name/value pairs to allowed

 

dictAIFSRL.RemoveAll

 

strSubSubTitle = "win.ini\Windows\"

strKey = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\IniFileMapping\win.ini\Windows"

strValue = "USR:Software\Microsoft\Windows NT\CurrentVersion\Windows"

 

ChkDefaultValue strKey, strValue 'compare default value to strValue

 

If strOS = "WVA" Then 'Vista typo

dictAIFSRL.Add "AppInit_DLLs","SYS:MICROSOFT\\WINDOWS NT\\CURRENTVERSION\\WINDOWS"

Else

dictAIFSRL.Add "AppInit_DLLs","SYS:Microsoft\Windows NT\CurrentVersion\Windows"

End If

 

ChkNameValues strKey, dictAIFSRL, True 'compare name/value pairs to allowed

'resolve unallowed value

 

dictAIFSRL.RemoveAll

 

End If 'strOS = W98/WME

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

strWarn = "" : strOut = ""

 

End If 'SecTest?

 

 

 

 

'#17. AUTORUN.INF in root directory of local fixed disks

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

'WMe & WXP SP2 do not launch AUTORUN.INF on local fixed disks

If strOS <> "WME" And strOSLong <> "Windows XP SP2" Then

 

'fixed disk, DWORD value, binary value array, AutoRun.Inf file,

Dim oDisk, hVal, arBVal, oARI

 

strTitle = "Autostart via AUTORUN.INF on local fixed drives:"

 

'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:"

 

'assume HKLM NoDriveTypeAutoRun Fixed Disks Enabled

Public flagHKLM_NDTAR_FDE : flagHKLM_NDTAR_FDE = True

'assume HKCU NoDriveTypeAutoRun Fixed Disks Enabled

Public flagHKCU_NDTAR_FDE : flagHKCU_NDTAR_FDE = True

 

'assume HKLM NoDriveTypeAutoRun value does NOT exist

Public flagHKLM_NDTAR : flagHKLM_NDTAR = False

'assume HKCU NoDriveTypeAutoRun value does NOT exist (unused, passed for consistency)

Public flagHKCU_NDTAR : flagHKCU_NDTAR = False

 

'assume HKLM NoDriveAutoRun value does NOT exist

Public flagHKLM_NDAR : flagHKLM_NDAR = False

'assume HKCU NoDriveAutoRun value does NOT exist (unused, passed for consistency)

Public flagHKCU_NDAR : flagHKCU_NDAR = False

 

strKey = "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer"

 

'WVa RC1 ignores NDTAR/NDAR values in HKCU/HKLM

If strOS <> "WVA" Then

 

'check NDTAR/NDTAR_FDE values in HKLM, toggle flag if needed

NDTAR HKLM, flagHKLM_NDTAR, flagHKLM_NDTAR_FDE

'if HKLM NDTAR value not found, check NDTAR/NDTAR_FDE values in HKCU

If Not flagHKLM_NDTAR Then NDTAR HKCU, flagHKCU_NDTAR, flagHKCU_NDTAR_FDE

 

Else 'strOS = "WVA"

 

flagHKLM_NDTAR = True : flagHKCU_NDTAR = True

flagHKLM_NDTAR_FDE = True : flagHKCU_NDTAR_FDE = True

 

End If

 

'if NoDriveTypeAutoRun permits autorun on fixed disks, look at

'individual disks

If flagHKLM_NDTAR_FDE And flagHKCU_NDTAR_FDE Then

 

'enumerate fixed disks

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

 

'WVa RC1 ignores NDAR values

If strOS <> "WVA" Then

NDAR HKLM, flagHKLM_NDAR

Else

flagHKLM_NDAR = True : flagHKCU_NDAR = True

End if

 

If Not flagHKLM_NDAR Then NDAR HKCU, flagHKCU_NDAR

 

'for every fixed disk

For i = 0 To UBound(arFixedDisks,2)

 

strSubTitle = arFixedDisks(0,i) & "\"

 

'if autorun enabled

If arFixedDisks(2,i) Then

 

'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", "", arFixedDisks(0,i)

IniInfParse strLine, "shellexecute", "", arFixedDisks(0,i)

 

Loop 'next AUTORUN.INF line

 

oARI.Close : Set oARI=Nothing 'close AUTORUN.INF

 

'if no verbs found And ShowAll

If strSubTitle <> "" And flagShowAll Then

 

TitleLineWrite

 

oFN.WriteLine "AUTORUN.INF -> (" & DQ & "open" & DQ &_

" & " & DQ & "shellexecute" & DQ & " lines not found)"

 

End If 'ShowAll?

 

Else 'AUTORUN.INF not found in root

 

'if ShowAll

If flagShowAll Then

 

TitleLineWrite

 

'output file not found message

oFN.WriteLine "AUTORUN.INF -> (file not found)"

 

End If 'ShowAll?

 

End If 'AUTORUN.INF exists in root?

 

End If 'autorun enabled on drive?

 

Next 'fixed disk

 

End If 'NoDriveTypeAutoRun enables autorun on fixed disks?

 

dictDL.RemoveAll : Set dictDL=Nothing

 

End If 'strOS <> WME/WXP SP2?

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

End If 'SecTest?

 

 

 

 

'#18. HKLM... Explorer\AutoplayHandlers\Handlers

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

' And OS = WXP or WVA

If (Not flagTest Or (flagTest And SecTest)) And (strOS = "WXP" Or strOS = "WVA") Then

 

'InvokeProgID, InvokeVerb, Command/DropTarget subverbs, found subverbs,

'path from HKLM\SOFTWARE\Classes to shell\verb

Dim strHandlerSubKey, strProgID, strVerb, arSubVerbs, strSubVerb, strClass2Verb, strHive, strCLSIDVerb, flagSUBAllow

Dim strCLSIDSubKey 'path to one of four CLSID verbs

 

Dim strCLSIDVerbValue

 

Dim strProvider 'Provider value

'2 row x 3 col array, col 0: subverb; col 1: value; col 2: found?

Dim arAllowedSubVerbs (1,2)

arAllowedSubVerbs(0,0) = "Command"

arAllowedSubVerbs(0,1) = ""

arAllowedSubVerbs(1,0) = "DropTarget"

arAllowedSubVerbs(1,1) = "CLSID"

'four possible CLSID verbs

Dim arCLSIDVerbs : arCLSIDVerbs = Array("InProcServer32","LocalServer32","ProgID","VersionIndependentProgID")

'are Provider/InitCmdLine/CLSID/InvokeProgID executables default?

Dim flagAllowProvider, flagAllowICL, flagAllowCLSIDServer, flagAllowInvokeProgID

 

'mix of Provider, ICL, CLSID Server values that cover all executables referred by Handler names

Dim arAllowedHandlerGrammar()

ReDim arAllowedHandlerGrammar(65)

 

'WXP Home

arAllowedHandlerGrammar(0) = "@%SystemRoot%\system32\SHELL32.dll,-17170"

arAllowedHandlerGrammar(1) = strWinDir & "\Explorer.exe /idlist,%I,%L"

arAllowedHandlerGrammar(2) = "@%SystemRoot%\system32\SHELL32.dll,-17155"

arAllowedHandlerGrammar(3) = DQ & strPgmFilesDir & "\Windows Media Player\wmplayer.exe" &_

DQ & " /prefetch:3 /device:AudioCD " & DQ & "%L" & DQ

arAllowedHandlerGrammar(4) = DQ & strPgmFilesDir & "\Windows Media Player\wmplayer.exe" &_

DQ & " /prefetch:4 /device:DVD " & DQ & "%L" & DQ

arAllowedHandlerGrammar(5) = strWinDir & "\system32\wmpshell.dll"

arAllowedHandlerGrammar(6) = "@%SystemRoot%\system32\SHELL32.dll,-17159"

arAllowedHandlerGrammar(7) = "rundll32.exe " & strWinDir & "\system32\shimgvw.dll," &_

"ImageView_Fullscreen %1"

arAllowedHandlerGrammar(8) = strWinDir & "\System32\photowiz.dll"

arAllowedHandlerGrammar(9) = "Windows Explorer"

arAllowedHandlerGrammar(10) = "PromptEachTime"

arAllowedHandlerGrammar(11) = "rundll32.exe shell32.dll,SHCreateLocalServerRunDll " &_

"{995C996E-D918-4a8c-A302-45719A6F4EA7}"

arAllowedHandlerGrammar(12) = "PromptEachTimeNoContent"

arAllowedHandlerGrammar(13) = DQ & strPgmFilesDir & "\Windows Media Player\wmplayer.exe" &_

DQ & " /prefetch:3 /RipAudioCD " & DQ & "%L" & DQ

arAllowedHandlerGrammar(14) = "@%SystemRoot%\system32\SHELL32.dll,-17157"

arAllowedHandlerGrammar(15) = "rundll32.exe " & strWinDir & "\system32\shimgvw.dll," &_

"ImageView_COMServer {00E7B358-F65B-4dcf-83DF-CD026B94BFD4}"

arAllowedHandlerGrammar(16) = "@" & strPgmFilesDir & "\Movie Maker\wmmres.dll,-61424"

arAllowedHandlerGrammar(17) = DQ & strPgmFilesDir & "\Movie Maker\moviemk.exe" & DQ & " /RECORD"

arAllowedHandlerGrammar(18) = "rundll32.exe shell32.dll,SHCreateLocalServerRunDll " &_

"{FFB8655F-81B9-4fce-B89C-9A6BA76D13E7}"

arAllowedHandlerGrammar(19) = strWinDir & "\System32\wiadefui.dll"

arAllowedHandlerGrammar(20) = DQ & strPgmFilesDir & "\Windows Media Player\wmplayer.exe" &_

DQ & " /prefetch:3 /task:PortableDevice"

arAllowedHandlerGrammar(21) = "@" & strPgmFilesDir & "\Movie Maker\wmmres.dll,-61424"

arAllowedHandlerGrammar(22) = "@wmploc.dll,-6502"

arAllowedHandlerGrammar(23) = DQ & strPgmFilesDir & "\Windows Media Player\wmplayer.exe" &_

DQ & " /prefetch:3 /Task:PortableDevice /Device:" & DQ & "%L" & DQ

 

'WVA

arAllowedHandlerGrammar(24) = "@" & strWinDir & "\eHome\ehdrop.dll,-115"

arAllowedHandlerGrammar(25) = strWinDir & "\eHome\ehdrop.dll"

arAllowedHandlerGrammar(26) = "@" & strWinDir & "\system32\shell32.dll,-17417"

arAllowedHandlerGrammar(27) = strWinDir & "\system32\shell32.dll,PrepareDiscForBurnRunDll %L"

arAllowedHandlerGrammar(28) = "@emdmgmt.dll,-200"

arAllowedHandlerGrammar(29) = "rundll32.exe emdmgmt.dll,EMDMgmtLaunchProperties %L"

arAllowedHandlerGrammar(30) = DQ & strPgmFilesDir & "\Movie Maker\dvdmaker.exe" &_

DQ & " -drive:%L" & DQ

arAllowedHandlerGrammar(31) = strWinDir & "\Explorer.exe /separate,/idlist,%I,%L"

arAllowedHandlerGrammar(32) = "@" & strPgmFilesDir & "\Windows Photo Gallery\PhotoAcq.dll,-401"

arAllowedHandlerGrammar(33) = DQ & strWinDir & "\System32\rundll32.exe" & DQ &_

" " & DQ & strPgmFilesDir & "\Windows Photo Gallery\PhotoAcq.dll" & DQ &_

",AutoplayComServerW {00f2b433-44e4-4d88-b2b0-2698a0a91dba}"

arAllowedHandlerGrammar(34) = strWinDir & "\system32\rundll32.exe " & strWinDir &_

"\system32\shell32.dll,PrepareDiscForBurnRunDll %L"

arAllowedHandlerGrammar(35) = "@" & strPgmFilesDir & "\movie maker\dvdmaker.exe,-61403"

arAllowedHandlerGrammar(36) = DQ & strPgmFilesDir & "\Movie Maker\dvdmaker.exe" &_

DQ & " -drive:%L"

arAllowedHandlerGrammar(37) = strPgmFilesDir & "\Windows Photo Gallery\PhotoAcq.dll"

arAllowedHandlerGrammar(38) = DQ & strPgmFilesDir & "\Windows Media Player\wmplayer.exe" &_

DQ & " /prefetch:4 /device:VCD " & DQ & "%L" & DQ

arAllowedHandlerGrammar(39) = "@" & strWinDir & "\system32\shell32.dll,-17411"

arAllowedHandlerGrammar(40) = strWinDir & "\System32\rundll32.exe shell32.dll," &_

"SHCreateLocalServerRunDll {995C996E-D918-4a8c-A302-45719A6F4EA7}"

arAllowedHandlerGrammar(41) = DQ & strPgmFilesDir & "\Windows Media Player\wmplayer.exe" &_

DQ & " /prefetch:3 /RipAudioCD " & DQ & "%L" & DQ

arAllowedHandlerGrammar(42) = "@%SystemRoot%\system32\audiodev.dll,-501"

arAllowedHandlerGrammar(43) = "::{21EC2020-3AEA-1069-A2DD-08002B30309D}\" &_

"::{640167b4-59b0-47a6-b335-a6b3c0695aea}"

arAllowedHandlerGrammar(44) = strWinDir & "\System32\rundll32.exe shell32.dll," &_

"SHCreateLocalServerRunDll {FFB8655F-81B9-4fce-B89C-9A6BA76D13E7}"

arAllowedHandlerGrammar(45) = "@" & strPgmFilesDir & "\Windows Photo Gallery\PhotoViewer.dll,-3067"

arAllowedHandlerGrammar(46) = DQ & strWinDir & "\System32\rundll32.exe" & DQ &_

" " & DQ & strPgmFilesDir & "\Windows Photo Gallery\PhotoViewer.dll" & DQ &_

",ImageView_COMServer {9D687A4C-1404-41ef-A089-883B6FBECDE6}"

arAllowedHandlerGrammar(47) = "@" & strPgmFilesDir & "\Movie Maker\CaptureWizard.exe,-61403"

arAllowedHandlerGrammar(48) = "CaptureWizard"

arAllowedHandlerGrammar(49) = DQ & strPgmFilesDir & "\Movie Maker\VideoCameraAutoPlayManager.exe" & DQ

arAllowedHandlerGrammar(50) = DQ & strPgmFilesDir & "\Windows Media Player\wmplayer.exe" &_

DQ & " /prefetch:3 /Task:CDWrite /Device:" & DQ & "%L" & DQ

arAllowedHandlerGrammar(51) = DQ & strPgmFilesDir & "\Windows Media Player\wmplayer.exe" &_

DQ & " /prefetch:3 /Task:DVDWrite /Device:" & DQ & "%L" & DQ

arAllowedHandlerGrammar(52) = "@%windir%\system32\migwiz\MIGUIRes.dll,-12095"

arAllowedHandlerGrammar(53) = "MigAutoPlay.exe"

arAllowedHandlerGrammar(54) = "/NetworkConfig;rundll32;xwizards.dll,RunWizard {34c219bd-85c1-4338-95e8-788a36901dc2} /z %s"

arAllowedHandlerGrammar(55) = "@" & strWinDir & "\system32\wpdshext.dll,-503"

arAllowedHandlerGrammar(56) = "@" & strWinDir & "\system32\wpdshext.dll,-501"

arAllowedHandlerGrammar(57) = strWinDir & "\system32\WPDShextAutoplay.exe"

arAllowedHandlerGrammar(58) = "/NetworkConfig;rundll32;xwizards.dll," &_

"RunWizard {34c219bd-85c1-4338-95e8-788a36901dc2} /z %s"

 

'WXP Pro

arAllowedHandlerGrammar(59) = "::{20D04FE0-3AEA-1069-A2D8-08002B30309D}\" &_

"::{21EC2020-3AEA-1069-A2DD-08002B30309D}\::{640167b4-59b0-47a6-b335-a6b3c0695aea}"

arAllowedHandlerGrammar(60) = "@" & strPgmFilesDir & "\Movie Maker\wmm2res.dll,-100"

'language-specific!

arAllowedHandlerGrammar(61) = "@" & strPgmFilesDir & "\Movie Maker\1033\wmm2res.dll,-100"

arAllowedHandlerGrammar(62) = DQ & strPgmFilesDir & "\Movie Maker\moviemk.exe" &_

DQ & " /RECORD"

arAllowedHandlerGrammar(63) = DQ & strPgmFilesDir &_

"\Windows Media Player\wmlaunch.exe" & DQ

arAllowedHandlerGrammar(64) = "@%systemroot%\System32\wiaacmgr.exe,-101"

arAllowedHandlerGrammar(65) = strWinDir & "\system32\svchost.exe"

 

strTitle = "Windows Portable Device AutoPlay Handlers"

 

strKey = "SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\AutoplayHandlers\Handlers"

strSubTitle = "HKLM\" & strKey & "\"

 

'find all the Handlers

intErrNum = oReg.EnumKey (HKLM,strKey,arKeys)

 

'if Handlers found

If intErrNum = 0 And IsArray(arKeys) Then

 

'for each Handler

For Each strHandlerSubKey In arKeys

 

flagFound = False : flagAllow = False

 

' InvokeProgID & InvokeVerb

' -------------------------

 

'Shell\verb\Command/DropValue values not found

arAllowedSubVerbs(0,2) = False : arAllowedSubVerbs(1,2) = False

 

'look for InvokeProgID & InvokeVerb

intErrNum1 = oReg.GetStringValue (HKLM,strKey & "\" & strHandlerSubKey,"InvokeProgID",strProgID)

intErrNum2 = oReg.GetStringValue (HKLM,strKey & "\" & strHandlerSubKey,"InvokeVerb",strVerb)

 

'if InvokeProgID & InvokeVerb both found

If intErrNum1 = 0 And intErrNum2 = 0 Then

 

'intialize variables & flag

strValue = "" : strCLSIDVerb = "" : strCLSIDVerbValue = "" : strCLSIDTitle = ""

strProvider = ""

 

flagAllowProvider = True 'start out with Handler Provider is default

 

'set up SubSubTitle

strSubSubTitle = strHandlerSubKey & "\" & vbCRLF &_

DQ & "InvokeProgID" & DQ & " = " & DQ & strProgID & DQ & vbCRLF &_

DQ & "InvokeVerb" & DQ & " = " & DQ & strVerb & DQ

 

'look for Provider

intErrNum5 = oReg.GetStringValue (HKLM,strKey & "\" & strHandlerSubKey,"Provider",strProvider)

 

'if Provider found

If intErrNum5 = 0 And strProvider <> "" Then

 

'modify SubSubTitle

strSubSubTitle = strHandlerSubKey & "\" & vbCRLF &_

DQ & "Provider" & DQ & " = " & DQ & strProvider & DQ & vbCRLF &_

DQ & "InvokeProgID" & DQ & " = " & DQ & strProgID & DQ & vbCRLF &_

DQ & "InvokeVerb" & DQ & " = " & DQ & strVerb & DQ

 

flagAllowProvider = False 'assume Handler Provider is not default

 

'check to see if Provider value is default

For nn = 0 To UBound(arAllowedHandlerGrammar)

 

If LCase(Trim(strProvider)) = LCase(arAllowedHandlerGrammar(nn)) Then

flagAllowProvider = True : Exit For

End If

 

Next 'arAllowedHandlerGrammar member

 

End If 'strProvider found?

 

'assemble InvokeProgID + Verb phrase

strClass2Verb = "SOFTWARE\Classes\" & strProgID & "\shell\" & strVerb

 

'look for phrase in each hive

For ii = 0 To 1

 

'look for phrase subverbs

intErrNum3 = oReg.EnumKey (arHives(ii,1),strClass2Verb,arSubVerbs)

 

'if subverbs found

If intErrNum3 = 0 And IsArray(arSubVerbs) Then

 

'for each subverb found

For Each strSubVerb In arSubVerbs

 

'intialize flags

flagAllowCLSIDServer = False 'Handler action not default

flagAllowInvokeProgID = False 'Handler action not default

flagAllow = False 'TRUE if Provider & CLSIDServer are default

 

'check if subverb either Command or DropTarget

For jj = 0 To UBound(arAllowedSubVerbs,1)

 

'since this For _must_ be traversed for all index values, an

'Exit for a subverb already found cannot be placed here

 

'if command or droptarget found

If LCase(strSubVerb) = LCase(arAllowedSubVerbs(jj,0)) Then

 

'exit if subverb already found

If arAllowedSubVerbs(jj,2) Then Exit For

 

'retrieve the Command default value or DropTarget CLSID value

intErrNum4 = oReg.GetStringValue (arHives(ii,1),strClass2Verb &_

"\" & strSubVerb,arAllowedSubVerbs(jj,1),strValue)

 

'if the value exists

If intErrNum4 = 0 And strValue <> "" Then

 

'toggle flagFound flag to avoid subsequent sections

flagFound = True

 

'if value is a CLSID

If IsCLSID(strValue) Then

 

'resolve the CLSID & set Allow flag

CLSIDPop strValue, UBound(arCLSIDVerbs), flagAllowCLSIDServer, _

strHive, strCLSIDVerb, strCLSIDVerbValue, strCLSIDTitle

 

If strCLSIDVerbValue <> "" Then

 

arAllowedSubVerbs(jj,2) = True

 

'toggle flagAllow if Provider & CLSIDServer are default

If flagAllowCLSIDServer And flagAllowProvider Then _

flagAllow = True

 

'output required if not default Or ShowAll

If Not flagAllow Or flagShowAll Then

 

TitleLineWrite

oFN.WriteLine SOCA(arHives(ii,0) & "\" & strClass2Verb) & "\" &_

strSubVerb & "\" & arAllowedSubVerbs(jj,1) & " = " &_

DQ & strValue & DQ

oFN.WriteLine " -> {" & strHive & "...CLSID} = " & strCLSIDTitle

oFN.WriteLine Space(19) & "\" & strCLSIDVerb & "\(Default) = " &_

StringFilter(strCLSIDVerbValue,True) & CoName(IDExe(strCLSIDVerbValue))

 

'toggle Command/DropTarget found flag

arAllowedSubVerbs(jj,2) = True : Exit For

 

End If 'output required?

 

End If 'strCLSIDVerbValue not empty?

 

Else 'IsCLSID = False, so this is a Command verb

 

'check to see if Command value is default

For nn = 0 To UBound(arAllowedHandlerGrammar)

 

If arAllowedSubVerbs(jj,2) = True Then Exit For

 

'if default, toggle Command/DropTarget found flag & default flag

If LCase(Trim(strValue)) = LCase(arAllowedHandlerGrammar(nn)) Then

arAllowedSubVerbs(jj,2) = True : flagAllowInvokeProgID = True : Exit For

End If

 

Next

 

'toggle flagAllow if Provider & CLSIDServer are default

If flagAllowInvokeProgID And flagAllowProvider Then _

flagAllow = True

 

'output required if not default or ShowAll

If Not flagAllow Or flagShowAll Then

 

TitleLineWrite

oFN.WriteLine SOCA(arHives(ii,0) & "\" & strClass2Verb) &_

"\" & strSubVerb & "\" & arAllowedSubVerbs(jj,1) &_

"(Default) = " & DQ & strValue & DQ & CoName(IDExe(strValue))

arAllowedSubVerbs(jj,2) = True : Exit For

 

End If 'output required?

 

End If 'IsCLSID?

 

End If 'Command\(Default)/DropTarget\CLSID value exists?

 

End If 'Command/DropTarget verb exists?

 

Next 'jj arAllowedSubVerb

 

Next 'arSubVerb

 

End If 'arSubVerbs exists?

 

Next 'ii hive

 

End If 'InvokeProgID & Invoke Verb (intErrNum1/2) both found?

 

 

 

' ProgID & Provider

' -----------------

 

'if Handler action not defined by InvokeProgID & InvokeVerb,

'try ProgID & Provider

If Not flagFound Then

 

'look for ProgID & Provider

intErrNum1 = oReg.GetStringValue (HKLM,strKey & "\" & strHandlerSubKey,"ProgID",strProgID)

intErrNum2 = oReg.GetStringValue (HKLM,strKey & "\" & strHandlerSubKey,"Provider",strProvider)

 

'if ProgID & Provider both found

If intErrNum1 = 0 And intErrNum2 = 0 Then

 

'intialize variables & flags

strValue = "" : strValue3 = "" : strCLSIDVerb = "" : strCLSIDVerbValue = ""

strCLSIDTitle = ""

 

flagAllowCLSIDServer = False 'Handler action not permitted/default

flagAllowProvider = False 'Handler Provider is not permitted/default

flagAllowICL = True 'Handler InitCmdLine is permitted/default

flagAllow = False 'Handler is not permitted/default

 

'check to see if Provider value is default

For nn = 0 To UBound(arAllowedHandlerGrammar)

 

If LCase(Trim(strProvider)) = LCase(arAllowedHandlerGrammar(nn)) Then

flagAllowProvider = True : Exit For

End If

 

Next 'arAllowedHandlerGrammar member

 

strSubSubTitle = strHandlerSubKey & "\" & vbCRLF &_

DQ & "Provider" & DQ & " = " & DQ & strProvider & DQ & vbCRLF &_

DQ & "ProgID" & DQ & " = " & DQ & strProgID & DQ

 

'assemble ProgID\CLSID key

strClass2Verb = "SOFTWARE\Classes\" & strProgID & "\CLSID"

 

'look in each hive

For ii = 0 To 1

 

'exit if CLSID server already found

If flagFound Then Exit For

 

'look for ProgID\CLSID default value

intErrNum2 = oReg.GetStringValue (arHives(ii,1),strClass2Verb,"",strValue)

 

'if ProgID\CLSID default value exists

If intErrNum2 = 0 And strValue <> "" Then

 

flagFound = True 'skip remaining sections

 

If IsCLSID(strValue) Then

 

CLSIDPop strValue, 1, flagAllowCLSIDServer, strHive, strCLSIDVerb, _

strCLSIDVerbValue, strCLSIDTitle

 

If strCLSIDVerbValue <> "" Then

 

'look for InitCmdLine value

flagAllowICL = True 'Handler InitCmdLine is (permitted) default

intErrNum6 = oReg.GetStringValue (HKLM,strKey & "\" &_

strHandlerSubKey,"InitCmdLine",strValue3)

 

'if ICL value found

If intErrNum6 = 0 And strValue3 <> "" Then

 

flagAllowICL = False 'since ICL was found, it may not be a default

 

'if ICL is default, toggle ICL flag

For nn = 0 To UBound(arAllowedHandlerGrammar)

 

If LCase(Trim(strValue3)) = LCase(arAllowedHandlerGrammar(nn)) Then

flagAllowICL = True : Exit For

End If

 

Next 'arAllowedHandlerGrammar member

 

End If 'ICL found?

 

'if three flags are all default, toggle Allow flag

If flagAllowProvider And flagAllowCLSIDServer And _

flagAllowICL Then flagAllow = True

 

'output if required

If Not flagAllow Or flagShowAll Then

 

TitleLineWrite

If intErrNum6 = 0 And strValue3 <> "" Then oFN.WriteLine DQ &_

"InitCmdLine" & DQ & " = " & DQ & strValue3 & DQ

oFN.WriteLine SOCA(arHives(ii,0) & "\" & strClass2Verb) &_

"\(Default) = " & DQ & strValue & DQ

oFN.WriteLine " -> {" & strHive & "...CLSID} = " & strCLSIDTitle

oFN.WriteLine Space(19) & "\" & strCLSIDVerb & "\(Default) = " &_

StringFilter(strCLSIDVerbValue,True) & CoName(IDExe(strCLSIDVerbValue))

 

Exit For

 

End If 'Not flagAllow?

 

End If 'strCLSIDVerbValue not empty?

 

End If 'IsCLSID?

 

End If 'CLSID exists?

 

Next 'ii hive

 

End If 'ProgID & Provider values found?

 

End If 'flagFound?

 

 

' CLSID

' -----

 

'if Handler action not defined by InvokeProgID & InvokeVerb,

'or by ProgID & Provider, try CLSID

If Not flagFound Then

 

strValue = "" 'intialize empty

 

'look for CLSID

intErrNum1 = oReg.GetStringValue (HKLM,strKey & "\" & strHandlerSubKey,"CLSID",strValue)

 

'if CLSID value found

If intErrNum1 = 0 And strValue <> "" Then

 

'intialize variables & flags

strValue3 = "" : strCLSIDVerb = "" : strCLSIDVerbValue = ""

strCLSIDTitle = "" : strProvider = ""

 

flagAllowCLSIDServer = False 'Handler CLSID Server is not permitted/default

flagAllowProvider = True 'Handler Provider is permitted/default

flagAllowICL = True 'Handler InitCmdLine is permitted/default

flagAllow = False 'Handler is not permitted/default

 

If IsCLSID(strValue) Then

 

strSubSubTitle = strHandlerSubKey & "\" & vbCRLF &_

DQ & "CLSID" & DQ & " = " & DQ & strValue & DQ

 

'look for Provider

intErrNum5 = oReg.GetStringValue (HKLM,strKey & "\" &_

strHandlerSubKey,"Provider",strProvider)

 

'if Provider found

If intErrNum5 = 0 And strProvider <> "" Then

 

'modify SubSubTitle

strSubSubTitle = strHandlerSubKey & "\" & vbCRLF &_

DQ & "Provider" & DQ & " = " & DQ & strProvider & DQ & vbCRLF &_

DQ & "CLSID" & DQ & " = " & DQ & strValue & DQ

 

flagAllowProvider = False 'Handler Provider is not default

 

'check to see if Provider value is default

For nn = 0 To UBound(arAllowedHandlerGrammar)

 

If LCase(Trim(strProvider)) = LCase(arAllowedHandlerGrammar(nn)) Then

flagAllowProvider = True : Exit For

End If

 

Next 'arAllowedHandlerGrammar member

 

End If 'strProvider found?

 

CLSIDPop strValue, 1, flagAllowCLSIDServer, strHive, strCLSIDVerb, _

strCLSIDVerbValue, strCLSIDTitle

 

If strCLSIDVerbValue <> "" Then

 

'look for InitCmdLine value

intErrNum6 = oReg.GetStringValue (HKLM,strKey & "\" &_

strHandlerSubKey,"InitCmdLine",strValue3)

 

'if ICL value found

If intErrNum6 = 0 And strValue3 <> "" Then

 

flagAllowICL = False 'since ICL was found, it may not be a default

 

'if ICL is default, toggle ICL flag

For nn = 0 To UBound(arAllowedHandlerGrammar)

 

If LCase(Trim(strValue3)) = LCase(arAllowedHandlerGrammar(nn)) Then

flagAllowICL = True : Exit For

End If

 

Next 'arAllowedHandlerGrammar member

 

End If 'ICL found?

 

'if all three flags are default, toggle Allow flag

If flagAllowProvider And flagAllowCLSIDServer And flagAllowICL Then _

flagAllow = True

 

'output if required

If Not flagAllow Or flagShowAll Then

 

TitleLineWrite

If intErrNum6 = 0 And strValue3 <> "" Then oFN.WriteLine DQ &_

"InitCmdLine" & DQ & " = " & DQ & strValue3 & DQ

oFN.WriteLine " -> {" & strHive & "...CLSID} = " & strCLSIDTitle

oFN.WriteLine Space(19) & "\" & strCLSIDVerb & "\(Default) = " &_

StringFilter(strCLSIDVerbValue,True) & CoName(IDExe(strCLSIDVerbValue))

 

End If 'output required?

 

End If 'strCLSIDVerbValue not empty?

 

End If 'CLSID?

 

End If 'CLSID value found?

 

End If 'flagFound?

 

Next 'Handler subkey

 

End If 'Handler array returned?

 

'clean up

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

flagFound = False : flagAllow = False

ReDim arAllowedHandlerGrammar(0)

 

End If 'SecTest And WXP/WVA?

 

 

 

 

'#19. DESKTOP.INI in any local fixed disk directory (section skipped by default)

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

'skip unless -supp or -all command line parameters used

If flagShowAll Or flagSupp Then

 

Dim datDTIStart : datDTIStart = Now

Public strDTITime

 

'array of allowed CLSID DLLs

Dim arOKDLLs : arOKDLLs = Array("shdocvw.dll", "occache.dll", _

"mstask.dll", "cdfview.dll", "shell32.dll", "fontext.dll", _

"mscoree.dll", "ieframe.dll")

 

strTitle = "DESKTOP.INI DLL launch in local fixed drive directories:"

 

'enumerate fixed disks

Set colDisks = GetObject("winmgmts:\root\cimv2")._

ExecQuery("SELECT * FROM Win32_LogicalDisk WHERE DriveType = 3")

 

For Each oDisk in colDisks

 

'initialize DeskTop.Ini output & error arrays & counters

ReDim arSDDTI(0) : ctrArDTI = 0

ReDim arSDErr(0) : ctrArErr = 0

 

'check for unreadable partition

On Error Resume Next

'root format: C:\

Set oRoot = Fso.GetDrive(oDisk.DeviceID).RootFolder

intErrNum = Err.Number : Err.Clear

On Error Goto 0

 

If intErrNum = 0 Then 'if partition readable

 

'find directories with System attribute containing DESKTOP.INI

'with .ShellClassInfo section and CLSID statement

'fill arSDDTI array with output & arSDErr with (permission) errors

DirSysAtt oRoot

 

'output DLL launch points if found

If ctrArDTI > 0 Then

TitleLineWrite

'output array contents

For i = 0 To UBound(arSDDTI) : oFN.WriteLine arSDDTI(i) : Next

ElseIf flagShowAll Then

TitleLineWrite : oFN.WriteLine vbCRLF & oRoot.Drive & " (no DLL launch points found)"

End If

 

'output errors if ShowAll

If ctrArErr > 0 And flagShowAll Then

 

strSubTitle = "Permission Errors on " & oRoot.Drive : TitleLineWrite : strOut = ""

 

For i = 0 To UBound(arSDErr)

 

'limit line length to 100

If strOut <> "" Then

 

If Len(strOut & arSDErr(i)) >= 100 Then

oFN.WriteLine strOut : strOut = arSDErr(i)

Else

strOut = strOut & ", " & arSDErr(i)

End If 'this error & prev errors>100?

 

Else 'strOut empty

 

If Len(arSDErr(i)) >= 100 Then

oFN.WriteLine arSDErr(i)

Else

strOut = arSDErr(i)

End If 'this error>100?

 

End If 'strOut empty?

 

Next 'arSDErr member

 

'write out final error string

If strOut <> "" Then oFN.WriteLine strOut : strOut = ""

 

End If

 

Set oRoot=Nothing

 

Else 'partition not readable (may be Linux)

 

TitleLineWrite

oFN.WriteLine vbCRLF & "WARNING! " & oDisk.DeviceID & " is an unreadable partition!"

 

End If 'partition readable?

 

Next 'disk in colDisks

 

'determine -supp seconds used

strDTITime = DateDiff("s",datDTIStart,Now) & " seconds"

 

Set colDisks=Nothing

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

'recover array memory

ReDim arSDDTI(0) : ReDim arSDErr(0)

 

End If 'flagShowAll Or flagSupp?

 

End If 'SecTest?

[MAcgYvER everyONE 0]

'#20. Startup Directories

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

'All Users StartUp Folder (AUSFP title string (empty by default)

Dim flagAUSUF : flagAUSUF = False 'true if entry for AUSF loc'n in registry

Dim flagFE : flagFE = False 'true if AUSF exists

 

'in W98/WMe, see if local-language-specific All Users startup folder location

'appears in registry and set flag 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 name exists and value not empty, toggle flag

If Not IsNull(strValue) And strValue <> "" Then flagAUSUF = True

 

End If

 

'assign startup folder short names

If strOS = "W98" Or strOS = "WME" Then

arSUFN = Array("Startup")

arSUFDN = Array("Startup")

Else

arSUFN = Array("Startup","AllUsersStartup")

arSUFDN = Array("Startup","All Users")

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 & DQ & "Startup" & DQ

 

If flagAUSUF Then

strLine = strLine & " & " & DQ & "All Users...Startup" & DQ & " folders:"

Else

strLine = strLine & " folder:"

End If

 

Else 'all other O/S's

 

strLine = strLine & DQ & Wshso.ExpandEnvironmentStrings("%USERNAME%") &_

DQ & " & " & DQ & "All Users" & DQ & " startup folders:"

arSUFDN(0) = Wshso.ExpandEnvironmentStrings("%USERNAME%")

 

End If

 

strTitle = strLine

 

'for each startup folder name

For i = 0 To 1 '0 = user folder, 1 = All Users folder

 

strSubTitle = "" : flagFE = 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)

strSubTitle = oSUF.Path : flagFE = True

Else

strSubTitle = "WARNING! " & DQ & "All Users" & DQ &_

" startup folder not found!"

TitleLineWrite

End If 'FolderExists?

End If 'flagAUSUF?

 

Else 'all other O/S's at all times

 

On Error Resume Next

Set oSUF = Fso.GetFolder(Wshso.SpecialFolders(arSUFN(i)))

intErrNum = Err.Number : Err.Clear

On Error Goto 0

 

If intErrNum = 0 Then

strSubTitle = oSUF.Path : flagFE = True

Else 'assign title for Startup folder not found

If strOS = "W98" Or strOS = "WME" Then

strSubTitle = "WARNING! " & DQ & arSUFDN(i) & DQ &_

" folder not found!"

Else

strSubTitle = "WARNING! " & DQ & arSUFDN(i) & DQ &_

" startup folder not found!"

End If

TitleLineWrite

End If 'intErrNum=0?

 

End If 'i=1 & W98/WME?

 

'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 = DQ & Fso.GetBaseName (oSUFi.Path) & DQ & " -> URL shortcut to: " &_

DQ & oSUSC.TargetPath

 

Else

 

'prepare the shortcut file base name and the target path & arguments

strLine = DQ & Fso.GetBaseName (oSUFi.Path) & DQ & " -> shortcut to: " &_

DQ & oSUSC.TargetPath

 

If oSUSC.Arguments <> "" Then

strLine = strLine & " " & oSUSC.Arguments & DQ

Else

strLine = strLine & DQ

End If

 

'add co-name

strLine = strLine & CoName(IDExe(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 = DQ & Fso.GetBaseName(oSUFi.Path) & DQ &_

" -> PIF to: " & DQ & strPIFTgt & DQ &_

CoName(IDExe(strPIFTgt))

 

'file is neither shortcut nor PIF

Else

 

'file is probably an executable so include an IWarn and

' the file name, using the full path as IDExe argument

If LCase(Fso.GetFileName(oSUFi)) <> "desktop.ini" Then

strLine = IWarn & DQ & oSUFi.Name & DQ & CoName(IDExe(oSUFi.Path))

flagIWarn = True

End If

 

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

TitleLineWrite

 

'output the line

oFN.WriteLine strLine

 

End If

 

Next 'file in startup folder

 

Set oSUF=Nothing

 

'if ShowAll

If flagShowAll Then TitleLineWrite

 

End If 'flagFE?

 

Next 'startup folder name

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = "" : strWarn = ""

 

'recover array memory

ReDim arSUFN(0)

 

End If 'SecTest?

 

 

 

 

'#21. Enabled Scheduled Tasks

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

'Enabled Scheduled Tasks Directory/Folder object

Dim strESTDir, oESTFo

 

'prepare section title lines

strTitle = "Enabled Scheduled Tasks:"

If strOS = "WVA" Then strTitle = "Non-disabled Scheduled Tasks:"

 

If strOS <> "WVA" Then

 

' Byte Disabled Enabled

'00000030: #####1## #####0## <--

 

'file in Tasks directory

Dim oFi2

 

'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

 

TitleLineWrite

 

'write error message

oFN.WriteLine vbCRLF & DQ & oFi2.Name & DQ &_

" -- insufficient permission to read this file!"

 

End If '.JOB file opened successfully?

 

End If '.JOB file extension selected?

 

Next 'file in TASKS directory

 

'if ShowAll, output title line if not already done

If flagShowAll Then TitleLineWrite

 

Else 'Tasks directory can't be found

 

'write titles and error message

TitleLineWrite

oFN.WriteLine vbCRLF & "WARNING! The " & DQ &_

strWinDir & "\Tasks" & DQ &_

" directory cannot be found."

 

End If 'Tasks directory exists?

 

Set oJobF=Nothing

 

Else 'WVa -- Non-Disabled Scheduled Tasks

 

'initialize error array & counter

ReDim arErr(0) : ctrErr = 0 : strOut = ""

 

'fill strOut with output & arErr with (permission) errors

 

strESTDir = Wshso.ExpandEnvironmentStrings("%WINDIR%\system32\Tasks")

 

Set oESTFo = Fso.GetFolder(strESTDir)

 

'initiate recursion into ST folder to find enabled XML-format tasks

DirEST oESTFo

 

'output EST's if found

If strOut <> "" Then

TitleLineWrite : oFN.WriteLine strOut

ElseIf flagShowAll Then

TitleLineWrite

oFN.WriteLine vbCRLF & "(no enabled scheduled tasks found)"

End If

 

'output directory permission errors if ShowAll

If ctrErr > 0 And flagShowAll Then

 

strSubTitle = "Directory Permission Errors:" & vbCRLF

TitleLineWrite : strOut = ""

 

For i = 0 To UBound(arErr)

 

'limit line length to 100

If strOut <> "" Then

 

If Len(strOut & arErr(i)) >= 100 Then

oFN.WriteLine strOut : strOut = arErr(i)

Else

strOut = strOut & ", " & arErr(i)

End If 'this error & prev errors>100?

 

Else 'strOut empty

 

If Len(arErr(i)) >= 100 Then

oFN.WriteLine arErr(i)

Else

strOut = arErr(i)

End If 'this error>100?

 

End If 'strOut not empty?

 

Next 'arErr member

 

'write out final error string

If strOut <> "" Then oFN.WriteLine strOut : strOut = ""

 

End If 'show errors?

 

End If 'WVa?

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

End If 'SecTest?

 

 

 

 

'#22. Winsock2 Service Provider DLLs

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

strTitle = "Winsock2 Service Provider DLLs:"

 

Dim strNSCatKey 'NameSpace Catalog Key

Dim strProCatKey 'Protocol Catalog Key

Dim strNSSP 'NameSpace Service Provider

Dim arTSP '(returned) Transport Service Provider array

Dim int1C 'single chr binary (integer) code

 

'TSP output array for numeric keys, key #, strlen of key #, work var

Dim arTSPFi(), intKN, intL, intT

'TSP output array for alpha (illegal) keys

Dim arATSPFi()

'arTSPFi is 4 x n array

ReDim arTSPFi(3,0)

ReDim arATSPFi(1,0)

'number of numbered TSP keys

Dim intNumKeys : intNumKeys = 0

intCnt = 0 'arTSPFi UBound - 1

Dim intACnt : intACnt = 0 'arATSPFi UBound - 1

strAllOutDefault = " {++}"

 

'NameSpace Providers

 

strKey = "System\CurrentControlSet\Services\Winsock2\Parameters"

 

'find name of NameSpace Catalog key

intErrNum1 = oReg.GetStringValue (HKLM,strKey,"Current_NameSpace_Catalog",strNSCatKey)

 

'if the Current_NameSpace_Catalog name exists And value set (exc for W2K!)

If intErrNum1 = 0 And strNSCatKey <> "" Then

 

strSubTitle = "Namespace Service Providers" & vbCRLF & vbCRLF &_

SYCA("HKLM\" & strKey & "\" & strNSCatKey & "\Catalog_Entries\" &_

strAllOutDefault)

 

'find NameSpace catalog entry subkeys

oReg.EnumKey HKLM,strKey & "\" & strNSCatKey & "\Catalog_Entries",arKeys

 

'if sub-keys exist

If IsArray(arKeys) Then

 

'for each subkey

For Each oKey in arKeys

 

'find LibraryPath

intErrNum2 = oReg.GetStringValue (HKLM,strKey & "\" & strNSCatKey &_

"\Catalog_Entries\" & oKey,"LibraryPath",strNSSP)

 

'if the LibraryPath name exists And value set (exc for W2K!)

If intErrNum2 = 0 And strNSSP <> "" Then

 

TitleLineWrite

 

On Error Resume Next

oFN.WriteLine oKey & "\LibraryPath" & " = " & DQ &_

strNSSP & DQ & CoName(IDExe(strNSSP))

intErrNum3 = Err.Number : Err.Clear

On Error Goto 0

If intErrNum3 <> 0 Then oFN.WriteLine oKey & "\LibraryPath" &_

" = (value not set)"

 

End If 'LibaryPath value set?

 

Next 'subkey

 

'IsArray = True, but array is empty

If strSubTitle <> "" And flagShowAll Then

TitleLineWrite : oFN.WriteLine vbCRLF & "HKLM\" & strKey &_

"\" & strNSCatKey & "\Catalog_Entries\" & " = (sub-keys not found)"

End If

 

Else 'Catalog_Entries subkeys do not exist

 

If flagShowAll Then

TitleLineWrite : oFN.WriteLine "(sub-keys not found)"

End If

 

End If 'Catalog_Entries subkeys exist?

 

Else 'Current_NameSpace_Catalog value doesn't exist Or value not set

 

If flagShowAll Then

TitleLineWrite : oFN.WriteLine vbCRLF & SYCA("HKLM\" & strKey &_

"\Current_Namespace_Catalog = (value not found)")

End If

 

End If 'Current_NameSpace_Catalog value exists?

 

 

'Transport Service Providers (Layered Service Providers = LSP's)

 

intErrNum1 = oReg.GetStringValue (HKLM,strKey,"Current_Protocol_Catalog",strProCatKey)

 

'if the Current_Protocol_Catalog name exists And value set (exc for W2K!)

If intErrNum1 = 0 And strProCatKey <> "" Then

 

strSubTitle = "Transport Service Providers" & vbCRLF & vbCRLF &_

SYCA("HKLM\" & strKey & "\" & strProCatKey & "\Catalog_Entries\" &_

strAllOutDefault)

 

'find Protocol catalog entry subkeys

oReg.EnumKey HKLM,strKey & "\" & strProCatKey & "\Catalog_Entries",arKeys

 

'if sub-keys exist

If IsArray(arKeys) Then

 

'for each subkey

For Each oKey in arKeys

 

'can only take UBound if subkeys exist

'find number of keys in array & # digits

intNumKeys = UBound(arKeys) + 1

 

'determine # digits

intL = Len(CStr(intNumKeys))

 

'convert key name to integer

On Error Resume Next

intKN = CInt(oKey)

intErrNum = Err.Number : Err.Clear

On Error Goto 0

 

If intErrNum <> 0 Then intKN = -1 'key not in numeric format

 

'find PackedCatalogItem

intErrNum2 = oReg.GetBinaryValue (HKLM,strKey & "\" & strProCatKey &_

"\Catalog_Entries\" & oKey,"PackedCatalogItem",arTSP)

 

'if the PackedCatalogItem name exists And value set (exc for W2K!)

If intErrNum2 = 0 And IsArray(arTSP) Then

 

strDLL = "" 'clear strDLL

 

'reform strDLL from binary data array

For i = 0 To UBound(arTSP)

 

int1C = arTSP(i)

'end of target is single "0" byte

If int1C = 0 Then Exit For

'otherwise convert binary to ASCII and append to string

strDLL = strDLL & Chr(int1C)

 

Next 'binary data array element

 

'if key number numeric

If intKN <> -1 Then

 

'if file array populated

If intCnt > 0 Then

 

flagMatch = False

 

'for every arTSPFi member

For i = 0 To UBound(arTSPFi,2)

 

'if array file matches DLL, store array subscript

If arTSPFi(0,i) = strDLL Then

flagMatch = True : intSS = i : Exit For

End If

 

Next 'arTSPFi member

 

'if DLL is new

If Not flagMatch Then

 

'initialize output array for DLL

ReDim Preserve arTSPFi(3,intCnt)

arTSPFi(0,intCnt) = strDLL 'FN path\file name

arTSPFi(1,intCnt) = Right("0" & CStr(intKN),intL) 'OS output string

arTSPFi(2,intCnt) = intKN 'LA last added key number

arTSPFi(3,intCnt) = intKN 'UL upper limit key number

 

'increment output array for next pass

intCnt = intCnt + 1

 

Else 'flagMatch = True

 

'this key # consecutive to DLL UL

If intKN - arTSPFi(3,intSS) = 1 Then

 

'set DLL UL to this key #

arTSPFi(3,intSS) = intKN

 

Else 'this key # not consecutive to DLL UL

 

'if last added = upper limit, add comma and key # for new range

If arTSPFi(2,intSS) = arTSPFi(3,intSS) Then

 

arTSPFi(1,intSS) = arTSPFi(1,intSS) & ", " &_

Right("0" & CStr(intKN),intL)

arTSPFi(2,intSS) = intKN

arTSPFi(3,intSS) = intKN

 

'last added < upper limit, add hyphen, upper limit, comma and

'key # for new range

Else 'LA <> UL

 

arTSPFi(1,intSS) = arTSPFi(1,intSS) & " - " &_

Right("0" & CStr(arTSPFi(3,intSS)),intL) & ", " &_

Right("0" & CStr(intKN),intL)

arTSPFi(2,intSS) = intKN

arTSPFi(3,intSS) = intKN

 

End If 'LA = UL?

 

End If 'consecutive occurrence?

 

End If 'flagMatch?

 

Else 'intCnt = 0

 

'add first DLL to array

ReDim arTSPFi(3,intCnt)

arTSPFi(0,intCnt) = strDLL 'FN

arTSPFi(1,intCnt) = Right("0" & CStr(intKN),intL) 'OS

arTSPFi(2,intCnt) = intKN 'LA

arTSPFi(3,intCnt) = intKN 'UL

 

intCnt = intCnt + 1

 

End If 'intCnt > 0?

 

Else 'intKN not numeric

 

ReDim Preserve ATSPFi(1,intACnt)

arATSPFi(0,intACnt) = oKey

arATSPFi(1,intACnt) = strDLL

intACnt = intACnt + 1

 

End If 'intKN numeric?

 

End If 'PackedCatalogItem value exists?

 

Next 'subkey

 

 

'output results

 

'if Catalog_Entries sub-keys exist

If intNumKeys > 0 Then

 

'finalize output strings

For i = 0 To UBound(arTSPFi,2)

 

'last added < upper limit, add upper limit

If arTSPFi(2,i) < arTSPFi(3,i) Then

 

arTSPFi(1,i) = arTSPFi(1,i) & " - " & Right("0" & arTSPFi(3,i),intL)

 

End If 'LA = UL?

 

Next 'TSP array member

 

TitleLineWrite

 

'write out non-numeric sub-keys

If intACnt > 0 Then

 

For i = 0 To UBound(arATSPFi,2)

 

oFN.WriteLine vbCRLF & arATSPFi(0,i) & " = " & DQ &_

arATSPFi(1,i) & DQ & CoName(IDExe(arATSPFi(1,i))) & vbCRLF

 

Next

 

End If 'non-numeric sub-keys exist?

 

'write out numeric sub-keys

 

'0000000000##\PackedCatalogItem contains (DLL [Company Name], ##):

'%SystemRoot%\system32\xxxxxx.dll [CN] ##-##, ##-##

'%SystemRoot%\system32\yyyyyy.dll [CN] ##-##

 

oFN.WriteLine String(12-intL,"0") &_

String(intL,"#") & "\PackedCatalogItem (contains) DLL " &_

"[Company Name], (at) " & String(intL,"#") & " range:"

 

For i = 0 To UBound(arTSPFi,2)

 

oFN.WriteLine arTSPFi(0,i) & CoName(IDExe(arTSPFi(0,i))) & ", " &_

arTSPFi(1,i)

 

Next

 

Else 'intNumKeys=0 (no Catalog_Entries sub-keys)

 

If flagShowAll Then

TitleLineWrite : oFN.WriteLine "(sub-keys not found)"

End If

 

End If 'arKeys subkeys exist?

 

Else 'Catalog_Entries sub-keys do not exist

 

If flagShowAll Then

TitleLineWrite : oFN.WriteLine "(sub-keys not found)"

End If

 

End If 'Catalog_Entries array exists?

 

Else 'Current_Protocol_Catalog name doesn't exist Or value not set

 

If flagShowAll Then

TitleLineWrite : oFN.WriteLine vbCRLF & SYCA("HKLM\" & strKey &_

"\Current_Protocol_Catalog = (value not found)")

End If

 

End If 'Current_Protocol_Catalog value exists?

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

'recover array memory

ReDim arTSPFi(0)

ReDim arATSPFi(0)

 

End If 'SecTest?

 

 

 

 

'#23. Internet Explorer Toolbars, Explorer Bars, Extensions

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

strTitle = "Toolbars, Explorer Bars, Extensions:"

 

'HKCU/HKLM Explorer Bars, combined array of existing explorer bars

Dim arHKExplorerBars(), arListedExplorerBars()

Dim arAllowedExplorerBars() 'allowed explorer bars

Dim strHKExplorerBar 'single explorer bar

'all CLSIDs, CLSID\Implemented Categories sub-keys, single CLSID, single Impl Cat sub-key

Dim arCLSIDKeys(), arCLSIDImpCatSubKey(), strImpCatSubKey

'count of HKCU/HKLM explorer bars needed for ReDim statement

Dim cntExplorerBars : cntExplorerBars = 0

Dim arHKExtensions() 'HKCU/HKLM extension keys

Dim arAllowedExtensions() 'allowed extensions

Dim strHKExtension 'single extension key name

Dim arAllowedToolbars() 'allowed toolbars

Dim strHKToolbar 'single toolbar value name

Dim arHKCUTbSK() 'HKCU toolbar sub-keys

Dim strSKName 'single toolbar subkey name

Dim arSKValName() 'toolbar sub-key value names

Dim arHKToolbarVals() 'toolbar value names

Dim flagTBTLW : flagTBTLW = False 'toolbar title lines

 

 

'Toolbars

 

strSubTitle = "Toolbars"

 

ReDim arAllowedToolbars(4) 'must be in upper case!

arAllowedToolbars(0) = "{01E04581-4EEE-11D0-BFE9-00AA005B4383}" '&Address

arAllowedToolbars(1) = "{0E5CBF21-D15F-11D0-8301-00AA005B4383}" '&Links

arAllowedToolbars(2) = "{1E796980-9CC5-11D1-A83F-00C04FC99D61}" 'displayed toolbar buttons (non-CLSID)

arAllowedToolbars(3) = "{710EB7A1-45ED-11D0-924A-0020AFC7AC4D}" 'unknown default (non-CLSID)

arAllowedToolbars(4) = "{8E718888-423F-11D2-876E-00A0C9082467}" '... &Radio

 

strKey = "Software\Microsoft\Internet Explorer\Toolbar"

 

'for HKCU & HKLM hives

For i = 0 To 1

 

strSubSubTitle = SOCA(arHives(i,0) & "\" & strKey & "\")

 

'get toolbar key values

oReg.EnumValues arHives(i,1),strKey,arHKToolbarVals,arType

 

'if values exist

If IsArray(arHKToolbarVals) Then

 

'for each value

For Each strCLSID in arHKToolbarVals

 

'change to UCase

strCLSID = Trim(UCase(strCLSID))

 

'assume not on allowed list

flagAllow = False

 

'is Toolbar on allowed list?

For j = 0 To UBound(arAllowedToolbars)

If arAllowedToolbars(j) = UCase(strCLSID) Then

flagAllow = True : Exit For 'toggle allowed flag

End If

Next

 

'if not allowed Or ShowAll

If Not flagAllow Or flagShowAll Then

 

flagTitle = False

 

CLSIDLocTitle arHives(i,1), strKey, strCLSID, strLocTitle

 

For ctrCH = intCLL To 1

 

ResolveCLSID strCLSID, arHives(ctrCH,1), strCLSIDTitle, strIPSDLL

 

If strIPSDLL <> "" Then 'IPS exists?

 

If Not flagTitle Then

 

'output toolbar CLSID value name

On Error Resume Next

If strSubSubTitle <> "" Then

TitleLineWrite : oFN.WriteLine DQ & strCLSID & DQ &_

" = " & strLocTitle

intErrNum = Err.Number : Err.Clear

If intErrNum <> 0 Then oFN.WriteLine DQ & strCLSID & DQ &_

" = (no title provided)"

Else

oFN.WriteLine DQ & strCLSID & DQ & " = " & strLocTitle

intErrNum = Err.Number : Err.Clear

If intErrNum <> 0 Then oFN.WriteLine DQ & strCLSID & DQ &_

" = (no title provided)"

End If

flagTitle = True

On Error Goto 0

 

End If

 

'output InProcServer32 value

oFN.WriteLine " -> {" & arHives(ctrCH,0) & "...CLSID} = " &_

strCLSIDTitle & vbCRLF & Space(19) & "\InProcServer32\(Default) = " &_

StringFilter(strIPSDLL,True) & CoName(IDExe(strIPSDLL))

 

End If 'strIPSDLL <> ""?

 

Next 'CLSID hive

 

End If 'flagAllow Or ShowAll?

 

Next 'HKCU/HKLM toolbar key value

 

End If 'toolbar key has values

 

'for HKCU Toolbar key only

If arHives(i,0) = "HKCU" Then

 

'get HKCU toolbar subkeys

oReg.EnumKey HKCU,strKey,arHKCUTbSK

 

'if key array exists

If IsArray(arHKCUTbSK) Then

 

'for each sub-key

For Each strSKName in arHKCUTbSK

 

strSubSubTitle = "HKCU\" & strKey & "\" & strSKName & "\"

 

'if one of three targeted sub-keys

If LCase(strSKName) = "explorer" Or LCase(strSKName) = "shellbrowser" Or _

LCase(strSKName) = "webbrowser" Then

 

'get toolbar subkey values

oReg.EnumValues HKCU,strKey & "\" & strSKName,arSKValName,arType

 

'if array of values exists

If IsArray(arSKValName) Then

 

'for each value

For Each strValue in arSKValName

 

'assume not on allowed list

flagAllow = False

 

'is Toolbar on allowed list?

For j = 0 To UBound(arAllowedToolbars)

If arAllowedToolbars(j) = UCase(strValue) Then

flagAllow = True : Exit For 'toggle allowed flag

End If

Next

 

'if not allowed Or ShowAll

If Not flagAllow Or flagShowAll Then

 

flagTitle = False

 

For ctrCH = intCLL To 1

 

ResolveCLSID strValue, arHives(ctrCH,1), strCLSIDTitle, strIPSDLL

 

'if InProcServer32 value exists

If strIPSDLL <> "" Then

 

'output toolbar CLSID

If strSubSubTitle <> "" Then TitleLineWrite

If Not flagTitle Then

oFN.WriteLine DQ & strValue & DQ : flagTitle = True

End If

oFN.WriteLine " -> {" & arHives(ctrCH,0) & "...CLSID} = " &_

strCLSIDTitle & vbCRLF & Space(19) & "\InProcServer32\(Default) = " &_

StringFilter(strIPSDLL,True) & CoName(IDExe(strIPSDLL))

 

End If 'IPS exists?

 

Next

 

End If 'flagAllow Or ShowAll?

 

Next 'strValue

 

End If 'IsArray(arSKValName)?

 

End If 'targeted sub-key

 

Next 'toolbar sub-key

 

End If 'toolbar sub-key array exists

 

End If 'HKCU hive?

 

'if ShowAll, output title lines if not already done

If flagShowAll Then TitleLineWrite

 

Next 'hive

 

 

'Explorer Bars

 

strSubTitle = "Explorer Bars"

 

ReDim arAllowedExplorerBars(9) 'must be in upper case!

arAllowedExplorerBars(0) = "{30D02401-6A81-11D0-8274-00C04FD5AE38}" 'Search Band

arAllowedExplorerBars(1) = "{32683183-48A0-441B-A342-7C2A440A9478}" 'Media Band

arAllowedExplorerBars(2) = "{4D5C8C25-D075-11D0-B416-00C04FB90376}" '&Tip of the Day

arAllowedExplorerBars(3) = "{BDEADE7F-C265-11D0-BCED-00A0C90AB50F}" '&Discuss

arAllowedExplorerBars(4) = "{C4EE31F3-4768-11D2-BE5C-00A0C9A83DA1}" 'File and Folders Search ActiveX Control

arAllowedExplorerBars(5) = "{EFA24E61-B078-11D0-89E4-00C04FC9E26E}" 'Favorites Band

arAllowedExplorerBars(6) = "{EFA24E62-B078-11D0-89E4-00C04FC9E26E}" 'History Band

arAllowedExplorerBars(7) = "{EFA24E64-B078-11D0-89E4-00C04FC9E26E}" 'Explorer Band

arAllowedExplorerBars(8) = "{21569614-B795-46B1-85F4-E737A8DC09AD}" 'Search Band (WVa)

arAllowedExplorerBars(9) = "{5D60981B-2654-09E1-085A-6B546CA52169}" 'Favories Band (W98)

 

strKey = "Software\Microsoft\Internet Explorer\Explorer Bars"

 

'for HKCU & HKLM hives

For i = 0 To 1

 

strSubSubTitle = SOCA(arHives(i,0) & "\" & strKey & "\")

 

'get explorer bar subkeys

oReg.EnumKey arHives(i,1),strKey,arHKExplorerBars

 

'if subkeys exist

If IsArray(arHKExplorerBars) Then

 

'for each subkey

For Each strHKExplorerBar in arHKExplorerBars

 

'convert subkey name (CLSID) to uppercase

strHKExplorerBar= UCase(strHKExplorerBar)

 

'assume not on allowed list

flagAllow = False

 

'add to ListedExplorerBars array

ReDim Preserve arListedExplorerBars(cntExplorerBars)

arListedExplorerBars(cntExplorerBars) = strHKExplorerBar

cntExplorerBars = cntExplorerBars + 1 'cnt = UBound + 1

 

'is Explorer Bar on allowed list?

For j = 0 To UBound(arAllowedExplorerBars)

If arAllowedExplorerBars(j) = UCase(strHKExplorerBar) Then

flagAllow = True : Exit For 'toggle allowed flag

End If

Next

 

'if not allowed Or ShowAll

If Not flagAllow Or flagShowAll Then

 

flagTitle = False

 

CLSIDLocTitle arHives(i,1), strKey, strHKExplorerBar, strLocTitle

 

For ctrCH = intCLL To 1

 

ResolveCLSID strHKExplorerBar, arHives(ctrCH,1), strCLSIDTitle, strIPSDLL

 

'if InProcServer32 value exists

If strIPSDLL <> "" Then

 

'output explorer bar CLSID

If strSubSubTitle <> "" Then TitleLineWrite

 

If Not flagTitle Then

oFN.WriteLine strHKExplorerBar & "\(Default) = " & strLocTitle

flagTitle = True

End If

 

'output InProcServer32 value

oFN.WriteLine " -> {" & arHives(ctrCH,0) & "...CLSID} = " &_

strCLSIDTitle & vbCRLF & Space(19) & "\InProcServer32\(Default) = " &_

StringFilter(strIPSDLL,True) & CoName(IDExe(strIPSDLL))

 

End If 'IPS exists?

 

Next

 

End If 'not on allowed list Or ShowAll

 

Next 'HKCU/HKLM explorer bar subkey

 

End If 'explorer bar key has subkeys

 

'if ShowAll, output sub-title lines if not already done

If flagShowAll Then TitleLineWrite

 

Next 'hive

 

 

'check CLSIDs for Explorer Bars

 

Dim datDEBStart : datDEBStart = Now

 

strKey = "Software\Classes\CLSID"

 

For ctrCH = intCLL To 1

 

'get CLSIDs

oReg.EnumKey arHives(ctrCH,1),strKey,arCLSIDKeys

 

If IsArray(arCLSIDKeys) Then

 

'for each CLSID

For Each strCLSIDKey in arCLSIDKeys

 

'convert to uppercase

strCLSIDKey = UCase(strCLSIDKey)

 

'look for Implemented Categories subkeys

intErrNum = oReg.EnumKey (arHives(ctrCH,1),strKey & "\" & strCLSIDKey &_

"\Implemented Categories",arCLSIDImpCatSubKey)

 

'if Implemented Categories subkeys exist

If intErrNum = 0 And IsArray(arCLSIDImpCatSubKey) Then

 

'for each Implemented Categories subkey

For Each strImpCatSubKey in arCLSIDImpCatSubKey

 

'convert to uppercase

strImpCatSubKey = UCase(strImpCatSubKey)

 

'if subkey name is vertical or horizontal explorer bar

If strImpCatSubKey = "{00021494-0000-0000-C000-000000000046}" Or _

strImpCatSubKey = "{00021493-0000-0000-C000-000000000046}" Then

 

flagFound = False 'assume CLSID is not listed in HKCU/HKLM explorer bars

 

If IsArray(arListedExplorerBars) Then

 

'search explorer bar array for CLSID

For Each strArMember in arListedExplorerBars

If strArMember = strCLSIDKey Then

flagFound = True : Exit For

End If

Next

 

End If 'IsArray(arListedExplorerBars)?

 

'if CLSID not listed

If Not flagFound Then

 

'assume not allowed

flagAllow = False

 

'see if on allowed list

For j = 0 To UBound(arAllowedExplorerBars)

If arAllowedExplorerBars(j) = UCase(strCLSIDKey) Then

flagAllow = True : Exit For

End If

Next

 

'if not allowed Or ShowAll

If Not flagAllow Or flagShowAll Then

 

'look for InProcServer32

intErrNum3 = oReg.GetExpandedStringValue(arHives(ctrCH,1),"Software\Classes\CLSID\" &_

strCLSIDKey & "\InProcServer32","",strValue3)

 

'if InProcServer32 value exists

If intErrNum3 = 0 And strValue3 <> "" Then

 

'get CLSID title

oReg.GetStringValue arHives(ctrCH,1),"Software\Classes\CLSID\" &_

strCLSIDKey,"",strValue4

 

TitleLineWrite

 

'output CLSID + title, prepare output string,

'output Implemented Categories key, InProcServer32

If strValue4 <> "" Then

oFN.WriteLine vbCRLF & SOCA(arHives(ctrCH,0) & "\Software\Classes\CLSID\") &_

strCLSIDKey & "\(Default) = " & StringFilter(strValue4,True)

Else

oFN.WriteLine vbCRLF & SOCA(arHives(ctrCH,0) & "\Software\Classes\CLSID\") &_

strCLSIDKey & "\(Default) = (title not found)"

End If

If Mid(strImpCatSubKey,9,1) = "3" Then

strOut = " [vertical bar]"

Else

strOut = " [horizontal bar]"

End If

oFN.WriteLine "Implemented Categories\" & strImpCatSubKey & "\" & strOut

oFN.WriteLine "InProcServer32\(Default) = " &_

DQ & strvalue3 & DQ & CoName(IDExe(strValue3))

 

End If 'CLSID InProcServer32 exists?

 

End If 'CLSID not allowed Or ShowAll?

 

End If 'CLSID not already found in HKCU/HKLM?

 

End If 'strImpCatSubKey designates scroll bar?

 

Next 'arCLSIDImpCatSubKey

 

End If 'Implemented Categories sub-key exists?

 

Next 'CLSID sub-key

 

End If 'CLSID array exists?

 

Next 'CLSID hive

 

'determine -supp seconds used

Dim strDEBTime : strDEBTime = DateDiff("s",datDEBStart,Now) & " seconds"

 

 

 

 

'Extensions (Tools menu items, toolbar buttons)

 

strSubTitle = "Extensions (Tools menu items, main toolbar menu buttons)"

 

ReDim arAllowedExtensions(4) 'must be in upper case!

arAllowedExtensions(0) = "{438AFBA1-B0CB-11D2-9214-00104B3BCE5F}" '&Document Tree

arAllowedExtensions(1) = "{B06300D0-CCDE-11D2-92D3-0000F87A4A55}" 'Add to R&estricted Zone

arAllowedExtensions(2) = "{BF80219A-CCDD-11D2-92D3-0000F87A4A55}" 'Add to Tr&usted Zone

arAllowedExtensions(3) = "{C95FE080-8F5D-11D2-A20B-00AA003C157A}" 'Show &Related Links

arAllowedExtensions(4) = "{FC09D8A3-C85A-11D2-92D0-0000F87A4A55}" 'Offline

'{FB5F1910-F110-11D2-BB9E-00C04F795683} MSN Messenger Service

 

strKey = "Software\Microsoft\Internet Explorer\Extensions"

 

'for HKCU & HKLM hives

For i = 0 To 1

 

strSubSubTitle = SOCA(arHives(i,0) & "\" & strKey & "\")

 

'get extension subkeys

oReg.EnumKey arHives(i,1),strKey,arHKExtensions

 

'if subkeys exist

If IsArray(arHKExtensions) Then

 

'for each subkey

For Each strHKExtension in arHKExtensions

 

If Len(strHKExtension) = 38 And Left(strHKExtension,1) = "{" And _

Right(strHKExtension,1) = "}" Then

 

'convert subkey name (CLSID) to uppercase

strHKExtension= UCase(strHKExtension)

 

'assume not on allowed list

flagAllow = False

 

'is Extension on allowed list?

For j = 0 To UBound(arAllowedExtensions)

If arAllowedExtensions(j) = UCase(strHKExtension) Then

flagAllow = True : Exit For 'toggle allowed flag

End If

Next

 

'if not allowed Or ShowAll

If Not flagAllow Or flagShowAll Then

 

'look for ButtonText/MenuText/CLSIDExtension/Exec values

intErrNum1 = oReg.GetStringValue(arHives(i,1),strKey & "\" &_

strHKExtension,"ButtonText",strValue1)

intErrNum2 = oReg.GetStringValue(arHives(i,1),strKey & "\" &_

strHKExtension,"MenuText",strValue2)

intErrNum3 = oReg.GetStringValue(arHives(i,1),strKey & "\" &_

strHKExtension,"CLSIDExtension",strValue3)

intErrNum4 = oReg.GetStringValue(arHives(i,1),strKey &_

"\" & strHKExtension,"Script",strValue4)

intErrNum5 = oReg.GetStringValue(arHives(i,1),strKey &_

"\" & strHKExtension,"Exec",strValue5)

 

If strSubSubTitle <> "" Then

TitleLineWrite : oFN.WriteLine strHKExtension & "\"

Else

oFN.WriteLine vbCRLF & strHKExtension & "\"

End If

 

'most output is optional (on error, do nothing)

On Error Resume Next

If intErrNum1 = 0 And strValue1 <> "" Then _

oFN.WriteLine DQ & "ButtonText" & DQ & " = " &_

DQ & strValue1 & DQ

If intErrNum2 = 0 And strValue2 <> "" Then _

oFN.WriteLine DQ & "MenuText" & DQ & " = " & DQ &_

strValue2 & DQ

 

If intErrNum3 = 0 And strValue3 <> "" Then

 

Err.Clear 'required to reset Err if ButtonText or MenuText missing

 

flagTitle = False

For ctrCH = intCLL To 1

 

ResolveCLSID strValue3, arHives(ctrCH,1), strCLSIDTitle, strValue6

 

If Not flagTitle Then

oFN.WriteLine DQ & "CLSIDExtension" & DQ & " = " &_

DQ & strValue3 & DQ

flagTitle = True

End If

 

If strValue6 <> "" Then

oFN.WriteLine " -> {" & arHives(ctrCH,0) & "...CLSID} = " &_

strCLSIDTitle & vbCRLF & Space(19) & "\InProcServer32\(Default) = " &_

StringFilter(strValue6,True) & CoName(IDExe(strValue6))

End If

 

Next 'CLSID hive

 

End If 'CLSIDExtension value exists

 

If intErrNum4 = 0 And strValue4 <> "" Then oFN.WriteLine DQ &_

"Script" & DQ & " = " & DQ & strValue4 & DQ &_

CoName(IDExe(strValue4))

If intErrNum5 = 0 And strValue5 <> "" Then oFN.WriteLine DQ &_

"Exec" & DQ & " = " & DQ & strValue5 & DQ &_

CoName(IDExe(strValue5))

Err.Clear

On Error Goto 0

 

End If 'flagAllow Or flagAll?

 

End If 'CLSID format?

 

Next 'Extension subkey

 

End If 'Extension subkeys exist

 

'if ShowAll, output sub-title lines if not already done

If flagShowAll Then TitleLineWrite

 

Next 'hive

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

'recover array memory

ReDim arCLSIDKeys(0)

ReDim arCLSIDImpCatSubKey(0)

ReDim arExplorerBars(0)

ReDim arAllowedExplorerBars(0)

ReDim arListedExplorerBars(0)

ReDim arHKExtensions(0)

ReDim arAllowedExtensions(0)

ReDim arAllowedToolbars(0)

ReDim arHKCUTbSK(0)

ReDim arSKValName(0)

ReDim arHKToolbarVals(0)

 

End If 'SecTest?

 

 

 

 

'#24. Internet Explorer URL Prefixes

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

strTitle = "Internet Explorer Address Prefixes:"

 

'prefix used if bare domain ("microsoft.com") entered into IE address box

strKey = "Software\Microsoft\Windows\CurrentVersion\URL"

 

strSubTitle = "Prefix for bare domain (" & DQ &_

"domain-name-here.com" & DQ & ")" & vbCRLF & vbCRLF &_

SOCA("HKLM\" & strKey & "\Default Prefix\")

 

'get DefaultPrefix default value

intErrNum = oReg.GetStringValue (HKLM,strKey & "\DefaultPrefix","",strValue)

 

'assume not infected

strWarn = ""

 

'value exists and is not empty

If intErrNum = 0 And strValue <> "" Then

 

'if default value not OK, toggle warning & flagHWarn

If Trim(LCase(strValue)) <> "http://" Then

strWarn = HWarn : flagHWarn = True

End If

 

If strWarn <> "" Or flagShowAll Then

 

TitleLineWrite : oFN.Writeline strWarn & "(Default) = " &_

StringFilter(strValue,True)

 

End If

 

Else 'value doesn't exist

 

If flagShowAll Then

TitleLineWrite

oFN.WriteLine "(Default) = (value not set)"

End If

 

End If 'default value exists?

 

 

'prefix used with specific service

'2 x 5 array

Dim arPrefix()

ReDim arPrefix(1,4)

arPrefix(0,0) = "ftp" : arPrefix(1,0) = "ftp://"

arPrefix(0,1) = "gopher" : arPrefix(1,1) = "gopher://"

arPrefix(0,2) = "home" : arPrefix(1,2) = "http://"

arPrefix(0,3) = "mosaic" : arPrefix(1,3) = "http://"

arPrefix(0,4) = "www" : arPrefix(1,4) = "http://"

 

'find all the names in the key

intErrNum1 = oReg.EnumValues (HKLM, strKey & "\Prefixes", arNames, arType)

 

strSubTitle = "Prefix for specific service (i.e., " & DQ & "www" &_

DQ & ")" & vbCRLF & vbCRLF & SOCA("HKLM\" & strKey & "\Prefixes\")

 

'enumerate data if present

If intErrNum1 = 0 And IsArray(arNames) Then

 

'for each name

For Each strName in arNames

 

'assume infected

flagMatch = False : strWarn = HWarn

 

'for each prefix type

For i = 0 To UBound(arPrefix,2)

 

'if name = prefix Or name = prefix.

If Trim(LCase(strName)) = arPrefix(0,i) Or _

Trim(LCase(strName)) = arPrefix(0,i) & "." Then

 

'get value

intErrNum2 = oReg.GetStringValue(HKLM,strKey & "\Prefixes", _

strName,strValue)

 

'if value exists (exc. for W2K!)

If intErrNum2 = 0 And strValue <> "" Then

 

'toggle flags if value = default value

If Trim(LCase(strValue)) = arPrefix(1,i) Then

flagMatch = True : strWarn = "" : Exit For

End If 'value = arPrefix member?

 

End If 'strValue exists And not empty?

 

End If 'name = arPrefix member?

 

Next 'arPrefix member

 

'get value if name not in arPrefix

If Not flagMatch Then oReg.GetStringValue HKLM, _

strKey & "\Prefixes",strName,strValue

 

'output if flagMatch Or flagShowAll

If Not flagMatch Or flagShowAll Then

 

TitleLineWrite

 

If strWarn <> "" Then flagHWarn = True

 

On Error Resume Next

 

'output warning, name, value

oFN.WriteLine strWarn & StringFilter(strName,True) & " = " &_

DQ & strValue & DQ

intErrNum = Err.Number : Err.Clear

'error check for W2K if value not set

If intErrNum <> 0 Then oFN.WriteLine StringFilter(strName,True) &_

" = (value not set)"

 

On Error Goto 0

 

End If 'flagMatch or flagShowAll?

 

Next 'prefix key name array member

 

If strSubTitle <> "" And flagShowAll Then

TitleLineWrite : oFN.WriteLine "(values not found)"

End If

 

Else 'prefix key name array doesn't exist

 

If flagShowAll Then

TitleLineWrite : oFN.WriteLine "(values not found)"

End If

 

End If 'prefix key name array exists

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

'recover array memory

ReDim arPrefix(0,0)

 

End If 'SecTest?

 

 

 

 

'#25. Misc. IE Hijack Points

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

'IERESET Text File, IERESET file name, INF-file section name,

'array of count of missing phrase lines by section

Dim oIERTF, strSection, arSectionCount(), intTFF

Dim intAsc1Chr, intAsc2Chr 'ASCII code of 1st & 2nd chr of IERESET.INF

'zero-based number of sections in phrase array with lines missing from disk file

Public intSectionCount : intSectionCount = -1

'one-based number of lines in each section of phrase array with lines missing from disk file

Public intSectionLineCount : intSectionLineCount = 0

 

strTitle = "Miscellaneous IE Hijack Points"

strWarn = HWarn

 

'parse IERESET.INF, look for added and missing lines

Dim strIERFN : strIERFN = UCase(strFPWF) & "\INF\IERESET.INF"

 

'read the IE version from the registry

 

'IE version reg value, work string

Dim strIELVer, strIELVWK

'short string version, non-numeric if dec symbol not "."

Dim strIEShVer : strIEShVer = "0"

'numeric IE version: 0 if IE version not in registry or value not set

'otherwise, number using single local dec symbol

Dim intIELVer : intIELVer = 0

Dim strDecSym : strDecSym = "." 'dec symbol

 

strKey = "Software\Microsoft\Internet Explorer"

intErrNum = oReg.GetStringValue(HKLM,strKey,"Version",strIELVer)

 

strSubTitle = SOCA("HKLM\" & strKey & "\Version = " & strIELVer)

strSubSubTitle = strIERFN & " (used to " & DQ & "Reset Web " &_

"Settings" & DQ & ")"

 

'in W2K, if value not set, strIELVer will be garbage

If intErrNum = 0 And Len(Trim(strIELVer)) > 3 Then

 

'read the decimal symbol from the registry

strKey1 = "Control Panel\International"

intErrNum1 = oReg.GetStringValue(HKCU,strKey1,"sDecimal",strValue1)

'if the symbol exists, store it

If intErrNum1 = 0 And strValue1 <> "" Then strDecSym = strValue1

 

'replace 1st dec pt in the IE ver with XXX

strIELVWK = Replace (Trim(strIELVer),".","XXX",1,1,1)

'delete all succeeding dec pts

strIELVWK = Replace (Trim(strIELVWK),".","",1,-1,1)

'restore dec symbol to pos'n of first dec pt and call it an integer

intIELVer = Replace (Trim(strIELVWK),"XXX",strDecSym,1,1,1)

 

If IsNumeric(intIELVer) Then 'should exclude W2K value not set garbage

 

strIEShVer = Left(LTrim(strIELVer),3)

 

If strIEShVer <> "5.5" Then 'for 5.5, retain 3 chrs

 

'use left-most chr

strIEShVer = Left(LTrim(strIELVer),1)

 

'if IE ver < 5, advise that INF file doesn't exist

If intIELVer < 5 Then

TitleLineWrite

oFN.WriteLine vbCRLF & "IERESET.INF does not exist for this Internet " &_

"Explorer version."

End If 'intIELVer<5?

 

End If 'strIEShVer=5.5?

 

Else 'intIELVer not numeric, so advise about bad IE version and reset to 0

 

strSubTitle = "HKLM\" & strKey & "\Version = (invalid data)" &_

vbCRLF & "The Internet Explorer version cannot be found!"

TitleLineWrite

oFN.WriteLine "The contents of IERESET.INF cannot be reliably checked!"

intIELVer = 0

 

End If 'intIELVer numeric?

 

Else 'IE ver not found or value corrupt

 

strSubTitle = SOCA("HKLM\" & strKey & "\Version = (invalid data)" &_

vbCRLF & "The Internet Explorer version cannot be found!")

TitleLineWrite

oFN.WriteLine "The contents of IERESET.INF cannot be reliably checked!"

 

End If 'IE ver exists?

 

'change titles if not already written

If strTitle <> "" Then

strSubTitle = strIERFN & " (used to " & DQ & "Reset Web Settings" &_

DQ & ")"

strSubSubTitle = ""

End If

 

If strIEShVer <> "7" Then 'IE 7

 

Dim arIER() 'common IERESET.INF lines & phrases

ReDim arIER(31,2) 'section, phrase, found-in-file-on-disk?

arIER(0,0)="[Version]" : arIER(0,1)="Signature=""$CHICAGO$"""

arIER(1,0)="[Version]" : arIER(1,1)="AdvancedINF=2.5,""You need a new version of advpack.dll"""

arIER(2,0)="[RestoreHomePage]" : arIER(2,1)="AddReg=RestoreHomePage.reg"

arIER(3,0)="[RestoreHomePage.reg]" : arIER(3,1)="HKCU,""Software\Microsoft\Internet Explorer\Main"",""Start Page"",0,%START_PAGE_URL%"

arIER(4,0)="[RestoreBrowserSettings.reg]" : arIER(4,1)="HKLM,""Software\Microsoft\Internet Explorer\Main"",""Default_Page_URL"",0,%START_PAGE_URL%"

arIER(5,0)="[RestoreBrowserSettings.reg]" : arIER(5,1)="HKLM,""Software\Microsoft\Internet Explorer\Main"",""Default_Search_URL"",0,%SEARCH_PAGE_URL%"

arIER(6,0)="[RestoreBrowserSettings.reg]" : arIER(6,1)="HKLM,""Software\Microsoft\Internet Explorer\Main"",""Search Page"",0,%SEARCH_PAGE_URL%"

arIER(7,0)="[RestoreBrowserSettings.reg]" : arIER(7,1)="HKLM,""Software\Microsoft\Internet Explorer\Main\UrlTemplate"",""1"",0,""www.%s.com"""

arIER(8,0)="[RestoreBrowserSettings.reg]" : arIER(8,1)="HKLM,""Software\Microsoft\Internet Explorer\Main\UrlTemplate"",""2"",0,""www.%s.org"""

arIER(9,0)="[RestoreBrowserSettings.reg]" : arIER(9,1)="HKLM,""Software\Microsoft\Internet Explorer\Main\UrlTemplate"",""3"",0,""www.%s.net"""

arIER(10,0)="[RestoreBrowserSettings.reg]" : arIER(10,1)="HKLM,""Software\Microsoft\Internet Explorer\Main\UrlTemplate"",""4"",0,""www.%s.edu"""

arIER(11,0)="[RestoreBrowserSettings.reg]" : arIER(11,1)="HKCU,""Software\Microsoft\Internet Explorer\Main"",""Search Page"",0,%SEARCH_PAGE_URL%"

arIER(12,0)="[RestoreBrowserSettings.reg]" : arIER(12,1)="HKCU,""Software\Microsoft\Internet Explorer\SearchUrl"",""Provider"",0,"""""

arIER(13,0)="[RestoreBrowserSettings.reg]" : arIER(13,1)="HKLM,""Software\Microsoft\Internet Explorer\Search"",""SearchAssistant"",0,""http://ie.search.msn.com/{SUB_RFC1766}/srchasst/srchasst.htm"""

arIER(14,0)="[RestoreBrowserSettings.reg]" : arIER(14,1)="HKLM,""Software\Microsoft\Internet Explorer\Search"",""CustomizeSearch"",0,""http://ie.search.msn.com/{SUB_RFC1766}/srchasst/srchcust.htm"""

arIER(15,0)="[RestoreBrowserSettings.reg]" : arIER(15,1)="HKLM,""Software\Microsoft\Windows\CurrentVersion\Internet Settings\SafeSites"",%SAFESITE_VALUE%,0,""http://ie.search.msn.com/*"""

arIER(16,0)="[DeleteTemplates.reg]" : arIER(16,1)="HKLM,""Software\Microsoft\Internet Explorer\Main\UrlTemplate"",""5"""

arIER(17,0)="[DeleteTemplates.reg]" : arIER(17,1)="HKLM,""Software\Microsoft\Internet Explorer\Main\UrlTemplate"",""6"""

arIER(18,0)="[DeleteTemplates.reg]" : arIER(18,1)="HKLM,""Software\Microsoft\Internet Explorer\Main\UrlTemplate"",""7"""

arIER(19,0)="[DeleteTemplates.reg]" : arIER(19,1)="HKLM,""Software\Microsoft\Internet Explorer\Main\UrlTemplate"",""8"""

arIER(20,0)="[DeleteTemplates.reg]" : arIER(20,1)="HKLM,""Software\Microsoft\Internet Explorer\Main\UrlTemplate"",""9"""

arIER(21,0)="[DeleteAutosearch.reg]" : arIER(21,1)="HKCU,""Software\Microsoft\Internet Explorer\Main"",""AutoSearch"""

arIER(22,0)="[strings]" : arIER(22,1)="SEARCH_PAGE_URL=""http://www.microsoft.com/isapi/redir.dll?prd=ie&ar=iesearch"""

arIER(23,0)="[RestoreBrowserSettings]" : arIER(23,1)="AddReg=RestoreBrowserSettings.reg"

 

arIER(24,0)="[RestoreBrowserSettings]" : arIER(24,1)="DelReg=DeleteTemplates.reg"

arIER(25,0)="[RestoreBrowserSettings]" : arIER(25,1)="DelReg=DeleteTemplates.reg, DeleteAutosearch.reg"

arIER(26,0)="[strings]" : arIER(26,1)="START_PAGE_URL=""http://www.microsoft.com/isapi/redir.dll?prd=ie&pver=" & strIEShVer & "&ar=msnhome"""

arIER(27,0)="[strings]" : arIER(27,1)="START_PAGE_URL=""http://www.msn.com"""

arIER(28,0)="[strings]" : arIER(28,1)="SAFESITE_VALUE=""http://home.microsoft.com/"""

arIER(29,0)="[strings]" : arIER(29,1)="SAFESITE_VALUE=""ie.search.msn.com"""

arIER(30,0)="[strings]" : arIER(30,1)="MS_START_PAGE_URL=""http://www.microsoft.com/isapi/redir.dll?prd=ie&pver=" & strIEShVer & "&ar=msnhome"""

arIER(31,0)="[strings]" : arIER(31,1)="MS_START_PAGE_URL=""http://www.msn.com"""

 

'set found-in-file-on-disk flag to False

For i = 0 To UBound(arIER,1) : arIER(i,2) = False : Next

 

'if IERESET.INF exists

If Fso.FileExists(strIERFN) Then

 

'open the file for reading/don't create/ASCII format

Set oIERTF = Fso.OpenTextFile (strIERFN,1,False,0)

 

'get the file size

Dim intFileSize : intFileSize = Fso.GetFile(strIERFN).Size

 

If intFileSize > 100 Then

 

'read 1st 2 chrs, find Asc code (not AscW code)

intAsc1Chr = Asc(oIERTF.Read(1)) : intAsc2Chr = Asc(oIERTF.Read(1))

 

oIERTF.Close

 

'if Asc codes = 255 & 254, file is Unicode

'ASCII file read as Unicode: 1st Unicode line is entire file

'Unicode file read as ASCII: 1st ASCII line is variable length

'TriStateDefault appears to distinguish between ASCII & Unicode on file open

'VBS internally allots 2 bytes per ASCII chr

 

intTFF = 0 'ASCII fmt

If intAsc1Chr = 255 And intAsc2Chr = 254 Then intTFF = -1 'Unicode fmt

 

Set oIERTF = Fso.OpenTextFile (strIERFN,1,False,intTFF)

 

strSubSubTitle = "Added lines (compared with English-language version):"

 

flagInfect = False

 

'for each line

Do Until oIERTF.AtEndOfStream

 

strLine = Trim(oIERTF.ReadLine) 'read a line

 

flagMatch = False 'line doesn't match phrase array

 

'if line not empty And not a comment

If Len(strLine) > 0 And Left(strLine,1) <> ";" Then

 

If Left(strLine,1) = "[" Then 'if line is section title

 

strSection = strLine 'save the section name

 

Else 'line not a section title, so it's a data line

 

For i = 0 To UBound(arIER,1) 'for every line in phrase array

 

'if section's identical and phrase found in line,

'toggle line match flag & found-in-file-on-disk flag

If LCase(arIER(i,0)) = LCase(strSection) And _

LCase(strLine) = LCase(arIER(i,1)) Then

flagMatch = True : arIER(i,2) = True : Exit For

Exit For

End If

 

Next

 

If Not flagMatch Then 'if line not matched

flagInfect = True

TitleLineWrite

On Error Resume Next

'output section name & line

oFN.WriteLine strSection & ": " & strLine

intErrNum = Err.Number : Err.Clear

On Error Goto 0

If intErrNum <> 0 Then oFN.WriteLine "(unwritable string)"

End If 'line matched?

 

End If 'section title line?

 

End If 'data line?

 

Loop 'next file line

 

'close IERESET.INf

oIERTF.Close : Set oIERTF=Nothing

 

'initialize section title for phrases missing from file

strSection = ""

strSubSubTitle = "Missing lines (compared with English-language version):"

flagFound = True 'False if found-in-file-on-disk = False

 

For i = 0 To 23 'for single-option phrases

If Not arIER(i,2) Then

flagFound = False : flagInfect = True 'toggle flags

'increment counters

IERESETCounter strSection, arIER(i,0), arSectionCount

End If

Next 'single-option phrase

 

'check double-option phrases

For i = 24 To 30 Step 2

'if neither option found-in-file-on-disk

If Not arIER(i,2) And Not arIER(i+1,2) Then

flagFound = False : flagInfect = True 'toggle flags

'increment counters

IERESETCounter strSection, arIER(i,0), arSectionCount

End If

Next 'double-option phrase

 

If Not flagFound Then 'if lines missing

 

TitleLineWrite

 

'output contents of arSectionCount (section title: # missing lines)

For i = 0 To UBound(arSectionCount,2)

strOut = " line"

If arSectionCount(1,i) > 1 Then strOut = " lines"

oFN.WriteLine arSectionCount(0,i) & ": " & arSectionCount(1,i) & strOut

Next

 

End If 'lines missing?

 

strSubSubTitle = "" 'reset title line (no longer needed)

 

If strTitle <> "" And flagShowAll Then

strSubTitle = strIERFN & " (used to " & DQ &_

"Reset Web Settings" & DQ & " -- no anomalies found)"

TitleLineWrite

End If

 

Else 'IERESET.INF<100 bytes

 

oIERTF.Close

 

'file should always exist if IE ver > 5 Or if in one of these OS's

If intIELVer > 5 Or strOS = "WXP" Or strOS = "W2K" Or strOS = "WME" Then

 

TitleLineWrite

oFN.WriteLine strWarn & strIERFN & " is *much* too small and is " &_

"probably corrupt!"

flagHWarn = True

 

End If 'should file exist?

 

End If 'IERSET.INF>100 bytes?

 

Else 'IERESET.INF not found

 

'file should always exist if IE ver > 5 Or if in one of these OS's

If intIELVer > 5 Or strOS = "WXP" Or strOS = "W2K" Or strOS = "WME" Then

 

TitleLineWrite

oFN.WriteLine strWarn & strIERFN & " was not found!"

flagHWarn = True

 

End If 'should file exist?

 

End If 'IERESET.INF found?

 

End If 'strIEShVer<>7?

 

'URLSearchHooks

strKey = "Software\Microsoft\Internet Explorer\URLSearchHooks"

strSubTitle = "HKCU\" & strKey & "\"

 

intErrNum = oReg.EnumValues (HKCU, strKey, arNames, arType)

 

If IsArray(arNames) Then

 

For Each strCLSID In arNames

 

If UCase(strCLSID) <> "{CFBFAE00-17A6-11D0-99CB-00C04FD64497}" Or _

flagShowAll Then

 

flagTitle = False

 

CLSIDLocTitle HKCU, strKey, strCLSID, strLocTitle

 

For ctrCH = intCLL To 1

 

ResolveCLSID strCLSID, arHives(ctrCH,1), strCLSIDTitle, strIPSDLL

 

If strIPSDLL <> "" Then

 

strWarn = ""

If UCase(strCLSID) <> "{CFBFAE00-17A6-11D0-99CB-00C04FD64497}" Then

strWarn = HWarn : flagHWarn = True

End If

 

TitleLineWrite

 

If Not flagTitle Then

oFN.WriteLine strWarn & DQ & strCLSID & DQ & " = " & strLocTitle

flagTitle = True

End If

 

oFN.WriteLine " -> {" & arHives(ctrCH,0) & "...CLSID} = " &_

strCLSIDTitle & vbCRLF & Space(19) & "\InProcServer32\(Default) = " &_

StringFilter(strIPSDLL,True) & CoName(IDExe(strIPSDLL))

 

End If 'IPS exists?

 

Next 'CLSID hive

 

End If 'match Or flagShowAll?

 

Next 'strCLSID

 

Else

 

If flagShowAll Then

TitleLineWrite

oFN.WriteLine "(URLSearchHooks key not found!)"

End If

 

End If 'IsArray?

 

 

'AboutURLs

strKey = "Software\Microsoft\Internet Explorer\AboutURLs"

strSubTitle = SOCA("HKLM\" & strKey & "\")

 

EnumNVP HKLM, strKey, arNames, arType

 

If flagNVP Then 'name/value pairs exist

 

Set arSK = CreateObject("Scripting.Dictionary") 'key, item

 

'add dictionary pairs (universal elements)

arSK.Add "blank", "res://mshtml.dll/blank.htm"

arSK.Add "Home", "dword:0x0000010E"

arSK.Add "mozilla", "res://mshtml.dll/about.moz"

 

'value not set or IE 5-7

If intIELVer >= 7 Then 'IE 7

arSK.Add "DesktopItemNavigationFailure", "res://ieframe.dll/navcancl.htm"

arSK.Add "NavigationCanceled", "res://ieframe.dll/navcancl.htm"

arSK.Add "NavigationFailure", "res://ieframe.dll/navcancl.htm"

arSK.Add "OfflineInformation", "res://ieframe.dll/offcancl.htm"

arSK.Add "NoAdd-ons", "res://ieframe.dll/noaddon.htm"

arSK.Add "NoAdd-onsInfo", "res://ieframe.dll/noaddoninfo.htm"

arSK.Add "PostNotCached", "res://ieframe.dll/repost.htm"

arSK.Add "SecurityRisk", "res://ieframe.dll/securityatrisk.htm"

arSK.Add "Tabs", "res://ieframe.dll/tabswelcome.htm"

ElseIf intIELVer = 0 Or intIELVer >= 5 Then

arSK.Add "DesktopItemNavigationFailure", "res://shdoclc.dll/navcancl.htm"

arSK.Add "NavigationCanceled", "res://shdoclc.dll/navcancl.htm"

arSK.Add "NavigationFailure", "res://shdoclc.dll/navcancl.htm"

arSK.Add "OfflineInformation", "res://shdoclc.dll/offcancl.htm"

arSK.Add "PostNotCached", "res://mshtml.dll/repost.htm"

Else 'IE < 5

arSK.Add "DesktopItemNavigationFailure", "res://shdocvw.dll/navcancl.htm"

arSK.Add "NavigationCanceled", "res://shdocvw.dll/navcancl.htm"

arSK.Add "NavigationFailure", "res://shdocvw.dll/navcancl.htm"

arSK.Add "OfflineInformation", "res://shdocvw.dll/offcancl.htm"

arSK.Add "PostNotCached", "res://mshtml.dll/repost.htm"

End If 'IE>7?

 

arSKk = arSK.Keys : arSKi = arSK.Items

 

For i = 0 To UBound(arNames)

 

strWarn = HWarn

 

'use the type to find the value

strValue = RtnValue (HKLM, strKey, arNames(i), arType(i))

 

For j = 0 To arSK.Count-1

 

flagFound = False

 

If LCase(arNames(i)) = LCase(arSKk(j)) And _

LCase(strValue) = LCase(arSKi(j)) Then

flagFound = True : strWarn = "" : Exit For

End If

 

Next 'dictionary pair

 

If Not flagFound Or flagShowAll Then

 

TitleLineWrite

WriteValueData arNames(i), strValue, arType(i), strWarn

If strWarn <> "" Then flagHWarn = True

 

End If

 

Next 'arNames member

 

arSK.RemoveAll : Set arSK=Nothing 'recover dictionary memory

 

Else

 

If flagShowAll Then

TitleLineWrite

oFN.WriteLine "(AboutURLs key not found!)"

End If

 

End If 'flagNVP?

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

End If 'SecTest?

[MAcgYvER everyONE 0]

'#20. Startup Directories

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

'All Users StartUp Folder (AUSFP title string (empty by default)

Dim flagAUSUF : flagAUSUF = False 'true if entry for AUSF loc'n in registry

Dim flagFE : flagFE = False 'true if AUSF exists

 

'in W98/WMe, see if local-language-specific All Users startup folder location

'appears in registry and set flag 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 name exists and value not empty, toggle flag

If Not IsNull(strValue) And strValue <> "" Then flagAUSUF = True

 

End If

 

'assign startup folder short names

If strOS = "W98" Or strOS = "WME" Then

arSUFN = Array("Startup")

arSUFDN = Array("Startup")

Else

arSUFN = Array("Startup","AllUsersStartup")

arSUFDN = Array("Startup","All Users")

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 & DQ & "Startup" & DQ

 

If flagAUSUF Then

strLine = strLine & " & " & DQ & "All Users...Startup" & DQ & " folders:"

Else

strLine = strLine & " folder:"

End If

 

Else 'all other O/S's

 

strLine = strLine & DQ & Wshso.ExpandEnvironmentStrings("%USERNAME%") &_

DQ & " & " & DQ & "All Users" & DQ & " startup folders:"

arSUFDN(0) = Wshso.ExpandEnvironmentStrings("%USERNAME%")

 

End If

 

strTitle = strLine

 

'for each startup folder name

For i = 0 To 1 '0 = user folder, 1 = All Users folder

 

strSubTitle = "" : flagFE = 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)

strSubTitle = oSUF.Path : flagFE = True

Else

strSubTitle = "WARNING! " & DQ & "All Users" & DQ &_

" startup folder not found!"

TitleLineWrite

End If 'FolderExists?

End If 'flagAUSUF?

 

Else 'all other O/S's at all times

 

On Error Resume Next

Set oSUF = Fso.GetFolder(Wshso.SpecialFolders(arSUFN(i)))

intErrNum = Err.Number : Err.Clear

On Error Goto 0

 

If intErrNum = 0 Then

strSubTitle = oSUF.Path : flagFE = True

Else 'assign title for Startup folder not found

If strOS = "W98" Or strOS = "WME" Then

strSubTitle = "WARNING! " & DQ & arSUFDN(i) & DQ &_

" folder not found!"

Else

strSubTitle = "WARNING! " & DQ & arSUFDN(i) & DQ &_

" startup folder not found!"

End If

TitleLineWrite

End If 'intErrNum=0?

 

End If 'i=1 & W98/WME?

 

'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 = DQ & Fso.GetBaseName (oSUFi.Path) & DQ & " -> URL shortcut to: " &_

DQ & oSUSC.TargetPath

 

Else

 

'prepare the shortcut file base name and the target path & arguments

strLine = DQ & Fso.GetBaseName (oSUFi.Path) & DQ & " -> shortcut to: " &_

DQ & oSUSC.TargetPath

 

If oSUSC.Arguments <> "" Then

strLine = strLine & " " & oSUSC.Arguments & DQ

Else

strLine = strLine & DQ

End If

 

'add co-name

strLine = strLine & CoName(IDExe(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 = DQ & Fso.GetBaseName(oSUFi.Path) & DQ &_

" -> PIF to: " & DQ & strPIFTgt & DQ &_

CoName(IDExe(strPIFTgt))

 

'file is neither shortcut nor PIF

Else

 

'file is probably an executable so include an IWarn and

' the file name, using the full path as IDExe argument

If LCase(Fso.GetFileName(oSUFi)) <> "desktop.ini" Then

strLine = IWarn & DQ & oSUFi.Name & DQ & CoName(IDExe(oSUFi.Path))

flagIWarn = True

End If

 

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

TitleLineWrite

 

'output the line

oFN.WriteLine strLine

 

End If

 

Next 'file in startup folder

 

Set oSUF=Nothing

 

'if ShowAll

If flagShowAll Then TitleLineWrite

 

End If 'flagFE?

 

Next 'startup folder name

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = "" : strWarn = ""

 

'recover array memory

ReDim arSUFN(0)

 

End If 'SecTest?

 

 

 

 

'#21. Enabled Scheduled Tasks

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

'Enabled Scheduled Tasks Directory/Folder object

Dim strESTDir, oESTFo

 

'prepare section title lines

strTitle = "Enabled Scheduled Tasks:"

If strOS = "WVA" Then strTitle = "Non-disabled Scheduled Tasks:"

 

If strOS <> "WVA" Then

 

' Byte Disabled Enabled

'00000030: #####1## #####0## <--

 

'file in Tasks directory

Dim oFi2

 

'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

 

TitleLineWrite

 

'write error message

oFN.WriteLine vbCRLF & DQ & oFi2.Name & DQ &_

" -- insufficient permission to read this file!"

 

End If '.JOB file opened successfully?

 

End If '.JOB file extension selected?

 

Next 'file in TASKS directory

 

'if ShowAll, output title line if not already done

If flagShowAll Then TitleLineWrite

 

Else 'Tasks directory can't be found

 

'write titles and error message

TitleLineWrite

oFN.WriteLine vbCRLF & "WARNING! The " & DQ &_

strWinDir & "\Tasks" & DQ &_

" directory cannot be found."

 

End If 'Tasks directory exists?

 

Set oJobF=Nothing

 

Else 'WVa -- Non-Disabled Scheduled Tasks

 

'initialize error array & counter

ReDim arErr(0) : ctrErr = 0 : strOut = ""

 

'fill strOut with output & arErr with (permission) errors

 

strESTDir = Wshso.ExpandEnvironmentStrings("%WINDIR%\system32\Tasks")

 

Set oESTFo = Fso.GetFolder(strESTDir)

 

'initiate recursion into ST folder to find enabled XML-format tasks

DirEST oESTFo

 

'output EST's if found

If strOut <> "" Then

TitleLineWrite : oFN.WriteLine strOut

ElseIf flagShowAll Then

TitleLineWrite

oFN.WriteLine vbCRLF & "(no enabled scheduled tasks found)"

End If

 

'output directory permission errors if ShowAll

If ctrErr > 0 And flagShowAll Then

 

strSubTitle = "Directory Permission Errors:" & vbCRLF

TitleLineWrite : strOut = ""

 

For i = 0 To UBound(arErr)

 

'limit line length to 100

If strOut <> "" Then

 

If Len(strOut & arErr(i)) >= 100 Then

oFN.WriteLine strOut : strOut = arErr(i)

Else

strOut = strOut & ", " & arErr(i)

End If 'this error & prev errors>100?

 

Else 'strOut empty

 

If Len(arErr(i)) >= 100 Then

oFN.WriteLine arErr(i)

Else

strOut = arErr(i)

End If 'this error>100?

 

End If 'strOut not empty?

 

Next 'arErr member

 

'write out final error string

If strOut <> "" Then oFN.WriteLine strOut : strOut = ""

 

End If 'show errors?

 

End If 'WVa?

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

End If 'SecTest?

 

 

 

 

'#22. Winsock2 Service Provider DLLs

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

strTitle = "Winsock2 Service Provider DLLs:"

 

Dim strNSCatKey 'NameSpace Catalog Key

Dim strProCatKey 'Protocol Catalog Key

Dim strNSSP 'NameSpace Service Provider

Dim arTSP '(returned) Transport Service Provider array

Dim int1C 'single chr binary (integer) code

 

'TSP output array for numeric keys, key #, strlen of key #, work var

Dim arTSPFi(), intKN, intL, intT

'TSP output array for alpha (illegal) keys

Dim arATSPFi()

'arTSPFi is 4 x n array

ReDim arTSPFi(3,0)

ReDim arATSPFi(1,0)

'number of numbered TSP keys

Dim intNumKeys : intNumKeys = 0

intCnt = 0 'arTSPFi UBound - 1

Dim intACnt : intACnt = 0 'arATSPFi UBound - 1

strAllOutDefault = " {++}"

 

'NameSpace Providers

 

strKey = "System\CurrentControlSet\Services\Winsock2\Parameters"

 

'find name of NameSpace Catalog key

intErrNum1 = oReg.GetStringValue (HKLM,strKey,"Current_NameSpace_Catalog",strNSCatKey)

 

'if the Current_NameSpace_Catalog name exists And value set (exc for W2K!)

If intErrNum1 = 0 And strNSCatKey <> "" Then

 

strSubTitle = "Namespace Service Providers" & vbCRLF & vbCRLF &_

SYCA("HKLM\" & strKey & "\" & strNSCatKey & "\Catalog_Entries\" &_

strAllOutDefault)

 

'find NameSpace catalog entry subkeys

oReg.EnumKey HKLM,strKey & "\" & strNSCatKey & "\Catalog_Entries",arKeys

 

'if sub-keys exist

If IsArray(arKeys) Then

 

'for each subkey

For Each oKey in arKeys

 

'find LibraryPath

intErrNum2 = oReg.GetStringValue (HKLM,strKey & "\" & strNSCatKey &_

"\Catalog_Entries\" & oKey,"LibraryPath",strNSSP)

 

'if the LibraryPath name exists And value set (exc for W2K!)

If intErrNum2 = 0 And strNSSP <> "" Then

 

TitleLineWrite

 

On Error Resume Next

oFN.WriteLine oKey & "\LibraryPath" & " = " & DQ &_

strNSSP & DQ & CoName(IDExe(strNSSP))

intErrNum3 = Err.Number : Err.Clear

On Error Goto 0

If intErrNum3 <> 0 Then oFN.WriteLine oKey & "\LibraryPath" &_

" = (value not set)"

 

End If 'LibaryPath value set?

 

Next 'subkey

 

'IsArray = True, but array is empty

If strSubTitle <> "" And flagShowAll Then

TitleLineWrite : oFN.WriteLine vbCRLF & "HKLM\" & strKey &_

"\" & strNSCatKey & "\Catalog_Entries\" & " = (sub-keys not found)"

End If

 

Else 'Catalog_Entries subkeys do not exist

 

If flagShowAll Then

TitleLineWrite : oFN.WriteLine "(sub-keys not found)"

End If

 

End If 'Catalog_Entries subkeys exist?

 

Else 'Current_NameSpace_Catalog value doesn't exist Or value not set

 

If flagShowAll Then

TitleLineWrite : oFN.WriteLine vbCRLF & SYCA("HKLM\" & strKey &_

"\Current_Namespace_Catalog = (value not found)")

End If

 

End If 'Current_NameSpace_Catalog value exists?

 

 

'Transport Service Providers (Layered Service Providers = LSP's)

 

intErrNum1 = oReg.GetStringValue (HKLM,strKey,"Current_Protocol_Catalog",strProCatKey)

 

'if the Current_Protocol_Catalog name exists And value set (exc for W2K!)

If intErrNum1 = 0 And strProCatKey <> "" Then

 

strSubTitle = "Transport Service Providers" & vbCRLF & vbCRLF &_

SYCA("HKLM\" & strKey & "\" & strProCatKey & "\Catalog_Entries\" &_

strAllOutDefault)

 

'find Protocol catalog entry subkeys

oReg.EnumKey HKLM,strKey & "\" & strProCatKey & "\Catalog_Entries",arKeys

 

'if sub-keys exist

If IsArray(arKeys) Then

 

'for each subkey

For Each oKey in arKeys

 

'can only take UBound if subkeys exist

'find number of keys in array & # digits

intNumKeys = UBound(arKeys) + 1

 

'determine # digits

intL = Len(CStr(intNumKeys))

 

'convert key name to integer

On Error Resume Next

intKN = CInt(oKey)

intErrNum = Err.Number : Err.Clear

On Error Goto 0

 

If intErrNum <> 0 Then intKN = -1 'key not in numeric format

 

'find PackedCatalogItem

intErrNum2 = oReg.GetBinaryValue (HKLM,strKey & "\" & strProCatKey &_

"\Catalog_Entries\" & oKey,"PackedCatalogItem",arTSP)

 

'if the PackedCatalogItem name exists And value set (exc for W2K!)

If intErrNum2 = 0 And IsArray(arTSP) Then

 

strDLL = "" 'clear strDLL

 

'reform strDLL from binary data array

For i = 0 To UBound(arTSP)

 

int1C = arTSP(i)

'end of target is single "0" byte

If int1C = 0 Then Exit For

'otherwise convert binary to ASCII and append to string

strDLL = strDLL & Chr(int1C)

 

Next 'binary data array element

 

'if key number numeric

If intKN <> -1 Then

 

'if file array populated

If intCnt > 0 Then

 

flagMatch = False

 

'for every arTSPFi member

For i = 0 To UBound(arTSPFi,2)

 

'if array file matches DLL, store array subscript

If arTSPFi(0,i) = strDLL Then

flagMatch = True : intSS = i : Exit For

End If

 

Next 'arTSPFi member

 

'if DLL is new

If Not flagMatch Then

 

'initialize output array for DLL

ReDim Preserve arTSPFi(3,intCnt)

arTSPFi(0,intCnt) = strDLL 'FN path\file name

arTSPFi(1,intCnt) = Right("0" & CStr(intKN),intL) 'OS output string

arTSPFi(2,intCnt) = intKN 'LA last added key number

arTSPFi(3,intCnt) = intKN 'UL upper limit key number

 

'increment output array for next pass

intCnt = intCnt + 1

 

Else 'flagMatch = True

 

'this key # consecutive to DLL UL

If intKN - arTSPFi(3,intSS) = 1 Then

 

'set DLL UL to this key #

arTSPFi(3,intSS) = intKN

 

Else 'this key # not consecutive to DLL UL

 

'if last added = upper limit, add comma and key # for new range

If arTSPFi(2,intSS) = arTSPFi(3,intSS) Then

 

arTSPFi(1,intSS) = arTSPFi(1,intSS) & ", " &_

Right("0" & CStr(intKN),intL)

arTSPFi(2,intSS) = intKN

arTSPFi(3,intSS) = intKN

 

'last added < upper limit, add hyphen, upper limit, comma and

'key # for new range

Else 'LA <> UL

 

arTSPFi(1,intSS) = arTSPFi(1,intSS) & " - " &_

Right("0" & CStr(arTSPFi(3,intSS)),intL) & ", " &_

Right("0" & CStr(intKN),intL)

arTSPFi(2,intSS) = intKN

arTSPFi(3,intSS) = intKN

 

End If 'LA = UL?

 

End If 'consecutive occurrence?

 

End If 'flagMatch?

 

Else 'intCnt = 0

 

'add first DLL to array

ReDim arTSPFi(3,intCnt)

arTSPFi(0,intCnt) = strDLL 'FN

arTSPFi(1,intCnt) = Right("0" & CStr(intKN),intL) 'OS

arTSPFi(2,intCnt) = intKN 'LA

arTSPFi(3,intCnt) = intKN 'UL

 

intCnt = intCnt + 1

 

End If 'intCnt > 0?

 

Else 'intKN not numeric

 

ReDim Preserve ATSPFi(1,intACnt)

arATSPFi(0,intACnt) = oKey

arATSPFi(1,intACnt) = strDLL

intACnt = intACnt + 1

 

End If 'intKN numeric?

 

End If 'PackedCatalogItem value exists?

 

Next 'subkey

 

 

'output results

 

'if Catalog_Entries sub-keys exist

If intNumKeys > 0 Then

 

'finalize output strings

For i = 0 To UBound(arTSPFi,2)

 

'last added < upper limit, add upper limit

If arTSPFi(2,i) < arTSPFi(3,i) Then

 

arTSPFi(1,i) = arTSPFi(1,i) & " - " & Right("0" & arTSPFi(3,i),intL)

 

End If 'LA = UL?

 

Next 'TSP array member

 

TitleLineWrite

 

'write out non-numeric sub-keys

If intACnt > 0 Then

 

For i = 0 To UBound(arATSPFi,2)

 

oFN.WriteLine vbCRLF & arATSPFi(0,i) & " = " & DQ &_

arATSPFi(1,i) & DQ & CoName(IDExe(arATSPFi(1,i))) & vbCRLF

 

Next

 

End If 'non-numeric sub-keys exist?

 

'write out numeric sub-keys

 

'0000000000##\PackedCatalogItem contains (DLL [Company Name], ##):

'%SystemRoot%\system32\xxxxxx.dll [CN] ##-##, ##-##

'%SystemRoot%\system32\yyyyyy.dll [CN] ##-##

 

oFN.WriteLine String(12-intL,"0") &_

String(intL,"#") & "\PackedCatalogItem (contains) DLL " &_

"[Company Name], (at) " & String(intL,"#") & " range:"

 

For i = 0 To UBound(arTSPFi,2)

 

oFN.WriteLine arTSPFi(0,i) & CoName(IDExe(arTSPFi(0,i))) & ", " &_

arTSPFi(1,i)

 

Next

 

Else 'intNumKeys=0 (no Catalog_Entries sub-keys)

 

If flagShowAll Then

TitleLineWrite : oFN.WriteLine "(sub-keys not found)"

End If

 

End If 'arKeys subkeys exist?

 

Else 'Catalog_Entries sub-keys do not exist

 

If flagShowAll Then

TitleLineWrite : oFN.WriteLine "(sub-keys not found)"

End If

 

End If 'Catalog_Entries array exists?

 

Else 'Current_Protocol_Catalog name doesn't exist Or value not set

 

If flagShowAll Then

TitleLineWrite : oFN.WriteLine vbCRLF & SYCA("HKLM\" & strKey &_

"\Current_Protocol_Catalog = (value not found)")

End If

 

End If 'Current_Protocol_Catalog value exists?

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

'recover array memory

ReDim arTSPFi(0)

ReDim arATSPFi(0)

 

End If 'SecTest?

 

 

 

 

'#23. Internet Explorer Toolbars, Explorer Bars, Extensions

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

strTitle = "Toolbars, Explorer Bars, Extensions:"

 

'HKCU/HKLM Explorer Bars, combined array of existing explorer bars

Dim arHKExplorerBars(), arListedExplorerBars()

Dim arAllowedExplorerBars() 'allowed explorer bars

Dim strHKExplorerBar 'single explorer bar

'all CLSIDs, CLSID\Implemented Categories sub-keys, single CLSID, single Impl Cat sub-key

Dim arCLSIDKeys(), arCLSIDImpCatSubKey(), strImpCatSubKey

'count of HKCU/HKLM explorer bars needed for ReDim statement

Dim cntExplorerBars : cntExplorerBars = 0

Dim arHKExtensions() 'HKCU/HKLM extension keys

Dim arAllowedExtensions() 'allowed extensions

Dim strHKExtension 'single extension key name

Dim arAllowedToolbars() 'allowed toolbars

Dim strHKToolbar 'single toolbar value name

Dim arHKCUTbSK() 'HKCU toolbar sub-keys

Dim strSKName 'single toolbar subkey name

Dim arSKValName() 'toolbar sub-key value names

Dim arHKToolbarVals() 'toolbar value names

Dim flagTBTLW : flagTBTLW = False 'toolbar title lines

 

 

'Toolbars

 

strSubTitle = "Toolbars"

 

ReDim arAllowedToolbars(4) 'must be in upper case!

arAllowedToolbars(0) = "{01E04581-4EEE-11D0-BFE9-00AA005B4383}" '&Address

arAllowedToolbars(1) = "{0E5CBF21-D15F-11D0-8301-00AA005B4383}" '&Links

arAllowedToolbars(2) = "{1E796980-9CC5-11D1-A83F-00C04FC99D61}" 'displayed toolbar buttons (non-CLSID)

arAllowedToolbars(3) = "{710EB7A1-45ED-11D0-924A-0020AFC7AC4D}" 'unknown default (non-CLSID)

arAllowedToolbars(4) = "{8E718888-423F-11D2-876E-00A0C9082467}" '... &Radio

 

strKey = "Software\Microsoft\Internet Explorer\Toolbar"

 

'for HKCU & HKLM hives

For i = 0 To 1

 

strSubSubTitle = SOCA(arHives(i,0) & "\" & strKey & "\")

 

'get toolbar key values

oReg.EnumValues arHives(i,1),strKey,arHKToolbarVals,arType

 

'if values exist

If IsArray(arHKToolbarVals) Then

 

'for each value

For Each strCLSID in arHKToolbarVals

 

'change to UCase

strCLSID = Trim(UCase(strCLSID))

 

'assume not on allowed list

flagAllow = False

 

'is Toolbar on allowed list?

For j = 0 To UBound(arAllowedToolbars)

If arAllowedToolbars(j) = UCase(strCLSID) Then

flagAllow = True : Exit For 'toggle allowed flag

End If

Next

 

'if not allowed Or ShowAll

If Not flagAllow Or flagShowAll Then

 

flagTitle = False

 

CLSIDLocTitle arHives(i,1), strKey, strCLSID, strLocTitle

 

For ctrCH = intCLL To 1

 

ResolveCLSID strCLSID, arHives(ctrCH,1), strCLSIDTitle, strIPSDLL

 

If strIPSDLL <> "" Then 'IPS exists?

 

If Not flagTitle Then

 

'output toolbar CLSID value name

On Error Resume Next

If strSubSubTitle <> "" Then

TitleLineWrite : oFN.WriteLine DQ & strCLSID & DQ &_

" = " & strLocTitle

intErrNum = Err.Number : Err.Clear

If intErrNum <> 0 Then oFN.WriteLine DQ & strCLSID & DQ &_

" = (no title provided)"

Else

oFN.WriteLine DQ & strCLSID & DQ & " = " & strLocTitle

intErrNum = Err.Number : Err.Clear

If intErrNum <> 0 Then oFN.WriteLine DQ & strCLSID & DQ &_

" = (no title provided)"

End If

flagTitle = True

On Error Goto 0

 

End If

 

'output InProcServer32 value

oFN.WriteLine " -> {" & arHives(ctrCH,0) & "...CLSID} = " &_

strCLSIDTitle & vbCRLF & Space(19) & "\InProcServer32\(Default) = " &_

StringFilter(strIPSDLL,True) & CoName(IDExe(strIPSDLL))

 

End If 'strIPSDLL <> ""?

 

Next 'CLSID hive

 

End If 'flagAllow Or ShowAll?

 

Next 'HKCU/HKLM toolbar key value

 

End If 'toolbar key has values

 

'for HKCU Toolbar key only

If arHives(i,0) = "HKCU" Then

 

'get HKCU toolbar subkeys

oReg.EnumKey HKCU,strKey,arHKCUTbSK

 

'if key array exists

If IsArray(arHKCUTbSK) Then

 

'for each sub-key

For Each strSKName in arHKCUTbSK

 

strSubSubTitle = "HKCU\" & strKey & "\" & strSKName & "\"

 

'if one of three targeted sub-keys

If LCase(strSKName) = "explorer" Or LCase(strSKName) = "shellbrowser" Or _

LCase(strSKName) = "webbrowser" Then

 

'get toolbar subkey values

oReg.EnumValues HKCU,strKey & "\" & strSKName,arSKValName,arType

 

'if array of values exists

If IsArray(arSKValName) Then

 

'for each value

For Each strValue in arSKValName

 

'assume not on allowed list

flagAllow = False

 

'is Toolbar on allowed list?

For j = 0 To UBound(arAllowedToolbars)

If arAllowedToolbars(j) = UCase(strValue) Then

flagAllow = True : Exit For 'toggle allowed flag

End If

Next

 

'if not allowed Or ShowAll

If Not flagAllow Or flagShowAll Then

 

flagTitle = False

 

For ctrCH = intCLL To 1

 

ResolveCLSID strValue, arHives(ctrCH,1), strCLSIDTitle, strIPSDLL

 

'if InProcServer32 value exists

If strIPSDLL <> "" Then

 

'output toolbar CLSID

If strSubSubTitle <> "" Then TitleLineWrite

If Not flagTitle Then

oFN.WriteLine DQ & strValue & DQ : flagTitle = True

End If

oFN.WriteLine " -> {" & arHives(ctrCH,0) & "...CLSID} = " &_

strCLSIDTitle & vbCRLF & Space(19) & "\InProcServer32\(Default) = " &_

StringFilter(strIPSDLL,True) & CoName(IDExe(strIPSDLL))

 

End If 'IPS exists?

 

Next

 

End If 'flagAllow Or ShowAll?

 

Next 'strValue

 

End If 'IsArray(arSKValName)?

 

End If 'targeted sub-key

 

Next 'toolbar sub-key

 

End If 'toolbar sub-key array exists

 

End If 'HKCU hive?

 

'if ShowAll, output title lines if not already done

If flagShowAll Then TitleLineWrite

 

Next 'hive

 

 

'Explorer Bars

 

strSubTitle = "Explorer Bars"

 

ReDim arAllowedExplorerBars(9) 'must be in upper case!

arAllowedExplorerBars(0) = "{30D02401-6A81-11D0-8274-00C04FD5AE38}" 'Search Band

arAllowedExplorerBars(1) = "{32683183-48A0-441B-A342-7C2A440A9478}" 'Media Band

arAllowedExplorerBars(2) = "{4D5C8C25-D075-11D0-B416-00C04FB90376}" '&Tip of the Day

arAllowedExplorerBars(3) = "{BDEADE7F-C265-11D0-BCED-00A0C90AB50F}" '&Discuss

arAllowedExplorerBars(4) = "{C4EE31F3-4768-11D2-BE5C-00A0C9A83DA1}" 'File and Folders Search ActiveX Control

arAllowedExplorerBars(5) = "{EFA24E61-B078-11D0-89E4-00C04FC9E26E}" 'Favorites Band

arAllowedExplorerBars(6) = "{EFA24E62-B078-11D0-89E4-00C04FC9E26E}" 'History Band

arAllowedExplorerBars(7) = "{EFA24E64-B078-11D0-89E4-00C04FC9E26E}" 'Explorer Band

arAllowedExplorerBars(8) = "{21569614-B795-46B1-85F4-E737A8DC09AD}" 'Search Band (WVa)

arAllowedExplorerBars(9) = "{5D60981B-2654-09E1-085A-6B546CA52169}" 'Favories Band (W98)

 

strKey = "Software\Microsoft\Internet Explorer\Explorer Bars"

 

'for HKCU & HKLM hives

For i = 0 To 1

 

strSubSubTitle = SOCA(arHives(i,0) & "\" & strKey & "\")

 

'get explorer bar subkeys

oReg.EnumKey arHives(i,1),strKey,arHKExplorerBars

 

'if subkeys exist

If IsArray(arHKExplorerBars) Then

 

'for each subkey

For Each strHKExplorerBar in arHKExplorerBars

 

'convert subkey name (CLSID) to uppercase

strHKExplorerBar= UCase(strHKExplorerBar)

 

'assume not on allowed list

flagAllow = False

 

'add to ListedExplorerBars array

ReDim Preserve arListedExplorerBars(cntExplorerBars)

arListedExplorerBars(cntExplorerBars) = strHKExplorerBar

cntExplorerBars = cntExplorerBars + 1 'cnt = UBound + 1

 

'is Explorer Bar on allowed list?

For j = 0 To UBound(arAllowedExplorerBars)

If arAllowedExplorerBars(j) = UCase(strHKExplorerBar) Then

flagAllow = True : Exit For 'toggle allowed flag

End If

Next

 

'if not allowed Or ShowAll

If Not flagAllow Or flagShowAll Then

 

flagTitle = False

 

CLSIDLocTitle arHives(i,1), strKey, strHKExplorerBar, strLocTitle

 

For ctrCH = intCLL To 1

 

ResolveCLSID strHKExplorerBar, arHives(ctrCH,1), strCLSIDTitle, strIPSDLL

 

'if InProcServer32 value exists

If strIPSDLL <> "" Then

 

'output explorer bar CLSID

If strSubSubTitle <> "" Then TitleLineWrite

 

If Not flagTitle Then

oFN.WriteLine strHKExplorerBar & "\(Default) = " & strLocTitle

flagTitle = True

End If

 

'output InProcServer32 value

oFN.WriteLine " -> {" & arHives(ctrCH,0) & "...CLSID} = " &_

strCLSIDTitle & vbCRLF & Space(19) & "\InProcServer32\(Default) = " &_

StringFilter(strIPSDLL,True) & CoName(IDExe(strIPSDLL))

 

End If 'IPS exists?

 

Next

 

End If 'not on allowed list Or ShowAll

 

Next 'HKCU/HKLM explorer bar subkey

 

End If 'explorer bar key has subkeys

 

'if ShowAll, output sub-title lines if not already done

If flagShowAll Then TitleLineWrite

 

Next 'hive

 

 

'check CLSIDs for Explorer Bars

 

Dim datDEBStart : datDEBStart = Now

 

strKey = "Software\Classes\CLSID"

 

For ctrCH = intCLL To 1

 

'get CLSIDs

oReg.EnumKey arHives(ctrCH,1),strKey,arCLSIDKeys

 

If IsArray(arCLSIDKeys) Then

 

'for each CLSID

For Each strCLSIDKey in arCLSIDKeys

 

'convert to uppercase

strCLSIDKey = UCase(strCLSIDKey)

 

'look for Implemented Categories subkeys

intErrNum = oReg.EnumKey (arHives(ctrCH,1),strKey & "\" & strCLSIDKey &_

"\Implemented Categories",arCLSIDImpCatSubKey)

 

'if Implemented Categories subkeys exist

If intErrNum = 0 And IsArray(arCLSIDImpCatSubKey) Then

 

'for each Implemented Categories subkey

For Each strImpCatSubKey in arCLSIDImpCatSubKey

 

'convert to uppercase

strImpCatSubKey = UCase(strImpCatSubKey)

 

'if subkey name is vertical or horizontal explorer bar

If strImpCatSubKey = "{00021494-0000-0000-C000-000000000046}" Or _

strImpCatSubKey = "{00021493-0000-0000-C000-000000000046}" Then

 

flagFound = False 'assume CLSID is not listed in HKCU/HKLM explorer bars

 

If IsArray(arListedExplorerBars) Then

 

'search explorer bar array for CLSID

For Each strArMember in arListedExplorerBars

If strArMember = strCLSIDKey Then

flagFound = True : Exit For

End If

Next

 

End If 'IsArray(arListedExplorerBars)?

 

'if CLSID not listed

If Not flagFound Then

 

'assume not allowed

flagAllow = False

 

'see if on allowed list

For j = 0 To UBound(arAllowedExplorerBars)

If arAllowedExplorerBars(j) = UCase(strCLSIDKey) Then

flagAllow = True : Exit For

End If

Next

 

'if not allowed Or ShowAll

If Not flagAllow Or flagShowAll Then

 

'look for InProcServer32

intErrNum3 = oReg.GetExpandedStringValue(arHives(ctrCH,1),"Software\Classes\CLSID\" &_

strCLSIDKey & "\InProcServer32","",strValue3)

 

'if InProcServer32 value exists

If intErrNum3 = 0 And strValue3 <> "" Then

 

'get CLSID title

oReg.GetStringValue arHives(ctrCH,1),"Software\Classes\CLSID\" &_

strCLSIDKey,"",strValue4

 

TitleLineWrite

 

'output CLSID + title, prepare output string,

'output Implemented Categories key, InProcServer32

If strValue4 <> "" Then

oFN.WriteLine vbCRLF & SOCA(arHives(ctrCH,0) & "\Software\Classes\CLSID\") &_

strCLSIDKey & "\(Default) = " & StringFilter(strValue4,True)

Else

oFN.WriteLine vbCRLF & SOCA(arHives(ctrCH,0) & "\Software\Classes\CLSID\") &_

strCLSIDKey & "\(Default) = (title not found)"

End If

If Mid(strImpCatSubKey,9,1) = "3" Then

strOut = " [vertical bar]"

Else

strOut = " [horizontal bar]"

End If

oFN.WriteLine "Implemented Categories\" & strImpCatSubKey & "\" & strOut

oFN.WriteLine "InProcServer32\(Default) = " &_

DQ & strvalue3 & DQ & CoName(IDExe(strValue3))

 

End If 'CLSID InProcServer32 exists?

 

End If 'CLSID not allowed Or ShowAll?

 

End If 'CLSID not already found in HKCU/HKLM?

 

End If 'strImpCatSubKey designates scroll bar?

 

Next 'arCLSIDImpCatSubKey

 

End If 'Implemented Categories sub-key exists?

 

Next 'CLSID sub-key

 

End If 'CLSID array exists?

 

Next 'CLSID hive

 

'determine -supp seconds used

Dim strDEBTime : strDEBTime = DateDiff("s",datDEBStart,Now) & " seconds"

 

 

 

 

'Extensions (Tools menu items, toolbar buttons)

 

strSubTitle = "Extensions (Tools menu items, main toolbar menu buttons)"

 

ReDim arAllowedExtensions(4) 'must be in upper case!

arAllowedExtensions(0) = "{438AFBA1-B0CB-11D2-9214-00104B3BCE5F}" '&Document Tree

arAllowedExtensions(1) = "{B06300D0-CCDE-11D2-92D3-0000F87A4A55}" 'Add to R&estricted Zone

arAllowedExtensions(2) = "{BF80219A-CCDD-11D2-92D3-0000F87A4A55}" 'Add to Tr&usted Zone

arAllowedExtensions(3) = "{C95FE080-8F5D-11D2-A20B-00AA003C157A}" 'Show &Related Links

arAllowedExtensions(4) = "{FC09D8A3-C85A-11D2-92D0-0000F87A4A55}" 'Offline

'{FB5F1910-F110-11D2-BB9E-00C04F795683} MSN Messenger Service

 

strKey = "Software\Microsoft\Internet Explorer\Extensions"

 

'for HKCU & HKLM hives

For i = 0 To 1

 

strSubSubTitle = SOCA(arHives(i,0) & "\" & strKey & "\")

 

'get extension subkeys

oReg.EnumKey arHives(i,1),strKey,arHKExtensions

 

'if subkeys exist

If IsArray(arHKExtensions) Then

 

'for each subkey

For Each strHKExtension in arHKExtensions

 

If Len(strHKExtension) = 38 And Left(strHKExtension,1) = "{" And _

Right(strHKExtension,1) = "}" Then

 

'convert subkey name (CLSID) to uppercase

strHKExtension= UCase(strHKExtension)

 

'assume not on allowed list

flagAllow = False

 

'is Extension on allowed list?

For j = 0 To UBound(arAllowedExtensions)

If arAllowedExtensions(j) = UCase(strHKExtension) Then

flagAllow = True : Exit For 'toggle allowed flag

End If

Next

 

'if not allowed Or ShowAll

If Not flagAllow Or flagShowAll Then

 

'look for ButtonText/MenuText/CLSIDExtension/Exec values

intErrNum1 = oReg.GetStringValue(arHives(i,1),strKey & "\" &_

strHKExtension,"ButtonText",strValue1)

intErrNum2 = oReg.GetStringValue(arHives(i,1),strKey & "\" &_

strHKExtension,"MenuText",strValue2)

intErrNum3 = oReg.GetStringValue(arHives(i,1),strKey & "\" &_

strHKExtension,"CLSIDExtension",strValue3)

intErrNum4 = oReg.GetStringValue(arHives(i,1),strKey &_

"\" & strHKExtension,"Script",strValue4)

intErrNum5 = oReg.GetStringValue(arHives(i,1),strKey &_

"\" & strHKExtension,"Exec",strValue5)

 

If strSubSubTitle <> "" Then

TitleLineWrite : oFN.WriteLine strHKExtension & "\"

Else

oFN.WriteLine vbCRLF & strHKExtension & "\"

End If

 

'most output is optional (on error, do nothing)

On Error Resume Next

If intErrNum1 = 0 And strValue1 <> "" Then _

oFN.WriteLine DQ & "ButtonText" & DQ & " = " &_

DQ & strValue1 & DQ

If intErrNum2 = 0 And strValue2 <> "" Then _

oFN.WriteLine DQ & "MenuText" & DQ & " = " & DQ &_

strValue2 & DQ

 

If intErrNum3 = 0 And strValue3 <> "" Then

 

Err.Clear 'required to reset Err if ButtonText or MenuText missing

 

flagTitle = False

For ctrCH = intCLL To 1

 

ResolveCLSID strValue3, arHives(ctrCH,1), strCLSIDTitle, strValue6

 

If Not flagTitle Then

oFN.WriteLine DQ & "CLSIDExtension" & DQ & " = " &_

DQ & strValue3 & DQ

flagTitle = True

End If

 

If strValue6 <> "" Then

oFN.WriteLine " -> {" & arHives(ctrCH,0) & "...CLSID} = " &_

strCLSIDTitle & vbCRLF & Space(19) & "\InProcServer32\(Default) = " &_

StringFilter(strValue6,True) & CoName(IDExe(strValue6))

End If

 

Next 'CLSID hive

 

End If 'CLSIDExtension value exists

 

If intErrNum4 = 0 And strValue4 <> "" Then oFN.WriteLine DQ &_

"Script" & DQ & " = " & DQ & strValue4 & DQ &_

CoName(IDExe(strValue4))

If intErrNum5 = 0 And strValue5 <> "" Then oFN.WriteLine DQ &_

"Exec" & DQ & " = " & DQ & strValue5 & DQ &_

CoName(IDExe(strValue5))

Err.Clear

On Error Goto 0

 

End If 'flagAllow Or flagAll?

 

End If 'CLSID format?

 

Next 'Extension subkey

 

End If 'Extension subkeys exist

 

'if ShowAll, output sub-title lines if not already done

If flagShowAll Then TitleLineWrite

 

Next 'hive

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

'recover array memory

ReDim arCLSIDKeys(0)

ReDim arCLSIDImpCatSubKey(0)

ReDim arExplorerBars(0)

ReDim arAllowedExplorerBars(0)

ReDim arListedExplorerBars(0)

ReDim arHKExtensions(0)

ReDim arAllowedExtensions(0)

ReDim arAllowedToolbars(0)

ReDim arHKCUTbSK(0)

ReDim arSKValName(0)

ReDim arHKToolbarVals(0)

 

End If 'SecTest?

 

 

 

 

'#24. Internet Explorer URL Prefixes

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

strTitle = "Internet Explorer Address Prefixes:"

 

'prefix used if bare domain ("microsoft.com") entered into IE address box

strKey = "Software\Microsoft\Windows\CurrentVersion\URL"

 

strSubTitle = "Prefix for bare domain (" & DQ &_

"domain-name-here.com" & DQ & ")" & vbCRLF & vbCRLF &_

SOCA("HKLM\" & strKey & "\Default Prefix\")

 

'get DefaultPrefix default value

intErrNum = oReg.GetStringValue (HKLM,strKey & "\DefaultPrefix","",strValue)

 

'assume not infected

strWarn = ""

 

'value exists and is not empty

If intErrNum = 0 And strValue <> "" Then

 

'if default value not OK, toggle warning & flagHWarn

If Trim(LCase(strValue)) <> "http://" Then

strWarn = HWarn : flagHWarn = True

End If

 

If strWarn <> "" Or flagShowAll Then

 

TitleLineWrite : oFN.Writeline strWarn & "(Default) = " &_

StringFilter(strValue,True)

 

End If

 

Else 'value doesn't exist

 

If flagShowAll Then

TitleLineWrite

oFN.WriteLine "(Default) = (value not set)"

End If

 

End If 'default value exists?

 

 

'prefix used with specific service

'2 x 5 array

Dim arPrefix()

ReDim arPrefix(1,4)

arPrefix(0,0) = "ftp" : arPrefix(1,0) = "ftp://"

arPrefix(0,1) = "gopher" : arPrefix(1,1) = "gopher://"

arPrefix(0,2) = "home" : arPrefix(1,2) = "http://"

arPrefix(0,3) = "mosaic" : arPrefix(1,3) = "http://"

arPrefix(0,4) = "www" : arPrefix(1,4) = "http://"

 

'find all the names in the key

intErrNum1 = oReg.EnumValues (HKLM, strKey & "\Prefixes", arNames, arType)

 

strSubTitle = "Prefix for specific service (i.e., " & DQ & "www" &_

DQ & ")" & vbCRLF & vbCRLF & SOCA("HKLM\" & strKey & "\Prefixes\")

 

'enumerate data if present

If intErrNum1 = 0 And IsArray(arNames) Then

 

'for each name

For Each strName in arNames

 

'assume infected

flagMatch = False : strWarn = HWarn

 

'for each prefix type

For i = 0 To UBound(arPrefix,2)

 

'if name = prefix Or name = prefix.

If Trim(LCase(strName)) = arPrefix(0,i) Or _

Trim(LCase(strName)) = arPrefix(0,i) & "." Then

 

'get value

intErrNum2 = oReg.GetStringValue(HKLM,strKey & "\Prefixes", _

strName,strValue)

 

'if value exists (exc. for W2K!)

If intErrNum2 = 0 And strValue <> "" Then

 

'toggle flags if value = default value

If Trim(LCase(strValue)) = arPrefix(1,i) Then

flagMatch = True : strWarn = "" : Exit For

End If 'value = arPrefix member?

 

End If 'strValue exists And not empty?

 

End If 'name = arPrefix member?

 

Next 'arPrefix member

 

'get value if name not in arPrefix

If Not flagMatch Then oReg.GetStringValue HKLM, _

strKey & "\Prefixes",strName,strValue

 

'output if flagMatch Or flagShowAll

If Not flagMatch Or flagShowAll Then

 

TitleLineWrite

 

If strWarn <> "" Then flagHWarn = True

 

On Error Resume Next

 

'output warning, name, value

oFN.WriteLine strWarn & StringFilter(strName,True) & " = " &_

DQ & strValue & DQ

intErrNum = Err.Number : Err.Clear

'error check for W2K if value not set

If intErrNum <> 0 Then oFN.WriteLine StringFilter(strName,True) &_

" = (value not set)"

 

On Error Goto 0

 

End If 'flagMatch or flagShowAll?

 

Next 'prefix key name array member

 

If strSubTitle <> "" And flagShowAll Then

TitleLineWrite : oFN.WriteLine "(values not found)"

End If

 

Else 'prefix key name array doesn't exist

 

If flagShowAll Then

TitleLineWrite : oFN.WriteLine "(values not found)"

End If

 

End If 'prefix key name array exists

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

'recover array memory

ReDim arPrefix(0,0)

 

End If 'SecTest?

 

 

 

 

'#25. Misc. IE Hijack Points

 

intSection = intSection + 1

 

'execute section if not in testing mode or (in testing mode And this section selected for testing)

If Not flagTest Or (flagTest And SecTest) Then

 

'IERESET Text File, IERESET file name, INF-file section name,

'array of count of missing phrase lines by section

Dim oIERTF, strSection, arSectionCount(), intTFF

Dim intAsc1Chr, intAsc2Chr 'ASCII code of 1st & 2nd chr of IERESET.INF

'zero-based number of sections in phrase array with lines missing from disk file

Public intSectionCount : intSectionCount = -1

'one-based number of lines in each section of phrase array with lines missing from disk file

Public intSectionLineCount : intSectionLineCount = 0

 

strTitle = "Miscellaneous IE Hijack Points"

strWarn = HWarn

 

'parse IERESET.INF, look for added and missing lines

Dim strIERFN : strIERFN = UCase(strFPWF) & "\INF\IERESET.INF"

 

'read the IE version from the registry

 

'IE version reg value, work string

Dim strIELVer, strIELVWK

'short string version, non-numeric if dec symbol not "."

Dim strIEShVer : strIEShVer = "0"

'numeric IE version: 0 if IE version not in registry or value not set

'otherwise, number using single local dec symbol

Dim intIELVer : intIELVer = 0

Dim strDecSym : strDecSym = "." 'dec symbol

 

strKey = "Software\Microsoft\Internet Explorer"

intErrNum = oReg.GetStringValue(HKLM,strKey,"Version",strIELVer)

 

strSubTitle = SOCA("HKLM\" & strKey & "\Version = " & strIELVer)

strSubSubTitle = strIERFN & " (used to " & DQ & "Reset Web " &_

"Settings" & DQ & ")"

 

'in W2K, if value not set, strIELVer will be garbage

If intErrNum = 0 And Len(Trim(strIELVer)) > 3 Then

 

'read the decimal symbol from the registry

strKey1 = "Control Panel\International"

intErrNum1 = oReg.GetStringValue(HKCU,strKey1,"sDecimal",strValue1)

'if the symbol exists, store it

If intErrNum1 = 0 And strValue1 <> "" Then strDecSym = strValue1

 

'replace 1st dec pt in the IE ver with XXX

strIELVWK = Replace (Trim(strIELVer),".","XXX",1,1,1)

'delete all succeeding dec pts

strIELVWK = Replace (Trim(strIELVWK),".","",1,-1,1)

'restore dec symbol to pos'n of first dec pt and call it an integer

intIELVer = Replace (Trim(strIELVWK),"XXX",strDecSym,1,1,1)

 

If IsNumeric(intIELVer) Then 'should exclude W2K value not set garbage

 

strIEShVer = Left(LTrim(strIELVer),3)

 

If strIEShVer <> "5.5" Then 'for 5.5, retain 3 chrs

 

'use left-most chr

strIEShVer = Left(LTrim(strIELVer),1)

 

'if IE ver < 5, advise that INF file doesn't exist

If intIELVer < 5 Then

TitleLineWrite

oFN.WriteLine vbCRLF & "IERESET.INF does not exist for this Internet " &_

"Explorer version."

End If 'intIELVer<5?

 

End If 'strIEShVer=5.5?

 

Else 'intIELVer not numeric, so advise about bad IE version and reset to 0

 

strSubTitle = "HKLM\" & strKey & "\Version = (invalid data)" &_

vbCRLF & "The Internet Explorer version cannot be found!"

TitleLineWrite

oFN.WriteLine "The contents of IERESET.INF cannot be reliably checked!"

intIELVer = 0

 

End If 'intIELVer numeric?

 

Else 'IE ver not found or value corrupt

 

strSubTitle = SOCA("HKLM\" & strKey & "\Version = (invalid data)" &_

vbCRLF & "The Internet Explorer version cannot be found!")

TitleLineWrite

oFN.WriteLine "The contents of IERESET.INF cannot be reliably checked!"

 

End If 'IE ver exists?

 

'change titles if not already written

If strTitle <> "" Then

strSubTitle = strIERFN & " (used to " & DQ & "Reset Web Settings" &_

DQ & ")"

strSubSubTitle = ""

End If

 

If strIEShVer <> "7" Then 'IE 7

 

Dim arIER() 'common IERESET.INF lines & phrases

ReDim arIER(31,2) 'section, phrase, found-in-file-on-disk?

arIER(0,0)="[Version]" : arIER(0,1)="Signature=""$CHICAGO$"""

arIER(1,0)="[Version]" : arIER(1,1)="AdvancedINF=2.5,""You need a new version of advpack.dll"""

arIER(2,0)="[RestoreHomePage]" : arIER(2,1)="AddReg=RestoreHomePage.reg"

arIER(3,0)="[RestoreHomePage.reg]" : arIER(3,1)="HKCU,""Software\Microsoft\Internet Explorer\Main"",""Start Page"",0,%START_PAGE_URL%"

arIER(4,0)="[RestoreBrowserSettings.reg]" : arIER(4,1)="HKLM,""Software\Microsoft\Internet Explorer\Main"",""Default_Page_URL"",0,%START_PAGE_URL%"

arIER(5,0)="[RestoreBrowserSettings.reg]" : arIER(5,1)="HKLM,""Software\Microsoft\Internet Explorer\Main"",""Default_Search_URL"",0,%SEARCH_PAGE_URL%"

arIER(6,0)="[RestoreBrowserSettings.reg]" : arIER(6,1)="HKLM,""Software\Microsoft\Internet Explorer\Main"",""Search Page"",0,%SEARCH_PAGE_URL%"

arIER(7,0)="[RestoreBrowserSettings.reg]" : arIER(7,1)="HKLM,""Software\Microsoft\Internet Explorer\Main\UrlTemplate"",""1"",0,""www.%s.com"""

arIER(8,0)="[RestoreBrowserSettings.reg]" : arIER(8,1)="HKLM,""Software\Microsoft\Internet Explorer\Main\UrlTemplate"",""2"",0,""www.%s.org"""

arIER(9,0)="[RestoreBrowserSettings.reg]" : arIER(9,1)="HKLM,""Software\Microsoft\Internet Explorer\Main\UrlTemplate"",""3"",0,""www.%s.net"""

arIER(10,0)="[RestoreBrowserSettings.reg]" : arIER(10,1)="HKLM,""Software\Microsoft\Internet Explorer\Main\UrlTemplate"",""4"",0,""www.%s.edu"""

arIER(11,0)="[RestoreBrowserSettings.reg]" : arIER(11,1)="HKCU,""Software\Microsoft\Internet Explorer\Main"",""Search Page"",0,%SEARCH_PAGE_URL%"

arIER(12,0)="[RestoreBrowserSettings.reg]" : arIER(12,1)="HKCU,""Software\Microsoft\Internet Explorer\SearchUrl"",""Provider"",0,"""""

arIER(13,0)="[RestoreBrowserSettings.reg]" : arIER(13,1)="HKLM,""Software\Microsoft\Internet Explorer\Search"",""SearchAssistant"",0,""http://ie.search.msn.com/{SUB_RFC1766}/srchasst/srchasst.htm"""

arIER(14,0)="[RestoreBrowserSettings.reg]" : arIER(14,1)="HKLM,""Software\Microsoft\Internet Explorer\Search"",""CustomizeSearch"",0,""http://ie.search.msn.com/{SUB_RFC1766}/srchasst/srchcust.htm"""

arIER(15,0)="[RestoreBrowserSettings.reg]" : arIER(15,1)="HKLM,""Software\Microsoft\Windows\CurrentVersion\Internet Settings\SafeSites"",%SAFESITE_VALUE%,0,""http://ie.search.msn.com/*"""

arIER(16,0)="[DeleteTemplates.reg]" : arIER(16,1)="HKLM,""Software\Microsoft\Internet Explorer\Main\UrlTemplate"",""5"""

arIER(17,0)="[DeleteTemplates.reg]" : arIER(17,1)="HKLM,""Software\Microsoft\Internet Explorer\Main\UrlTemplate"",""6"""

arIER(18,0)="[DeleteTemplates.reg]" : arIER(18,1)="HKLM,""Software\Microsoft\Internet Explorer\Main\UrlTemplate"",""7"""

arIER(19,0)="[DeleteTemplates.reg]" : arIER(19,1)="HKLM,""Software\Microsoft\Internet Explorer\Main\UrlTemplate"",""8"""

arIER(20,0)="[DeleteTemplates.reg]" : arIER(20,1)="HKLM,""Software\Microsoft\Internet Explorer\Main\UrlTemplate"",""9"""

arIER(21,0)="[DeleteAutosearch.reg]" : arIER(21,1)="HKCU,""Software\Microsoft\Internet Explorer\Main"",""AutoSearch"""

arIER(22,0)="[strings]" : arIER(22,1)="SEARCH_PAGE_URL=""http://www.microsoft.com/isapi/redir.dll?prd=ie&ar=iesearch"""

arIER(23,0)="[RestoreBrowserSettings]" : arIER(23,1)="AddReg=RestoreBrowserSettings.reg"

 

arIER(24,0)="[RestoreBrowserSettings]" : arIER(24,1)="DelReg=DeleteTemplates.reg"

arIER(25,0)="[RestoreBrowserSettings]" : arIER(25,1)="DelReg=DeleteTemplates.reg, DeleteAutosearch.reg"

arIER(26,0)="[strings]" : arIER(26,1)="START_PAGE_URL=""http://www.microsoft.com/isapi/redir.dll?prd=ie&pver=" & strIEShVer & "&ar=msnhome"""

arIER(27,0)="[strings]" : arIER(27,1)="START_PAGE_URL=""http://www.msn.com"""

arIER(28,0)="[strings]" : arIER(28,1)="SAFESITE_VALUE=""http://home.microsoft.com/"""

arIER(29,0)="[strings]" : arIER(29,1)="SAFESITE_VALUE=""ie.search.msn.com"""

arIER(30,0)="[strings]" : arIER(30,1)="MS_START_PAGE_URL=""http://www.microsoft.com/isapi/redir.dll?prd=ie&pver=" & strIEShVer & "&ar=msnhome"""

arIER(31,0)="[strings]" : arIER(31,1)="MS_START_PAGE_URL=""http://www.msn.com"""

 

'set found-in-file-on-disk flag to False

For i = 0 To UBound(arIER,1) : arIER(i,2) = False : Next

 

'if IERESET.INF exists

If Fso.FileExists(strIERFN) Then

 

'open the file for reading/don't create/ASCII format

Set oIERTF = Fso.OpenTextFile (strIERFN,1,False,0)

 

'get the file size

Dim intFileSize : intFileSize = Fso.GetFile(strIERFN).Size

 

If intFileSize > 100 Then

 

'read 1st 2 chrs, find Asc code (not AscW code)

intAsc1Chr = Asc(oIERTF.Read(1)) : intAsc2Chr = Asc(oIERTF.Read(1))

 

oIERTF.Close

 

'if Asc codes = 255 & 254, file is Unicode

'ASCII file read as Unicode: 1st Unicode line is entire file

'Unicode file read as ASCII: 1st ASCII line is variable length

'TriStateDefault appears to distinguish between ASCII & Unicode on file open

'VBS internally allots 2 bytes per ASCII chr

 

intTFF = 0 'ASCII fmt

If intAsc1Chr = 255 And intAsc2Chr = 254 Then intTFF = -1 'Unicode fmt

 

Set oIERTF = Fso.OpenTextFile (strIERFN,1,False,intTFF)

 

strSubSubTitle = "Added lines (compared with English-language version):"

 

flagInfect = False

 

'for each line

Do Until oIERTF.AtEndOfStream

 

strLine = Trim(oIERTF.ReadLine) 'read a line

 

flagMatch = False 'line doesn't match phrase array

 

'if line not empty And not a comment

If Len(strLine) > 0 And Left(strLine,1) <> ";" Then

 

If Left(strLine,1) = "[" Then 'if line is section title

 

strSection = strLine 'save the section name

 

Else 'line not a section title, so it's a data line

 

For i = 0 To UBound(arIER,1) 'for every line in phrase array

 

'if section's identical and phrase found in line,

'toggle line match flag & found-in-file-on-disk flag

If LCase(arIER(i,0)) = LCase(strSection) And _

LCase(strLine) = LCase(arIER(i,1)) Then

flagMatch = True : arIER(i,2) = True : Exit For

Exit For

End If

 

Next

 

If Not flagMatch Then 'if line not matched

flagInfect = True

TitleLineWrite

On Error Resume Next

'output section name & line

oFN.WriteLine strSection & ": " & strLine

intErrNum = Err.Number : Err.Clear

On Error Goto 0

If intErrNum <> 0 Then oFN.WriteLine "(unwritable string)"

End If 'line matched?

 

End If 'section title line?

 

End If 'data line?

 

Loop 'next file line

 

'close IERESET.INf

oIERTF.Close : Set oIERTF=Nothing

 

'initialize section title for phrases missing from file

strSection = ""

strSubSubTitle = "Missing lines (compared with English-language version):"

flagFound = True 'False if found-in-file-on-disk = False

 

For i = 0 To 23 'for single-option phrases

If Not arIER(i,2) Then

flagFound = False : flagInfect = True 'toggle flags

'increment counters

IERESETCounter strSection, arIER(i,0), arSectionCount

End If

Next 'single-option phrase

 

'check double-option phrases

For i = 24 To 30 Step 2

'if neither option found-in-file-on-disk

If Not arIER(i,2) And Not arIER(i+1,2) Then

flagFound = False : flagInfect = True 'toggle flags

'increment counters

IERESETCounter strSection, arIER(i,0), arSectionCount

End If

Next 'double-option phrase

 

If Not flagFound Then 'if lines missing

 

TitleLineWrite

 

'output contents of arSectionCount (section title: # missing lines)

For i = 0 To UBound(arSectionCount,2)

strOut = " line"

If arSectionCount(1,i) > 1 Then strOut = " lines"

oFN.WriteLine arSectionCount(0,i) & ": " & arSectionCount(1,i) & strOut

Next

 

End If 'lines missing?

 

strSubSubTitle = "" 'reset title line (no longer needed)

 

If strTitle <> "" And flagShowAll Then

strSubTitle = strIERFN & " (used to " & DQ &_

"Reset Web Settings" & DQ & " -- no anomalies found)"

TitleLineWrite

End If

 

Else 'IERESET.INF<100 bytes

 

oIERTF.Close

 

'file should always exist if IE ver > 5 Or if in one of these OS's

If intIELVer > 5 Or strOS = "WXP" Or strOS = "W2K" Or strOS = "WME" Then

 

TitleLineWrite

oFN.WriteLine strWarn & strIERFN & " is *much* too small and is " &_

"probably corrupt!"

flagHWarn = True

 

End If 'should file exist?

 

End If 'IERSET.INF>100 bytes?

 

Else 'IERESET.INF not found

 

'file should always exist if IE ver > 5 Or if in one of these OS's

If intIELVer > 5 Or strOS = "WXP" Or strOS = "W2K" Or strOS = "WME" Then

 

TitleLineWrite

oFN.WriteLine strWarn & strIERFN & " was not found!"

flagHWarn = True

 

End If 'should file exist?

 

End If 'IERESET.INF found?

 

End If 'strIEShVer<>7?

 

'URLSearchHooks

strKey = "Software\Microsoft\Internet Explorer\URLSearchHooks"

strSubTitle = "HKCU\" & strKey & "\"

 

intErrNum = oReg.EnumValues (HKCU, strKey, arNames, arType)

 

If IsArray(arNames) Then

 

For Each strCLSID In arNames

 

If UCase(strCLSID) <> "{CFBFAE00-17A6-11D0-99CB-00C04FD64497}" Or _

flagShowAll Then

 

flagTitle = False

 

CLSIDLocTitle HKCU, strKey, strCLSID, strLocTitle

 

For ctrCH = intCLL To 1

 

ResolveCLSID strCLSID, arHives(ctrCH,1), strCLSIDTitle, strIPSDLL

 

If strIPSDLL <> "" Then

 

strWarn = ""

If UCase(strCLSID) <> "{CFBFAE00-17A6-11D0-99CB-00C04FD64497}" Then

strWarn = HWarn : flagHWarn = True

End If

 

TitleLineWrite

 

If Not flagTitle Then

oFN.WriteLine strWarn & DQ & strCLSID & DQ & " = " & strLocTitle

flagTitle = True

End If

 

oFN.WriteLine " -> {" & arHives(ctrCH,0) & "...CLSID} = " &_

strCLSIDTitle & vbCRLF & Space(19) & "\InProcServer32\(Default) = " &_

StringFilter(strIPSDLL,True) & CoName(IDExe(strIPSDLL))

 

End If 'IPS exists?

 

Next 'CLSID hive

 

End If 'match Or flagShowAll?

 

Next 'strCLSID

 

Else

 

If flagShowAll Then

TitleLineWrite

oFN.WriteLine "(URLSearchHooks key not found!)"

End If

 

End If 'IsArray?

 

 

'AboutURLs

strKey = "Software\Microsoft\Internet Explorer\AboutURLs"

strSubTitle = SOCA("HKLM\" & strKey & "\")

 

EnumNVP HKLM, strKey, arNames, arType

 

If flagNVP Then 'name/value pairs exist

 

Set arSK = CreateObject("Scripting.Dictionary") 'key, item

 

'add dictionary pairs (universal elements)

arSK.Add "blank", "res://mshtml.dll/blank.htm"

arSK.Add "Home", "dword:0x0000010E"

arSK.Add "mozilla", "res://mshtml.dll/about.moz"

 

'value not set or IE 5-7

If intIELVer >= 7 Then 'IE 7

arSK.Add "DesktopItemNavigationFailure", "res://ieframe.dll/navcancl.htm"

arSK.Add "NavigationCanceled", "res://ieframe.dll/navcancl.htm"

arSK.Add "NavigationFailure", "res://ieframe.dll/navcancl.htm"

arSK.Add "OfflineInformation", "res://ieframe.dll/offcancl.htm"

arSK.Add "NoAdd-ons", "res://ieframe.dll/noaddon.htm"

arSK.Add "NoAdd-onsInfo", "res://ieframe.dll/noaddoninfo.htm"

arSK.Add "PostNotCached", "res://ieframe.dll/repost.htm"

arSK.Add "SecurityRisk", "res://ieframe.dll/securityatrisk.htm"

arSK.Add "Tabs", "res://ieframe.dll/tabswelcome.htm"

ElseIf intIELVer = 0 Or intIELVer >= 5 Then

arSK.Add "DesktopItemNavigationFailure", "res://shdoclc.dll/navcancl.htm"

arSK.Add "NavigationCanceled", "res://shdoclc.dll/navcancl.htm"

arSK.Add "NavigationFailure", "res://shdoclc.dll/navcancl.htm"

arSK.Add "OfflineInformation", "res://shdoclc.dll/offcancl.htm"

arSK.Add "PostNotCached", "res://mshtml.dll/repost.htm"

Else 'IE < 5

arSK.Add "DesktopItemNavigationFailure", "res://shdocvw.dll/navcancl.htm"

arSK.Add "NavigationCanceled", "res://shdocvw.dll/navcancl.htm"

arSK.Add "NavigationFailure", "res://shdocvw.dll/navcancl.htm"

arSK.Add "OfflineInformation", "res://shdocvw.dll/offcancl.htm"

arSK.Add "PostNotCached", "res://mshtml.dll/repost.htm"

End If 'IE>7?

 

arSKk = arSK.Keys : arSKi = arSK.Items

 

For i = 0 To UBound(arNames)

 

strWarn = HWarn

 

'use the type to find the value

strValue = RtnValue (HKLM, strKey, arNames(i), arType(i))

 

For j = 0 To arSK.Count-1

 

flagFound = False

 

If LCase(arNames(i)) = LCase(arSKk(j)) And _

LCase(strValue) = LCase(arSKi(j)) Then

flagFound = True : strWarn = "" : Exit For

End If

 

Next 'dictionary pair

 

If Not flagFound Or flagShowAll Then

 

TitleLineWrite

WriteValueData arNames(i), strValue, arType(i), strWarn

If strWarn <> "" Then flagHWarn = True

 

End If

 

Next 'arNames member

 

arSK.RemoveAll : Set arSK=Nothing 'recover dictionary memory

 

Else

 

If flagShowAll Then

TitleLineWrite

oFN.WriteLine "(AboutURLs key not found!)"

End If

 

End If 'flagNVP?

 

strTitle = "" : strSubTitle = "" : strSubSubTitle = ""

 

End If 'SecTest?