Ad-Aware crashes in registry deep scan...possible malware?

Comments

• skywalker45 Bloomington, IN. USA

  February 2006 edited February 2006

  Hi Treadstone. Please follow these instructions:
  
  You might want to print these instructions because you will not have access to the internet for part of this fix. Please download CWShredder from my signature below. Unzip the program to your desktop. Double click on it then click check for update. Once it updates please close the program. We don't want to run it yet.
  
  Next you need to reboot your PC in safe mode. To do this, reboot and begin tapping the F8 key, continue tapping until the advanced boot options menu appears. Scroll to the top choice which is safe mode and press enter.
  
  Once in safe mode open CWShredder. Click fix then click OK. Allow the program to run and just exit when it is finished.
  
  Run Hijack This again. Put a check (tick) next to the following entries (do not be concerned it they don't exist):
  
  R1 - HKCU\Software\Microsoft\Internet Explorer\Main,Search Bar = about:blank
  R1 - HKCU\Software\Microsoft\Internet Explorer\Search,SearchAssistant = about:blank
  R1 - HKCU\Software\Microsoft\Internet Explorer\Search,CustomizeSearch = about:blank
  R1 - HKLM\Software\Microsoft\Internet Explorer\Search,Default_Search_URL = http://www.searchxp.com/search.html
  R0 - HKLM\Software\Microsoft\Internet Explorer\Search,SearchAssistant = about:blank
  R0 - HKLM\Software\Microsoft\Internet Explorer\Search,CustomizeSearch = about:blank
  R1 - HKCU\Software\Microsoft\Internet Explorer\SearchURL,(Default) = about:blank
  R3 - URLSearchHook: (no name) - {B913ED32-F1BF-8FD1-7E81-FB89F01F26A1} - clamav.dll (file missing)
  
  O16 - DPF: {56336BCB-3D8A-11D6-A00B-0050DA18DE71} - http://207.188.7.150/31c874b45aa5dab...p/RdxIE601.cab
  
  Close all other browsers/windows and click Fix Checked. Reboot the PC into normal mode and post another Hijack This log.

  0
• Treadstone71

  February 2006 edited February 2006

  Wow thank you for your help! I'll try this when I get home from work.
  
  Cheers,
  Sean

  0
• Treadstone71

  February 2006 edited February 2006

  Hi there, I did exactly what you said to, and this is my new Hijack This log:
  
  Logfile of HijackThis v1.99.1
  Scan saved at 7:27:05 PM, on 23/02/2006
  Platform: Windows XP SP1 (WinNT 5.01.2600)
  MSIE: Internet Explorer v6.00 SP1 (6.00.2800.1106)
  
  Running processes:
  C:\WINDOWS\System32\smss.exe
  C:\WINDOWS\system32\csrss.exe
  C:\WINDOWS\system32\winlogon.exe
  C:\WINDOWS\system32\services.exe
  C:\WINDOWS\system32\lsass.exe
  C:\WINDOWS\system32\svchost.exe
  C:\WINDOWS\System32\svchost.exe
  C:\WINDOWS\System32\svchost.exe
  C:\WINDOWS\System32\svchost.exe
  C:\WINDOWS\system32\spoolsv.exe
  C:\WINDOWS\Explorer.EXE
  C:\Program Files\Common Files\Real\Update_OB\realsched.exe
  C:\WINDOWS\System32\RunDll32.exe
  C:\Program Files\Saitek\Software\SaiSmart.exe
  C:\Program Files\Saitek\Software\SaiMfd.exe
  C:\Program Files\AntiVir PersonalEdition Classic\avgnt.exe
  C:\WINDOWS\System32\ctfmon.exe
  C:\WINDOWS\System32\alg.exe
  C:\Program Files\AntiVir PersonalEdition Classic\sched.exe
  C:\Program Files\AntiVir PersonalEdition Classic\avguard.exe
  C:\Program Files\ewido anti-malware\ewidoctrl.exe
  C:\WINDOWS\System32\nvsvc32.exe
  C:\WINDOWS\System32\svchost.exe
  C:\WINDOWS\System32\wdfmgr.exe
  C:\WINDOWS\system32\fxssvc.exe
  C:\Program Files\Mozilla Firefox\firefox.exe
  C:\Documents and Settings\Sean\My Documents\Driver Updates\HijackThis!\HijackThis.exe
  
  R0 - HKCU\Software\Microsoft\Internet Explorer\Main,Start Page = http://www.ascforums.com/
  O1 - Hosts: localhost 127.0.0.1
  O3 - Toolbar: &Radio - {8E718888-423F-11D2-876E-00A0C9082467} - C:\WINDOWS\System32\msdxm.ocx
  O4 - HKLM\..\Run: [NeroCheck] C:\WINDOWS\system32\NeroCheck.exe
  O4 - HKLM\..\Run: [QuickTime Task] "C:\Program Files\QuickTime\qttask.exe" -atboottime
  O4 - HKLM\..\Run: [TkBellExe] "C:\Program Files\Common Files\Real\Update_OB\realsched.exe" -osboot
  O4 - HKLM\..\Run: [HGTXPEI] C:\WINDOWS\System32\FirstReboot.exe
  O4 - HKLM\..\Run: [SoundFusion] RunDll32 hercplgs.cpl,BootEntryPoint
  O4 - HKLM\..\Run: [NvCplDaemon] RUNDLL32.EXE C:\WINDOWS\System32\NvCpl.dll,NvStartup
  O4 - HKLM\..\Run: [nwiz] nwiz.exe /install
  O4 - HKLM\..\Run: [NvMediaCenter] RUNDLL32.EXE C:\WINDOWS\System32\NvMcTray.dll,NvTaskbarInit
  O4 - HKLM\..\Run: [Profiler] C:\Program Files\Saitek\Software\Profiler.exe
  O4 - HKLM\..\Run: [SaiSmart] C:\Program Files\Saitek\Software\SaiSmart.exe
  O4 - HKLM\..\Run: [SaiMfd] C:\Program Files\Saitek\Software\SaiMfd.exe
  O4 - HKLM\..\Run: [avgnt] "C:\Program Files\AntiVir PersonalEdition Classic\avgnt.exe" /min
  O4 - HKCU\..\Run: [CTFMON.EXE] C:\WINDOWS\System32\ctfmon.exe
  O8 - Extra context menu item: E&xport to Microsoft Excel - res://C:\PROGRA~1\MICROS~2\Office10\EXCEL.EXE/3000
  O9 - Extra button: ICQ - {6224f700-cba3-4071-b251-47cb894244cd} - C:\Program Files\ICQ\ICQ.exe
  O9 - Extra 'Tools' menuitem: ICQ - {6224f700-cba3-4071-b251-47cb894244cd} - C:\Program Files\ICQ\ICQ.exe
  O9 - Extra button: Real.com - {CD67F990-D8E9-11d2-98FE-00C0F0318AFE} - C:\WINDOWS\System32\Shdocvw.dll
  O9 - Extra button: Messenger - {FB5F1910-F110-11d2-BB9E-00C04F795683} - C:\Program Files\Messenger\MSMSGS.EXE
  O9 - Extra 'Tools' menuitem: Messenger - {FB5F1910-F110-11d2-BB9E-00C04F795683} - C:\Program Files\Messenger\MSMSGS.EXE
  O16 - DPF: {0585238B-9CA6-4CCB-A9B2-FE4BA495E880} (AXWebMon Control) - http://www.smilecam.com/home/ezwebcam/eng0/common/AXWebMonProj1.cab
  O16 - DPF: {41F17733-B041-4099-A042-B518BB6A408C} - http://a1540.g.akamai.net/7/1540/52/20020713/qtinstall.info.apple.com/samantha/us/win/QuickTimeInstaller.exe
  O16 - DPF: {6414512B-B978-451D-A0D8-FCFDF33E833C} (WUWebControl Class) - http://update.microsoft.com/windowsupdate/v6/V5Controls/en/x86/client/wuweb_site.cab?1124329491451
  O16 - DPF: {6B4788E2-BAE8-11D2-A1B4-00400512739B} (PWMediaSendControl Class) - http://216.249.24.140/code/PWActiveXImgCtl.CAB
  O17 - HKLM\System\CCS\Services\Tcpip\..\{257F8369-E411-4362-A9EA-744C4C93750F}: NameServer = 85.255.116.56,85.255.112.146
  O17 - HKLM\System\CCS\Services\Tcpip\..\{6CAA78A4-6AA0-4F23-81DA-3BB264801CD9}: NameServer = 85.255.116.56 85.255.112.146
  O17 - HKLM\System\CS1\Services\Tcpip\..\{257F8369-E411-4362-A9EA-744C4C93750F}: NameServer = 85.255.116.56,85.255.112.146
  O23 - Service: AntiVir Scheduler (AntiVirScheduler) - H+BEDV Datentechnik GmbH - C:\Program Files\AntiVir PersonalEdition Classic\sched.exe
  O23 - Service: AntiVir PersonalEdition Classic Service (AntiVirService) - H+BEDV Datentechnik GmbH - C:\Program Files\AntiVir PersonalEdition Classic\avguard.exe
  O23 - Service: ewido security suite control - ewido networks - C:\Program Files\ewido anti-malware\ewidoctrl.exe
  O23 - Service: NVIDIA Display Driver Service (NVSvc) - NVIDIA Corporation - C:\WINDOWS\System32\nvsvc32.exe
  
  
  I tried Ad-Aware again, but it still hangs while deep scanning the registry.
  
  It reaches "HKEY_LOCAL_MACHINE\SOFTWARE\. ." and hangs. No solid crash or anything, it just stops and won't respond.
  
  Any ideas? Is it some sort of hidden key in my directory that is designed to halt Ad-Aware? Is there a program that will hunt for hidden directory keys?
  
  As always Skywalker45, I appreciate your help.
  
  cheers,
  Sean

  0
• skywalker45 Bloomington, IN. USA

  February 2006 edited February 2006

  I don't believe there is someting hidden there unless you have something else installed that might conflict with Ad-Aware. Spybot and Ad-Aware have been known to conflict with each other at times. Your log looks clean, but just in case we're missing something please follow the instructions below:
  
  Go here and download then run Silent Runners.vbs. It generates a log, please post the information back in this thread.
  If you have a script blocking program, please allow the file to run. It is not malicious.
  
  Post the silent runners log when finished.

  0
• Treadstone71

  February 2006 edited February 2006

  Hmm...the log it creates is rather long...twice as long as the allowed post size.
  
  Am I doing this right? Should I just split the log between two posts?

  0
• skywalker45 Bloomington, IN. USA

  February 2006 edited February 2006

  Yes just split the log.

  0
• Treadstone71

  February 2006 edited February 2006

  Understood...and, here we go!
  
  'Silent Runners.vbs -- find out what programs start up with Windows!
  '
  'DO NOT REMOVE THIS HEADER!
  '
  'Copyright Andrew ARONOFF 09 January 2006, http://www.silentrunners.org/
  'This script is provided without any warranty, either expressed or implied
  'It may not be copied or distributed without permission
  '
  '** YOU RUN THIS SCRIPT AT YOUR OWN RISK! **
  'HEADER ENDS HERE
  
  
  Option Explicit
  
  Dim strRevNo : strRevNo = "43"
  
  Public flagTest : flagTest = False 'True if testing
  'flagTest = True 'Uncomment to test
  
  'This script is divided into 27 sections.
  
  'malware launch points:
  ' registry keys (I-XII, XV)
  ' INI/INF-files (XVI-XVIII)
  ' folders (XIX)
  ' enabled scheduled tasks (XX)
  ' Winsock2 service provider DLLs (XXI)
  ' IE toolbars, explorer bars, extensions (XXII)
  ' started services (XXVI)
  ' keyboard driver filters (XXVII)
  
  'hijack points:
  ' System/Group Policies (XIV)
  ' prefixes for IE URLs (XXIII)
  ' misc IE points (XXIV)
  ' HOSTS file (XXV)
  
  'Output is suppressed if deemed normal unless the -all parameter is used
  'Sections XVIII & XXII-dormant Explorer Bars are skipped unless the -supp/-all
  ' parameters are used or the first message box is answered "No"
  
  ' I. HKCU/HKLM... Run/RunOnce/RunOnce\Setup
  ' HKLM... RunOnceEx/RunServices/RunServicesOnce
  ' HKCU/HKLM... Policies\Explorer\Run
  ' II. HKLM... Active Setup\Installed Components\
  ' HKCU... Active Setup\Installed Components\
  ' (StubPath <> "" And HKLM version # > HKCU version #)
  ' III. HKLM... Explorer\Browser Helper Objects\
  ' IV. HKLM... Shell Extensions\Approved\
  ' V. HKLM... Explorer\SharedTaskScheduler/ShellExecuteHooks
  ' VI. HKCU/HKLM... ShellServiceObjectDelayLoad\
  ' VII. HKCU... Command Processor\AutoRun ((default) <> "")
  ' HKCU... Policies\System\Shell (W2K & WXP only)
  ' HKCU... Windows\load & run ((default) <> "")
  ' HKCU... Command Processor\AutoRun ((default) <> "")
  ' HKLM... Windows\AppInit_DLLs ((default) <> "")
  ' HKLM... Winlogon\Shell/Userinit/System/Ginadll/Taskman
  ' ((default) <> explorer.exe, userinit.exe, "", "", "")
  ' HKLM... Control\SafeBoot\Option\UseAlternateShell
  ' HKLM... Control\Session Manager\BootExecute
  ' VIII. HKLM... Winlogon\Notify\ (subkey names/DLLName values <> O/S-specific dictionary data)
  ' IX. HKLM... Image File Execution Options\ (subkeys with name = "Debugger")
  ' X. HKCU/HKLM... Policies... Startup/Shutdown, Logon/Logoff
  ' XI. HKCR Protocols\Filter
  ' XII. Context menu shell extensions
  ' XIII. HKCR executable file type (bat/cmd/com/exe/hta/pif/scr)
  ' (shell\open\command data <> "%1" %*; hta <> mshta.exe "%1" %*; scr <> "%1" /S)
  ' XIV. System/Group Policies
  ' XV. Enabled Wallpaper & Screen Saver
  ' XVI. WIN.INI (load/run <> ""), SYSTEM.INI (shell <> explorer.exe, scrnsave.exe), WINSTART.BAT
  ' XVII. AUTORUN.INF in root of fixed drive (open/shellexecute <> "")
  ' XVIII. DESKTOP.INI in any local fixed disk directory (section skipped by default)
  ' XIX. %WINDIR%... Startup & All Users... Startup (W98/WME) or
  ' %USERNAME%... Startup & All Users... Startup folder contents
  ' XX. Scheduled Tasks
  ' XXI. Winsock2 Service Provider DLLs
  ' XXII. Internet Explorer Toolbars, Explorer Bars, Extensions (dormant
  ' Explorer Bars section skipped by default)
  ' XXIII. Internet Explorer URL Prefixes
  ' XXIV. Misc. IE Hijack Points
  ' XXV. HOSTS file
  ' XXVI. Started Services
  ' XXVII. Keyboard Driver Filters
  'XXVIII. Printer Monitors
  
  
  Dim Wshso : Set Wshso = WScript.CreateObject("WScript.Shell")
  Dim WshoArgs : Set WshoArgs = WScript.Arguments
  Dim intErrNum, intMB 'Err.Number, MsgBox return value
  
  Dim strflagTest : strflagTest = ""
  If flagTest Then
  strflagTest = "TEST "
  Wshso.Popup "Silent Runners is in testing mode.",1, _
  "Testing, testing, 1-2-3...", vbOKOnly + vbExclamation
  End If
  
  'Configuration Detection Section
  
  ' FileSystemObject creation error (112)
  ' CScript/WScript (147)
  ' Dim (161)
  ' GetFileVersion(WinVer.exe) (VBScript 5.1) (182)
  ' OS version (223)
  ' WMI (279)
  ' Dim (364)
  ' command line arguments (440)
  ' supplementary search MsgBox (532)
  ' startup MsgBox (557)
  ' CreateTextFile error (583)
  ' output file header (625)
  ' WXP SP2 (629)
  
  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://*******.com/7nn6&quot;
  
  intMB = MsgBox (Chr(34) & "Silent Runners" & Chr(34) &_
  " cannot access file services critical to" & vbCRLF &_
  "proper script operation." & vbCRLF & vbCRLF &_
  "If you are running Windows XP, make sure that the" &_
  vbCRLF & Chr(34) & "Cryptographic Services" & Chr(34) &_
  " service is started." & vbCRLF & vbCRLF &_
  "You can also try reinstalling the latest version of the MS" &_
  vbCRLF & "Windows Script Host." & vbCRLF & vbCRLF &_
  "Press " & Chr(34) & "OK" & Chr(34) & " to direct your browser to " &_
  "the download site or" & vbCRLF & Space(10) & Chr(34) & "Cancel" &_
  Chr(34) & " 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 REG_SZ=1, REG_EXPAND_SZ=2, REG_BINARY=3, REG_DWORD=4, REG_MULTI_SZ=7
  Const MS = " [MS]"
  
  '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 " & Chr(34) & "WSCRIPT.EXE" & Chr(34) & " nor " &_
  Chr(34) & "CSCRIPT.EXE" & Chr(34) & " was detected as " &_
  "the script host." & vbCRLF & Chr(34) & "Silent Runners" & Chr(34) &_
  " will assume that the script host is CSCRIPT-compatible and will" & vbCRLF &_
  "use WScript.Echo for all messages."
  End If 'script host
  
  Const SysFolder = 1 : Const WinFolder = 0
  Dim strOS : strOS = "Unknown"
  Dim strOSLong : strOSLong = "Unknown"
  Dim strOSXP : strOSXP = "Windows XP Home" 'XP Home or Pro
  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
  Dim flagGP : flagGP = False 'assume Group Policies cannot be set in the O/S
  
  '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 old VBScript version
  If intErrNum <> 0 Then
  
  'store dl URL
  strURL = "http://*******.com/7zh0&quot;
  
  'if using WScript
  If flagOut = "W" Then
  
  'explain the problem
  intMB = MsgBox ("This script requires VBScript 5.1 or higher " &_
  "to run." & vbCRLF & vbCRLF & "The latest version of VBScript can " &_
  "be downloaded at: " & strURL & vbCRLF & vbCRLF &_
  "Press " & Chr(34) & "OK" & Chr(34) & " to direct your browser to " &_
  "the download site or " & Chr(34) & "Cancel" & Chr(34) &_
  " to quit." & vbCRLF & vbCRLF & "(WMI is also required. If it's " &_
  "missing, download instructions will appear later.)", _
  vbOKCancel + vbExclamation,"Unsupported VBScript Version!")
  
  'if dl wanted now, send browser to dl site
  If intMB = 1 Then Wshso.Run strURL
  
  'if using CScript
  Else 'flagOut = "C"
  
  'explain the problem
  WScript.Echo Chr(34) & "Silent Runners" & Chr(34) & " requires " &_
  "VBScript 5.1 or higher to run." & vbCRLF & vbCRLF &_
  "It can be downloaded at: " & strURL
  
  End If 'WScript or CScript?
  
  'quit the script
  WScript.Quit
  
  End If '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" : 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"
  
  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
  
  Else 'unknown strSysVer
  
  If flagOut = "W" Then
  
  intMB = MsgBox ("The " & Chr(34) & "Silent Runners" & Chr(34) &_
  " script cannot determine the operating system." & vbCRLF & vbCRLF &_
  "Click " & Chr(34) & "OK" & Chr(34) & " to send an e-mail to the " &_
  "author, providing the following information:" & vbCRLF & vbCRLF &_
  "WINVER.EXE file version = " & strSysVer & vbCRLF & vbCRLF &_
  "or click " & Chr(34) & "Cancel" & Chr(34) & " to quit.", _
  49,"O/S Unknown!")
  
  If intMB = 1 Then Wshso.Run "mailto:Andrew%20Aronoff%20" &_
  "<%73%72.%6F%73.%76%65%72.%65%72%72%6F%72@%61%61%72%6F%6E%6F%66%66.%63%6F%6D>?" &_
  "subject=Silent%20Runners%20OS%20Version%20Error&body=WINVER.EXE" &_
  "%20file%20version%20=%20" & strSysVer
  
  Else 'flagOut = "C"
  
  WScript.Echo Chr(34) & "Silent Runners" & Chr(34) & " cannot " &_
  "determine the operating system." & vbCRLF & vbCRLF & "This script will exit."
  
  End If '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://*******.com/jbxe&quot;
  If strOS = "NT4" Then strURL = "http://*******.com/7wd7&quot;
  
  'invite user to download WMI & quit
  If flagOut = "W" Then
  
  intMB = MsgBox ("This script requires " & Chr(34) & "WMI" &_
  Chr(34) & ", Windows Management Instrumentation, to run." &_
  vbCRLF & vbCRLF & "It can be downloaded at: " & strURL &_
  vbCRLF & vbCRLF & "Press " & Chr(34) & "OK" & Chr(34) &_
  " to direct your browser to the download site or " &_
  Chr(34) & "Cancel" & Chr(34) & " to quit.",_
  vbOKCancel + vbCritical,"WMI Not Installed!")
  
  If intMB = 1 Then Wshso.Run strURL
  
  'at command line, explain & quit
  Else 'flagOut = "C"
  
  WScript.Echo Chr(34) & "Silent Runners" & Chr(34) & " requires " &_
  Chr(34) & "WMI" & Chr(34) & ", Windows Management Instrumentation, " &_
  "to run." & vbCRLF & vbCRLF & "It can be downloaded at: " & strURL
  
  End If
  
  'for W2K Or WXP, explain how to start the WMI service
  ElseIf strOS = "W2K" Or strOS = "WXP" Then
  
  If strOS = "W2K" Then strLine = "Settings, "
  
  '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 &_
  "Control Panel, Administrative Tools, Services," & vbCRLF &_
  "and start the " & Chr(34) & "Windows Management Instrumentation" &_
  Chr(34) & " service.",vbOKOnly + vbCritical,"WMI Service not running!"
  
  'at command line, explain & quit
  Else 'flagOut = "C"
  
  WScript.Echo Chr(34) & "Silent Runners" & Chr(34) & " requires " &_
  "Windows Management Instrumentation to run." & vbCRLF & vbCRLF &_
  "Click on Start, " & strLine & "Control Panel, Administrative " &_
  " Tools, Services," & vbCRLF & "and start the " & Chr(34) &_
  "Windows Management Instrumentation" & Chr(34) & " 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 Chr(34) & "Silent Runners" & Chr(34) & " 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 5, hive member, startup folder file,
  'startup file shortcut, IERESET.INF file
  Dim arRunKeys, i, ii, j, k, l, oHiveElmt, oSUFi, oSUSC
  'dictionary, keys, items, hard disk collection
  Dim arSK, arSKk, arSKi, colDisks
  
  'arrays: Run key names, keys, sub-keys, value type, Protocol filters
  Dim arNames(), arKeys(), arSubKeys(), arType, arFilter()
  'Sub-Directory DeskTop.Ini array, Sub-Directory Error array
  Public arSDDTI(), arSDErr()
  'DeskTop.Ini counter, Error counter
  Public ctrArDTI, ctrArErr
  Public cntFo : cntFo = 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 7
  Dim strValue, strValue1, strValue2, strValue3, strValue4, strValue5, strValue6, intValue
  'name, single character, startup folder name, startup folder, array member, temp var
  Dim strName, strChr, arSUFN, oSUF, strArMember, strTmp
  'output string x 3
  Dim strOut, strOut1, strOut2
  
  'output file msg x 2, warning string, title line
  Dim strLine, strLine1, strLine2, strWarn, strTitleLine
  Dim strKey, strKey1, strKey2, strKey3, strSubKey 'register key x 4, sub-key
  'output file name string, PIF path string, single binary character
  Dim strFN, 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 " & Chr(34) & "{++}" & Chr(34) 'output file string
  Public strTitle : strTitle = ""
  Public strSubTitle : strSubTitle = ""
  Public strSubSubTitle : strSubSubTitle = ""
  Public flagNVP : flagNVP = False 'existence of name/value pairs in a key
  Dim flagInfect : flagInfect = False 'flag infected condition
  Dim flagMatch 'flag matching keys
  Dim flagAllow 'flag key on approved list
  Dim flagFound 'flag key that exists in Registry
  Dim flagDirArg : flagDirArg = False 'presence of output directory argument
  Dim flagIsCLSID : flagIsCLSID = False 'true if argument in CLSID format
  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
  'or for dormant Explorer Bars
  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
  Dim 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. " & Chr(34) & "-supp" & Chr(34) & " to search " &_
  "all directories for DESKTOP.INI DLL" & vbCRLF &_
  strLSp & "launch points and all Registry CLSIDs for dormant" &_
  vbCRLF & strLSp & "Explorer Bars" &_
  vbCRLF & vbCRLF & strCSp & "-OR-" & vbCRLF & vbCRLF &_
  "3. " & Chr(34) & "-all" & Chr(34) & " 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 and of " &_
  "all Registry CLSIDs for dormant Explorer Bars" & 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 &_
  Chr(34) & UCase(WshoArgs(i)) & Chr(34) & 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: " &_
  Chr(34) & UCase(WshoArgs(i)) & Chr(34) &_
  " 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 searches?" &_
  vbCRLF & "(They typically take several minutes.)" & vbCRLF & vbCRLF &_
  "Press " & Chr(34) & "Yes" & Chr(34) & Space(5) &_
  " to skip the supplementary searches (default)" & vbCRLF & vbCRLF &_
  Space(10) & Chr(34) & "No" & Chr(34) & Space(6) &_
  " to perform them, or" & vbCRLF & vbCRLF &_
  Space(10) & Chr(34) & "Cancel" & Chr(34) &_
  " to get more information at the web site" & vbCRLF &_
  Space(25) & "and exit the script.",_
  15,"Skip supplementary searches?",_
  vbYesNoCancel + vbQuestion + vbDefaultButton1 + vbSystemModal)
  
  If intMB = vbNo Then
  flagSupp = True
  ElseIf intMB = vbCancel Then
  Wshso.Run "http://www.silentrunners.org/sr_thescript.html#supp&quot;
  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 Chr(34) & "Silent Runners" & Chr(34) & " 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 Chr(34) & "Silent Runners" & Chr(34) & " has started." &_
  " Please be patient..."
  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
  
  strFN = strPathOFFo & strflagTest & "Startup Programs (" &_
  oNetwk.ComputerName & ") " & FmtDate(datLaunch) & " " &_
  FmtHMS(datLaunch) & ".txt"
  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 Runners RED.vbs&quot;
  
  'invite user to e-mail me & 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 " & Chr(34) & "OK" & Chr(34) & " to direct your browser " &_
  "to the alternate script location, or" & vbCRLF & Space(10) &_
  Chr(34) & "Cancel" & Chr(34) & " 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 Chr(34) & "Silent Runners" & Chr(34) & " 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 Chr(34) & "Silent Runners.vbs" & Chr(34) &_
  ", revision " & strRevNo & ", http://www.silentrunners.org/&quot; &_
  vbCRLF & "Operating System: " & strOSLong & vbCRLF & strRptOutput
  
  'use WMI to differentiate between WXP Home & WXP Pro
  If strOS = "WXP" Then
  
  'get the O/S collection
  Dim colOS : Set colOS = GetObject("winmgmts:\root\cimv2").ExecQuery _
  ("Select * from Win32_OperatingSystem")
  
  For Each oOS in colOS
  '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"
  Next
  
  Set colOS=Nothing
  
  End If 'WXP?
  
  
  
  
  'I. Examine HKCU/HKLM... Run/RunOnce/RunOnceEx/RunServices/RunServicesOnce
  ' and HKCU/HKLM... Policies\Explorer\Run
  
  If Not flagTest Then 'skip if testing
  
  '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
  
  'Hive HKCU - 0 HKLM - 1

  0
• Treadstone71

  February 2006 edited February 2006

  '
  'Key 0 1 2 3 4 5 6 0 1 2 3 4 5 6
  'Index
  '
  'O/S:
  'W98 0,0 2,0 2,0 0,0 0,0 0,0 0,0 0,0 2,0 2,0 2,0 2,1 2,0 2,0
  'WME 0,0 2,0 2,0 0,0 0,0 0,0 0,0 0,0 2,0 2,0 2,0 2,1 2,0 2,0
  'NT4 1,0 2,0 2,0 0,0 0,0 0,0 0,0 1,0 2,0 2,0 1,0 2,1 0,0 0,0
  'W2K 2,1 2,1 2,1 0,0 0,0 0,0 0,0 2,1 2,1 2,1 0,0 2,1 0,0 0,0
  'WXP 2,0 2,0 2,0 0,0 0,0 0,0 0,0 2,0 2,0 2,0 1,0 2,1 0,0 0,0
  'WS2K3 ??? ??? ??? ??? ??? ??? ??? ??? ??? ??? ??? ??? ??? ???
  
  'arRegFlag(i,j,k): put flags in array by O/S:
  'hive = i (0 or 1), key_# = j (0-6),
  ' flags (key execution/subkey recursion) = k (0 or 1)
  ' k = 0 holds key execution value = 0/1/2
  ' 1 holds subkey recursion value = 0/1
  Dim arRegFlag()
  ReDim arRegFlag(1,6,1)
  
  'initialize entire array to zero
  For i = 0 To 1 : For j = 0 To 6 : For k = 0 To 1
  arRegFlag(i,j,k) = 0
  Next : Next : Next
  
  'add data to array for O/S that's running
  
  'W98 0,0 2,0 2,0 0,0 0,0 0,0 0,0 0,0 2,0 2,0 2,0 2,1 2,0 2,0
  If strOS = "W98" Or strOS = "WME" Then
  arRegFlag(0,1,0) = 2 'HKCU,Run = no-warn
  arRegFlag(0,2,0) = 2 'HKCU,RunOnce = no-warn
  arRegFlag(1,1,0) = 2 'HKLM,Run = no-warn
  arRegFlag(1,2,0) = 2 'HKLM,RunOnce = no-warn
  arRegFlag(1,3,0) = 2 'HKLM,RunOnce\Setup = no-warn
  arRegFlag(1,4,0) = 2 'HKLM,RunOnceEx = no-warn
  arRegFlag(1,4,1) = 1 'HKLM,RunOnceEx = sub-keys
  arRegFlag(1,5,0) = 2 'HKLM,RunServices = no-warn
  arRegFlag(1,6,0) = 2 'HKLM,RunServicesOnce = no-warn
  End If
  
  'NT4 1,0 2,0 2,0 0,0 0,0 0,0 0,0 1,0 2,0 2,0 1,0 2,1 0,0 0,0
  If strOS = "NT4" Then
  arRegFlag(0,0,0) = 1 'HKCU,Explorer\Run = warning
  arRegFlag(0,1,0) = 2 'HKCU,Run = no-warn
  arRegFlag(0,2,0) = 2 'HKCU,RunOnce = no-warn
  arRegFlag(1,0,0) = 1 'HKLM,Explorer\Run = warning
  arRegFlag(1,1,0) = 2 'HKLM,Run = no-warn
  arRegFlag(1,2,0) = 2 'HKLM,RunOnce = no-warn
  arRegFlag(1,3,0) = 1 'HKLM,RunOnce\Setup = warning
  arRegFlag(1,4,0) = 2 'HKLM,RunOnceEx = no-warn
  arRegFlag(1,4,1) = 1 'HKLM,RunOnceEx = sub-keys
  End If
  
  'W2K 2,1 2,1 2,1 0,0 0,0 0,0 0,0 2,1 2,1 2,1 0,0 2,1 0,0 0,0
  If strOs = "W2K" Then
  arRegFlag(0,0,0) = 2 'HKCU,Explorer\Run = no-warn
  arRegFlag(0,0,1) = 1 'HKCU,Explorer\Run = sub-keys
  arRegFlag(0,1,0) = 2 'HKCU,Run = no-warn
  arRegFlag(0,1,1) = 1 'HKCU,Run = sub-keys
  arRegFlag(0,2,0) = 2 'HKCU,RunOnce = no-warn
  arRegFlag(0,2,1) = 1 'HKCU,RunOnce = sub-keys
  arRegFlag(1,0,0) = 2 'HKLM,Explorer\Run = no-warn
  arRegFlag(1,0,1) = 1 'HKLM,Explorer\Run = sub-keys
  arRegFlag(1,1,0) = 2 'HKLM,Run = no-warn
  arRegFlag(1,1,1) = 1 'HKLM,Run = sub-keys
  arRegFlag(1,2,0) = 2 'HKLM,RunOnce = no-warn
  arRegFlag(1,2,1) = 1 'HKLM,RunOnce = sub-keys
  arRegFlag(1,4,0) = 2 'HKLM,RunOnceEx = no-warn
  arRegFlag(1,4,1) = 1 'HKLM,RunOnceEx = sub-keys
  End If
  
  'WXP 2,0 2,0 2,0 0,0 0,0 0,0 0,0 2,0 2,0 2,0 1,0 2,1 0,0 0,0
  If strOs = "WXP" Then
  arRegFlag(0,0,0) = 2 'HKCU,Explorer\Run = no-warn
  arRegFlag(0,1,0) = 2 'HKCU,Run = no-warn
  arRegFlag(0,2,0) = 2 'HKCU,RunOnce = no-warn
  arRegFlag(1,0,0) = 2 'HKLM,Explorer\Run = no-warn
  arRegFlag(1,1,0) = 2 'HKLM,Run = no-warn
  arRegFlag(1,2,0) = 2 'HKLM,RunOnce = no-warn
  arRegFlag(1,3,0) = 1 'HKLM,RunOnce\Setup = warning
  arRegFlag(1,4,0) = 2 'HKLM,RunOnceEx = no-warn
  arRegFlag(1,4,1) = 1 'HKLM,RunOnceEx = sub-keys
  End If
  
  '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: "
  
  '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" --
  'WXP False "Null" --
  'WS2K3 True "Variant()" --
  
  EnumNVP arHives(i,1), arRunKeys(j), arNames, arType
  
  If flagNVP Then 'name/value pairs exist
  
  'write the full key name
  oFN.WriteLine vbCRLF & 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 & 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 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 & 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 & arHives(i,0) & "\" & strSubKey & "\"
  
  End If 'flagNVP?
  
  Next 'sub-key
  
  End If 'sub-keys exist? W2K/WXP/WS2K3
  
  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?
  
  
  
  
  'II. Examine HKLM... Active Setup\Installed Components
  
  If Not flagTest Then 'skip if testing
  
  '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 = "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
  
  'Default Value not set:
  'W98/WME: returns 0, strValue = ""
  'NT4/W2K/WXP: returns non-zero, strValue = Null
  
  'Non-Default name inexistent:
  'W98/WME/NT4/W2K/WXP: returns non-zero, strValue = Null
  
  'Non-Default Value not set:
  'W2K: returns 0, strValue = unwritable string
  'W98/WME/NT4/WXP: 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 = Chr(34) & strPgmName & Chr(34)
  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 = " &_
  Chr(34) & strSPV & Chr(34) & 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 'flagTest?
  
  
  
  
  'III. Examine HKLM... Explorer\Browser Helper Objects
  
  If Not flagTest Then 'skip if testing
  
  strKey = "Software\Microsoft\Windows\CurrentVersion\Explorer\Browser Helper Objects"
  strSubTitle = "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
  
  TitleLineWrite
  
  If Len(strSubKey) = 38 Then 'strSubKey is CLSID
  
  'get the default value
  intErrNum1 = oReg.GetStringValue (HKLM,strKey & "\" & strSubKey,"",strValue)
  
  'if the BHO title exists, embed it in quotes
  If intErrNum1 = 0 And strValue <> "" Then
  
  strValue = StringFilter(strValue,True)
  
  Else 'check the CLSID default value
  
  strKey2 = "Software\Classes\CLSID\" & strSubKey
  intErrNum2 = oReg.GetStringValue (HKLM,strKey2,"",strValue2)
  
  'if the CLSID default value exists, embed it in quotes and say where it came from
  If intErrNum2 = 0 And strValue2 <> "" Then
  strValue = StringFilter(strValue2,True) & " [from CLSID]"
  Else 'use a standard string
  strValue = "(no title provided)"
  End If 'CLSID title exists?
  
  End If 'BHO title exists?
  
  'resolve the data via HKLM\Software\Classes\CLSID\{data}\InProcServer32
  strKey3 = "Software\Classes\CLSID\" & strSubKey & "\InProcServer32"
  intErrNum3 = oReg.GetExpandedStringValue (HKLM,strKey3,"",strValue3)
  
  'if InProcServer32 key exists and default value set
  If intErrNum3 = 0 And strValue3 <> "" Then
  
  strValue3 = StringFilter(strValue3,True) & CoName(IDExe(strValue3))
  
  'output the quote-delimited names and values
  oFN.WriteLine strSubKey & "\(Default) = " & strValue
  
  oFN.WriteLine " -> {CLSID}\InProcServer32\(Default) = " & strValue3
  
  End If 'InProcServer32 key exists And default value set?
  
  End If 'strSubKey CSID?
  
  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 'flagTest?
  
  
  
  
  'IV. Examine HKLM... Shell Extensions\Approved\
  
  If Not flagTest Then 'skip if testing
  
  'CLSID value, InProcessServer32 DLL name & output file version
  Dim strCLSID, strIPSDLL, strIPSDLLOut, strCLSIDTitle
  
  'Shell Extension Approved array
  Dim arSEA()
  ReDim arSEA(243,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"
  
  'set up key name to query
  strKey = "Software\Microsoft\Windows\CurrentVersion\Shell Extensions\Approved"
  strSubTitle = "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
  
  'assume CLSID unapproved
  flagMatch = False
  
  ResolveCLSID HKLM, strKey, strCLSID, strValue, strIPSDLL
  
  If strIPSDLL <> "" Then
  
  strCN = CoName(IDExe(strIPSDLL))
  
  'for every member of approved shellex array
  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) 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
  
  'find CoName
  strCN = CoName(IDExe(strIPSDLL))
  
  TitleLineWrite
  
  On Error Resume Next
  'output CLSID & title
  oFN.WriteLine Chr(34) & strCLSID & Chr(34) & " = " & strValue
  intErrNum = Err.Number : Err.Clear
  'error check for W2K if title (Approved CLSID) value not set
  If intErrNum <> 0 Then _
  oFN.WriteLine Chr(34) & strCLSID & Chr(34) & " = (no title provided)"
  On Error GoTo 0
  
  'output InProcServer32 DLL & CoName
  oFN.WriteLine " -> {CLSID}\InProcServer32\(Default) = " &_
  StringFilter(strIPSDLL,True) & CoName(IDExe(strIPSDLL))
  
  End If 'flagMatch Or flagShowAll?
  
  End If 'strIPSDLL <> ""?
  
  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)

  0
• Treadstone71

  February 2006 edited February 2006

  End If 'flagTest?
  
  
  
  
  'V. Examine HKLM... Explorer\SharedTaskScheduler/ShellExecuteHooks
  
  If Not flagTest Then 'skip if testing
  
  Dim arAllowedCLSID()
  
  ReDim arKeys(1)
  arKeys(0) = "Software\Microsoft\Windows\CurrentVersion\Explorer\SharedTaskScheduler"
  arKeys(1) = "Software\Microsoft\Windows\CurrentVersion\Explorer\ShellExecuteHooks"
  
  'for each Explorer sub-key
  For i = 0 To UBound(arKeys)
  
  strSubTitle = "HKLM" & "\" & arKeys(i) & "\"
  
  'set up allowed CLSID's & IPS names for each sub-key
  If i = 0 Then 'SharedTaskScheduler
  
  ReDim arAllowedCLSID(1,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"
  
  ElseIf i = 1 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
  
  ResolveCLSID HKLM, arKeys(i), strName, strValue1, strValue3
  
  If strValue3 <> "" Then
  
  flagFound = False : strWarn = "INFECTION WARNING! "
  strCN = CoName(IDExe(strValue3))
  
  'for every CLSID
  'see if CLSID, IPS filename are allowed & IPS CoName = "MS"
  For j = 0 To UBound(arAllowedCLSID,1)
  
  If LCase(strName) = LCase(arAllowedCLSID(j,0)) And _
  LCase(Fso.GetFileName(strValue3)) = LCase(arAllowedCLSID(j,1)) And _
  strCN = MS Then
  flagFound = True : strWarn = "" : Exit For
  End If
  
  Next 'allowed CLSID & IPS file name
  
  'if IPS not allowed or ShowAll, output name & value
  If Not flagFound Or flagShowAll Then
  
  'output the title line if not already done
  TitleLineWrite
  
  On Error Resume Next
  oFN.WriteLine strWarn & Chr(34) & strName & Chr(34) &_
  " = " & strValue1
  'error check for W2K if SharedTaskScheduler value not set
  intErrNum = Err.Number : Err.Clear
  On Error GoTo 0
  If intErrNum <> 0 Then oFN.WriteLine Chr(34) & strName & Chr(34) &_
  " = (no title provided)"
  
  oFN.WriteLine " -> {CLSID}\InProcServer32\(Default) = " &_
  StringFilter(strValue3,True) & strCN
  
  End If 'unexpected data or ShowAll?
  
  End If 'IPS exists?
  
  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 'flagTest?
  
  
  
  
  'VI. Examine HKCU/HKLM... ShellServiceObjectDelayLoad
  
  If Not flagTest Then 'skip if testing
  
  strKey = "Software\Microsoft\Windows\CurrentVersion\ShellServiceObjectDelayLoad"
  
  'Dim arHives(1,1)
  'arHives(0,0) = "HKCU" : arHives(1,0) = "HKLM"
  'arHives(0,1) = &H80000001 : arHives(1,1) = &H80000002
  
  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 = 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 name
  For Each strName In arNames
  
  flagMatch = False 'SSODL entry is not allowable
  
  'get the SSODL value = CLSID name
  oReg.GetStringValue arHives(i,1),strKey,strName,strValue
  
  'find the IPS at HKLM\Software\Classes\CLSID\{this data}\InProcServer32
  strKey2 = "Software\Classes\CLSID\" & strValue & "\InProcServer32"
  intErrNum = oReg.GetExpandedStringValue (HKLM,strKey2,"",strValue2)
  
  'if IPS value exists And is not empty
  If intErrNum = 0 And strValue2 <> "" Then
  
  strCN = CoName(IDExe(strValue2))
  strDLL = Fso.GetFileName(strValue2)
  
  '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
  If LCase(arSSODL(j,0)) = LCase(strValue) And _
  LCase(arSSODL(j,1)) = LCase(strDLL) And _
  LCase(strCN) = " [ms]" Then
  flagMatch = True 'toggle flag if all three match known values
  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
  
  'output SSODL value
  oFN.WriteLine Chr(34) & strName & Chr(34) & " = " & Chr(34) & strValue & Chr(34)
  oFN.WriteLine " -> {CLSID}\InProcServer32\(Default) = " &_
  StringFilter(strValue2,True) & strCN
  
  End If 'flagMatch?
  
  End If 'IPS exists?
  
  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 'flagTest?
  
  
  
  
  'VII. Find values of specific names:
  ' HKCU... Command Processor\AutoRun
  ' HKCU... Policies\System\Shell (W2K & WXP only)
  ' HKCU... Windows\load & run
  ' HKCU... Command Processor\AutoRun
  ' HKCU... Winlogon\Shell
  ' HKLM... Windows\AppInit_DLLs
  ' HKLM... Winlogon\Shell & Userinit & System & Ginadll & Taskman
  ' HKLM... Control\SafeBoot\Option\UseAlternateShell
  ' HKLM... Control\Session Manager\BootExecute
  
  If Not flagTest Then 'skip if testing
  
  'value length, pos'n of space/comma in value
  Dim intSpacePosn, intCommaPosn
  
  If strOS <> "W98" And strOS <> "WME" Then
  
  'HKCU\Software\Microsoft\Command Processor\AutoRun
  strSubTitle = "HKCU\SOFTWARE\Microsoft\Command Processor\"
  RegDataChk HKCU, "SOFTWARE\Microsoft\Command Processor", "AutoRun", strValue, ""
  
  If strOS = "W2K" Or strOS = "WXP" Then
  'HKCU\SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\System
  '"Shell" = ""
  strSubTitle = "HKCU\SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\System\"
  RegDataChk HKCU, "SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\System", "Shell", strValue, ""
  End If 'WXP?
  
  'HKCU\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Windows\load & run
  strSubTitle = "HKCU\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Windows\"
  RegDataChk HKCU, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Windows", "load", strValue, ""
  RegDataChk HKCU, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Windows", "run", strValue, ""
  
  'HKCU\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon\Shell
  '"Shell" = "Explorer.exe"
  strSubTitle = "HKCU\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon\"
  RegDataChk HKCU, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon", "Shell", strValue, "explorer.exe"
  
  'HKLM\Software\Microsoft\Command Processor\AutoRun
  strSubTitle = "HKLM\SOFTWARE\Microsoft\Command Processor\"
  RegDataChk HKLM, "SOFTWARE\Microsoft\Command Processor", "AutoRun", strValue, ""
  
  'HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Windows\AppInit_DLLs
  strSubTitle = "HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Windows\"
  RegDataChk HKLM, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Windows", "AppInit_DLLs", strValue, ""
  
  'HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon\GinaDLL
  '"GinaDLL" = "MSGina.dll"
  strSubTitle = "HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon\"
  RegDataChk HKLM, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon", "GinaDLL", strValue, "msgina.dll"
  
  'HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon\Shell
  '"Shell" = "Explorer.exe"
  RegDataChk HKLM, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon", "Shell", strValue, "explorer.exe"
  
  'HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon\Taskman
  '"Taskman" = ""
  RegDataChk HKLM, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon", "Taskman", strValue, ""
  
  'HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon\Userinit
  '"Userinit" = "%SystemRoot%\system32\userinit.exe,"
  'find value for "Userinit" name
  
  flagInfect = False
  
  strKey = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon"
  intErrNum = oReg.GetStringValue (HKLM,strKey,"Userinit",strValue)
  
  'if Userinit name exists And value set (exc for W2K!)
  If intErrNum = 0 And strValue <> "" Then
  
  'save default output line
  strOut = Chr(34) & "Userinit" & Chr(34) & " = " & Chr(34) &_
  strValue & Chr(34) & LRParse(strValue)
  
  'remove trailing space or comma
  strValue = Trim(strValue)
  If InStrRev(strValue,",") = Len(strValue) Then strValue = _
  Left(strValue,Len(strValue)-1)
  
  'if NT4 And Userinit value <> expected string, toggle infection flag & fill warning string
  If strOS = "NT4" And LCase(strValue) <> "userinit,nddeagnt.exe" And _
  LCase(strValue) <> "userinit nddeagnt.exe" Then
  
  flagInfect = True
  
  'if W2K/WXP
  ElseIf strOS <> "NT4" Then
  
  'find pos'n of space & comma in value
  intLenValue = Len(strValue)
  intSpacePosn = InStr(strValue," ")
  If intSpacePosn = 0 Then intSpacePosn = intLenValue
  intCommaPosn = InStr(strValue,",")
  If intCommaPosn = 0 Then intCommaPosn = intLenValue
  
  'if string doesn't contain userinit.exe Or extends beyond space or comma
  If InStr(LCase(strValue),"userinit.exe") = 0 Or _
  intLenValue > intSpacePosn + 1 Or intLenValue > intCommaPosn + 1 Then _
  flagInfect = True
  
  End If 'userinit string test
  
  If flagInfect Then strOut = "INFECTION WARNING! " & strOut
  
  'if infected or ShowAll
  If flagInfect Or flagShowAll Then
  
  'output key name
  TitleLineWrite
  
  'write name and value to file
  On Error Resume Next
  oFN.WriteLine strOut
  intErrNum = Err.Number : Err.Clear
  On Error GoTo 0
  
  'error check for W2K if Userinit value not set
  If intErrNum <> 0 Then _
  oFN.WriteLine Chr(34) & "Userinit" & Chr(34) & " = (value not set)"
  
  End If 'flagInfect/flagShowAll
  
  End If 'Userinit value exists?
  
  flagInfect = False
  
  'HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon\System
  '"System" = ""
  'if NT4, check for expected value
  If strOS = "NT4" Then
  RegDataChk HKLM, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon", "System", strValue, "lsass.exe"
  'if W2K/WXP, check for empty string
  Else
  RegDataChk HKLM, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon", "System", strValue, ""
  End If
  
  
  '*****
  If strOS = "W2K" Or strOS = "WXP" Then
  
  'HKLM\SYSTEM\CurrentControlSet\Control\SafeBoot\Option\UseAlternateShell
  strKey = "System\CurrentControlSet\Control\SafeBoot\Option"
  strSubTitle = "HKLM" & "\" & strKey & "\"
  
  flagArray = False : flagInfect = False : strValue = "" : intType = -1 : strWarn = ""
  
  'enumerate name/value pairs
  EnumNVP HKLM,strKey,arNames,arType
  
  'check for all OS's (esp WS2K3) if name/value pairs exist
  If IsArray(arNames) Then
  
  For Each strName In arNames
  flagArray = True : Exit For
  Next 'arNames member
  
  'if name/value pairs exist
  If flagArray Then
  
  For i = 0 To UBound(arNames)
  
  'check for UseAlternateShell name
  If Trim(LCase(arNames(i))) = "usealternateshell" Then
  
  'find its type & value, then exit For
  flagInfect = True : strWarn = "INFECTION WARNING! "
  intType = arType(i)
  strValue = RtnValue (HKLM, strKey, "UseAlternateShell", intType)
  Exit For
  
  End If 'UseAlternateShell?
  
  Next 'arName member
  
  End If 'flagArray?
  
  End If 'IsArray(arNames)?
  
  'output UseAlternateShell value
  If flagInfect Then
  
  'write name and value to file
  On Error Resume Next
  TitleLineWrite
  'output final line
  oFN.WriteLine strWarn & Chr(34) & "UseAlternateShell" &_
  Chr(34) & " = " & Chr(34) & strValue & Chr(34)
  intErrNum = Err.Number : Err.Clear
  On Error GoTo 0
  
  'if write error, output warning
  If intErrNum <> 0 Then oFN.WriteLine Chr(34) &_
  "UseAlternateShell" & Chr(34) & " = ** WARNING -- empty or invalid data! **"
  
  strKey = "System\CurrentControlSet\Control\SafeBoot"
  strSubTitle = "HKLM" & "\" & strKey & "\"
  TitleLineWrite
  intErrNum = oReg.GetStringValue (HKLM,strKey,"AlternateShell",strValue)
  
  If intErrNum = 0 Then
  On Error Resume Next
  oFN.WriteLine Chr(34) & "AlternateShell" & Chr(34) & " = " &_
  Chr(34) & strValue & Chr(34)
  intErrNum1 = Err.Number : Err.Clear
  On Error Goto 0
  'if write error, output warning
  If intErrNum1 <> 0 Then oFN.WriteLine Chr(34) &_
  "AlternateShell" & Chr(34) & " = ** WARNING -- empty or invalid data! **"
  Else
  oFN.WriteLine Chr(34) & "AlternateShell" & Chr(34) &_
  " = (value not set)"
  End If 'intErrNum=0?
  
  ElseIf flagShowAll Then
  
  TitleLineWrite
  oFN.WriteLine Chr(34) & "UseAlternateShell" & Chr(34) & " = (no data)"
  
  End If 'flagInfect Or flagShowAll?
  
  flagArray = False : flagInfect = False : strWarn = ""
  
  End If 'W2K or WXP?
  
  
  
  
  'HKLM\System\CurrentControlSet\Control\Session Manager\BootExecute
  strKey = "System\CurrentControlSet\Control\Session Manager"
  intErrNum = oReg.GetMultiStringValue (HKLM,strKey,"BootExecute",arNames)
  strSubTitle = "HKLM" & "\" & strKey & "\"
  
  '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)
  
  'concatenate line
  strLine = strLine & arNames(i) & " "
  
  'if autocheck not in a line
  If InStr(LCase(arNames(i)),"autocheck") = 0 Then
  strWarn = "INFECTION WARNING! " : flagInfect = True
  End If
  
  Next 'arNames member
  
  strLine = Chr(34) & RTrim(strLine) & Chr(34) 'embed in quotes
  
  Else 'BootExecute value doesn't exist or not set
  
  strLine = "(no data)"
  
  End If 'BootExecute value exists?
  
  'output bootexecute value
  If flagInfect Or flagShowAll Then
  
  'write name and value to file
  On Error Resume Next
  'if warning string not empty, parse line and find CoNames
  If flagInfect Then strCN = LRParse(strLine)
  
  TitleLineWrite
  
  'output final line
  oFN.WriteLine strWarn & Chr(34) & "BootExecute" &_
  Chr(34) & " = " & strLine & strCN
  intErrNum = Err.Number : Err.Clear
  On Error GoTo 0
  
  'if write error, output warning
  If intErrNum <> 0 Then oFN.WriteLine strLine & Chr(34) &_
  "BootExecute" & Chr(34) & " = ** WARNING -- empty or invalid data! **"
  
  End If 'flagInfect Or flagShowAll?
  
  End If 'not W98/WME
  
  strTitle = "" : strSubTitle = "" : strSubSubTitle = ""
  strLine = "" : strWarn = ""
  
  End If 'flagTest?
  
  
  
  
  'VIII. Examine HKLM... Winlogon\Notify\ subkey DLLName values
  
  If Not flagTest Then 'skip if testing
  
  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"
  
  End If
  
  arSKk = arSK.Keys
  arSKi = arSK.Items
  
  If strOS <> "W98" And strOS <> "WME" Then
  
  strKey = "Software\Microsoft\Windows NT\CurrentVersion\Winlogon\Notify"
  strSubTitle = "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
  
  '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
  
  flagInfect = True : strWarn = "INFECTION WARNING! "
  
  '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
  'empty warning string, toggle flag & exit -- no output necessary
  flagInfect = False : strWarn = "" : Exit For
  End If
  
  Next 'dictionary key
  
  '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 = " & Chr(34) &_
  strValue & Chr(34) & 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
  
  strTitle = "" : strSubTitle = "" : strSubSubTitle = ""
  strWarn = "" : strCN = ""
  
  'recover array memory
  arSK.RemoveAll : Set arSK=Nothing : ReDim arKeys(0)
  
  End If 'flagTest?
  
  
  
  
  'IX. Examine HKLM... Windows NT\CurrentVersion\Image File Execution Options
  ' subkey\Debugger value
  
  If Not flagTest Then 'skip if testing
  
  'ignore W98/WME
  If strOS <> "W98" And strOS <> "WME" Then
  
  strKey = "Software\Microsoft\Windows NT\CurrentVersion\Image File Execution Options"
  strSubTitle = "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 = "INFECTION WARNING! "
  
  'output title line if not already done
  TitleLineWrite
  
  'output sub-key, warning, Debugger value
  oFN.WriteLine strWarn & strSubKey & "\Debugger = " &_
  Chr(34) & strValue & Chr(34) & 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 'flagTest?
  
  
  
  
  'X. For W2K & WXP, check for startup/shutdown & logon/logoff scripts
  
  If Not flagTest Then 'skip if testing
  
  Dim strCmd : 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"
  
  Select Case strOS
  
  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 = 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 " & Chr(34) & strValue &_
  "\scripts.ini" & Chr(34) & 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"
  
  'Base Key string
  Dim strBK : strBK = "Software\Policies\Microsoft\Windows\System\Scripts\"
  
  Dim arNKSE 'Numbered (master) Keys containing Script Executable values
  Dim strSPXP : strSPXP = "" 'Script Path XP string
  'values: DisplayName, FileSysPath, Script, Parameter
  Dim strDispName, strFSP, strScript, strParam
  
  'for every hive
  For i = 0 To 1
  
  'for every script type
  For j = 0 To 1
  
  strSubTitle = 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 = 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 = Chr(34) & strDispName & Chr(34)
  '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 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
  
  '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 for directory
  'and append \Scripts\[script type]\
  If InStr(strScript,"\") = 0 Then
  strSPXP = strFSP & "\Scripts\" & arScrName(i,j) & "\"
  strCmd = strSPXP & strScript
  Else 'script has backslash, so is full path to script
  strCmd = strScript
  End If
  'if parameter string is not empty, append it
  If Trim(strParam) <> "" Then strScript = strScript & " " & strParam
  
  'write title lines if necessary for this master key
  TitleLineWrite
  oFN.WriteLine "DisplayName = " & strDispName
  
  'write script executable
  oFN.WriteLine strKey2 & "\" & " -> launches: " & Chr(34) &_
  strSPXP & strScript & Chr(34) & CoName(IDExe(strCmd))
  strSPXP = "" 'reset script path
  
  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?
  
  strTitle = "" : strSubTitle = "" : strSubSubTitle = ""
  
  End If 'flagTest?
  
  
  
  
  'XI. HKCR Protocols\Filter
  
  If Not flagTest Then 'skip if testing
  
  'filter counter
  Dim intFilterCnt : intFilterCnt = 0
  
  '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"
  strSubTitle = "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
  
  'count number of filters
  intFilterCnt = intFilterCnt + 1
  
  'set default values:
  'flagFound = True if CLSID & InProcServer32 values set
  'flagMatch = True if filter name, CLSID, InProcServer32 DLL, &
  ' DLL CoName match allowed values
  flagFound = True : flagMatch = False : flagInfect = True
  strWarn = "INFECTION WARNING! "
  
  'get the Filter CLSID value
  intErrNum1 = oReg.GetStringValue (HKLM,strKey & "\" & oKey,"CLSID",strValue1)
  
  'if CLSID name exists And value set (exc for W2K!)
  If intErrNum1 = 0 And strValue1 <> "" Then
  
  'prepare quote-embedded output string
  strOut1 = Chr(34) & strValue1 & Chr(34)
  
  'find CLSID InProcServer32 value and its CoName
  intErrNum2 = oReg.GetExpandedStringValue (HKLM,"Software\Classes\CLSID\" &_
  strValue1 & "\InProcServer32","",strValue2)
  
  'if InProcServer32 value exists And value set
  If intErrNum2 = 0 And strValue2 <> "" Then
  
  strCN = CoName(IDExe(strValue2)) 'find CoName
  'store output string
  strOut2 = StringFilter(strValue2,True) & strCN
  
  Else 'InProcServer32 value not set or empty
  
  'toggle flags, empty warning string
  flagFound = False : flagInfect = False
  strWarn = "" : strOut2 = "(value not set)"
  
  End If 'InProcServer32 value set?
  
  Else 'CLSID value not set or empty
  
  'toggle flags, empty warning string
  flagFound = False : flagInfect = False
  strWarn = "" : strOut1 = "(value not set)" : strOut2 = ""
  
  End If 'CLSID value set?
  
  'if both values set, check if filter is allowed
  If flagFound Then
  
  'check array for allowed entry
  For i = 0 To UBound(arFilter,1)
  
  'if filter name, CLSID value, DLL match arFilter & CoName = MS
  If LCase(oKey) = LCase(arFilter(i,0)) And _
  LCase(strValue1) = LCase(arFilter(i,1)) And _
  LCase(IDExe(strValue2)) = LCase(strFPSF & arFilter(i,2)) And _
  strCN = MS Then
  
  'toggle flag, empty warning string
  flagInfect = False : strWarn = "" : flagMatch = True : Exit For
  
  End If 'filter name & CLSID match arFilter?
  
  Next 'arFilter member
  
  End If 'flagFound?
  
  'if filter not in allowed array Or ShowAll
  If flagInfect Or flagShowAll Then
  
  TitleLineWrite
  
  On Error Resume Next
  'write the quote-delimited filter name and CLSID value
  oFN.WriteLine strWarn & oKey & "\CLSID = " & strOut1
  intErrNum = Err.Number : Err.Clear
  
  'not W2K: if Filter CLSID not set, intErrNum = 0 & strOut2 = ""
  'W2K : , intErrNum <> 0 & strOut2 = "(value not set)"
  If intErrNum = 0 And strOut2 <> "" Then
  
  oFN.WriteLine " -> {CLSID}\InProcServer32\(Default) = " & strOut2
  
  ElseIf intErrNum <> 0 Then 'WriteLine error, so just write first line
  
  oFN.WriteLine strWarn & oKey & "\CLSID = (value not set)"
  
  End If 'WriteLine error?
  On Error Goto 0
  
  End If 'flagInfect Or ShowAll?
  
  Next 'Filter subkey
  
  End If 'Filter subkeys exist?
  
  If flagShowAll Then TitleLineWrite
  
  'reset flags
  flagFound = False : flagMatch = False : flagInfect = False
  
  'reset strings
  strTitle = "" : strSubTitle = "" : strSubSubTitle = ""
  strWarn = ""
  
  'recover array memory
  ReDim arFilter(0)
  
  End If 'flagTest?
  
  
  
  
  'XII. Check file & folder context menu shell extensions
  
  If Not flagTest Then 'skip if testing
  
  Dim arClasses() : ReDim arClasses(2)
  arClasses(0) = "*" : arClasses(1) = "Directory" : arClasses(2) = "Folder"
  Dim arAllowedDLLs : arAllowedDLLs = Array("syncui.dll", "cscui.dll", _
  "shell32.dll", "runext.dll", "ntshrui.dll", "msshrui.dll", _
  "shcompui.dll")
  
  ' layout.dll, CoName = "Microsoft"
  
  For i = 0 To UBound(arClasses)
  
  strSubTitle = "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
  
  ResolveCLSID HKLM, "", strCLSID, 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 Then
  flagAllow = True : Exit For
  End If
  
  Next 'arAllowedDLLs element
  
  If Not flagAllow Or flagShowAll Then
  TitleLineWrite
  oFN.WriteLine strSubKey & "\(Default) = " & Chr(34) & strCLSID &_
  Chr(34) & vbCRLF & " -> {CLSID}\InProcServer32\(Default) = " &_
  Chr(34) & strIPSDLL & Chr(34) & CoName(IDExe(strIPSDLL))
  End If 'Not flagAllow Or ShowAll?
  
  End If 'strIPSDLL exists?
  
  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 'flagTest?
  
  
  
  
  'XIII. Check default executables for default strings
  
  If Not flagTest Then 'skip if testing
  
  'set up executables array
  Dim arExeExt : arExeExt = Array("bat","cmd","com","exe","hta","pif","scr")
  
  'set up expected value array
  Dim arExpVal : arExpVal = Array("""%1"" %*","""%1"" %*","""%1"" %*","""%1"" %*", _
  LCase(Fso.GetSpecialFolder(1)) & "\mshta.exe ""%1"" %*", _
  """%1"" %*","""%1"" /s")
  
  Dim strExeDef 'default executable string
  
  strTitle = "Default executables:"
  
  'for each executable type
  For i = 0 To UBound(arExeExt)
  
  'initialize strings: warning, CoName, default executable, output
  strWarn = "" : strCN = ""
  strExeDef = "" : strOut = ""
  
  'find the extension key to check
  strKey1 = "SOFTWARE\Classes\." & arExeExt(i)
  
  'find the file type at the default value
  intErrNum1 = oReg.GetStringValue (HKLM,strKey1,"",strValue1)
  
  'if file type exists And not empty
  If intErrNum1 = 0 And strValue1 <> "" Then
  
  'form the file type shell\open\command (S-O-C) string
  strKey2 = "SOFTWARE\Classes\" & strValue1 & "\shell\open\command"
  
  'look for the file type S-O-C value
  intErrNum2 = oReg.GetStringValue (HKLM,strKey2,"",strValue2)
  
  'if file type S-O-C value exists And not empty
  If intErrNum2 = 0 And strValue2 <> "" Then
  
  'set default executable & output strings
  strExeDef = strValue2 : strOut = strKey2
  
  'pointer value doesn't exist And O/S <> W98/WME/NT4
  'W98G/W98SE/NT4 ignore ext shell\open\cmd if file type doesn't exist
  'WME/W2K/WXP (incl SP2) interpret ext shell\open\cmd if file type doesn't exist
  ElseIf strOS = "WXP" Or strOS = "W2K" Or strOS = "WME" Then
  
  'look for ext S-O-C
  strKey3 = "SOFTWARE\Classes\." & arExeExt(i) & "\shell\open\command"
  
  intErrNum3 = oReg.GetStringValue (HKLM,strKey3,"",strValue3)
  
  'if ext S-O-C exists And not empty
  If intErrNum3 = 0 And strValue3 <> "" Then
  
  'set default executable & output strings
  strExeDef = strValue3 : strOut = strKey3
  
  End If 'ext S-O-C value exists?
  
  End If 'file type S-O-C exists?
  
  Else 'extension doesn't point to file type
  
  'look for ext S-O-C
  strKey3 = "SOFTWARE\Classes\." & arExeExt(i) & "\shell\open\command"
  
  intErrNum3 = oReg.GetStringValue (HKLM,strKey3,"",strValue3)
  
  'if ext S-O-C exists And not empty
  If intErrNum3 = 0 And strValue3 <> "" Then
  
  strExeDef = strValue3 : strOut = strKey3
  
  End If 'ext S-O-C exists?
  
  End If 'file type exists?
  
  'check against expected value, ShowAll
  If (strExeDef <> "" And Trim(LCase(strExeDef)) <> arExpVal(i)) Or flagShowAll Then
  
  'if not expected value, fill warnings & CoName
  If strExeDef <> "" And Trim(LCase(strExeDef)) <> arExpVal(i) Then
  strWarn = "INFECTION WARNING! " : strCN = CoName(IDExe(strExeDef))
  'if exec default string doesn't have ID'd coname, don't show it
  If strCN = " [file not found]" Then strCN = ""
  End If
  
  'output section titles if not done already
  TitleLineWrite
  
  'write exec extension name and key to file
  If strOut <> "" Then
  
  oFN.WriteLine vbCRLF & "." & UCase(arExeExt(i)) & ": " & "HKLM" &_
  "\" & strOut & "\"
  
  'output default executable value
  oFN.WriteLine strWarn & Chr(34) & "Default" & Chr(34) & " = " &_
  StringFilter(strExeDef,True) & strCN
  
  End If 'strOut empty?
  
  End If 'expected value found?
  
  Next 'next executable in array
  
  strTitle = "" : strSubTitle = "" : strSubSubTitle = ""
  
  'recover array memory
  ReDim arExeExt(0)
  ReDim arExpVal(0)
  
  End If 'flagTest?
  
  
  
  
  'XIV. System/Group Policies
  
  If Not flagTest Then 'skip if testing
  
  'assign System or Group Policy name
  Dim strPolName : strPolName = "System "
  If strOS = "W2K" Or strOS = "WXP" Then strPolName = "Group "
  
  Dim flagADClassicShell : flagADClassicShell = False 'True if ClassicShell disables AD
  Dim flagADEnabled : flagADEnabled = False 'True if AD is enabled by GP
  Dim flagADDisabled : flagADDisabled = False 'True if AD is disabled by GP
  Dim flagFADO : flagFADO = False 'True if ForceActiveDesktopOn is set
  Dim flagNAD : flagNAD = False 'True if NoActiveDesktop is set
  Dim flagNADC : flagNADC = False 'True if NoActiveDesktopChanges is set
  'True if ShellState setting should be examined
  'HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\ShellState
  Dim flagADviaSS : flagADviaSS = True
  Dim flagGPWPEntry : flagGPWPEntry = False 'True if GP wallpaper value sets WP
  Dim flagSkip : flagSkip = False 'True if skip write to output file
  Dim arDisCplNames, strDisCplName, strDisCplValue
  
  
  'set title line
  strTitle = strPolName & "Policies [Description]:"
  'add GPEdit location to title if GP used (W2K, WXP Pro)
  If flagGP Then strTitle = "Group Policies [Description] {enabled Group Policy setting}:"
  
  'examine Policies at Explorer & WindowsUpdate keys
  strKey = "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer"
  strSubTitle = "HKCU\" & strKey & "\"
  
  ReDim arNames(9,2)
  arNames(0,0) = "ClassicShell"
  arNames(0,1) = "[disables Active Desktop (overrides all other " &_
  "settings);" & vbCRLF & "removes the Display Properties|Web (tab); " &_
  "sets options in" & vbCRLF & "Windows Explorer|Tools|Folder Options...]"
  If strOS = "WXP" Then arNames(0,1) = "[removes the Display Properties|" &_
  "Desktop (tab); disables Active Desktop;" & vbCRLF & "(overrides " &_
  "all other settings); sets options in Windows Explorer|Tools|" &_
  vbCRLF & "Folder Options...]"
  If strOS = "W98" Or strOS = "NT4" Then arNames(0,1) = "[selects " &_
  "Classic style in Windows Explorer|View|Folder Options...]"
  arNames(0,2) = "{User Configuration|Administrative Templates|Windows " &_
  "Components|" & vbCRLF & "Windows Explorer|Enable Classic Shell}"
  If strOS = "WXP" Then arNames(0,2) = "{User Configuration|" &_
  "Administrative Templates|Windows Components|" & vbCRLF &_
  "Windows Explorer|Turn on Classic Shell}"
  
  arNames(1,0) = "ForceActiveDesktopOn"
  arNames(1,1) = "[enables Active Desktop and prevents disabling it]"
  arNames(1,2) = "{User Configuration|Administrative Templates|Desktop" &_
  "|Active Desktop|" & vbCRLF & "Enable Active Desktop}"
  
  arNames(2,0) = "NoActiveDesktop"
  arNames(2,1) = "[disables Active Desktop; removes Display Properties|" &_
  "Web (tab)]"
  If strOS = "WXP" Then arNames(2,1) = "[disables Active Desktop; " &_
  "removes Web tab from Display Properties|" & vbCRLF & "Desktop (tab)|" &_
  "Customize Desktop... (button)|Desktop Items (window)]"
  arNames(2,2) = "{User Configuration|Administrative Templates|Desktop" &_
  "|Active Desktop|" & vbCRLF & "Disable Active Desktop}"
  
  arNames(3,0) = "NoActiveDesktopChanges"
  arNames(3,1) = "[prevents changes to Active Desktop configuration;" &_
  " removes" & vbCRLF & "Display Properties|Web (tab)]"
  If strOS = "WXP" Then arNames(3,1) = "[prevents changes to Active Desktop; " &_
  "removes Web tab from Display Properties|" & vbCRLF & "Desktop (tab)|" &_
  "Customize Desktop... (button)|Desktop Items (window)]"
  arNames(3,2) = "{User Configuration|Administrative Templates|Desktop" &_
  "|Active Desktop|" & vbCRLF & "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
  arNames(4,0) = "DisallowCpl"
  arNames(4,1) = "[omits specific applets in Control Panel]"
  arNames(4,2) = "{User Configuration|Administrative Templates|Control Panel|" &_
  "Hide" & vbCRLF & "specified control panel applets|Policy (tab)|" &_
  "Show... (button)"
  If strOS = "WXP" Then arNames(4,2) = "{User Configuration|" &_
  "Administrative Templates|Control Panel|Hide" & vbCRLF &_
  "specified Control Panel applets|Setting (tab)|" &_
  "Show... (button)"
  
  arNames(5,0) = "NoToolbarCustomize"
  arNames(5,1) = "[removes the " & Chr(34) & "Customize..." & Chr(34) &_
  " menu option in Internet Explorer|View|Toolbars]"
  arNames(5,2) = "{User Configuration|Administrative Templates|Windows " &_
  "Components|" & vbCRLF & "Internet Explorer|Toolbars|Disable " &_
  "customizing browser toolbar buttons}"
  
  arNames(6,0) = "NoBandCustomize"
  arNames(6,1) = "[disables toolbar status changes in Internet Explorer|" &_
  "View|Toolbars]"
  arNames(6,2) = "{User Configuration|Administrative Templates|Windows " &_
  "Components|" & vbCRLF & "Internet Explorer|Toolbars|Disable " &_
  "customizing browser toolbars}"
  
  arNames(7,0) = "NoFolderOptions"
  'strOS = "WXP"/"WME"
  arNames(7,1) = "[removes Folder Options... from Windows Explorer|Tools " &_
  "menu and from" & vbCRLF & "Control Panel]"
  If strOS = "W98" Or strOS = "NT4" Then
  arNames(7,1) = "[removes Folder Options... from Windows Explorer|View menu]"
  ElseIf strOS = "W2K" Then
  arNames(7,1) = "[removes Folder Options... from Windows Explorer|Tools menu]"
  End If
  arNames(7,2) = "{User Configuration|Administrative Templates|Windows " &_
  "Components|" & vbCRLF & "Windows Explorer|Removes the Folder Options " &_
  "menu item from the Tools menu}"
  
  arNames(8,0) = "NoWindowsUpdate"
  arNames(8,1) = "[removes Windows Update GUI links and disables " &_
  "web site functionality]"
  If strOS = "W98" Or strOS = "WME" Or strOS = "NT4" Then _
  arNames(8,1) = "[removes Windows Update from Internet Explorer|Tools menu]"
  arNames(8,2) = "{User Configuration|Administrative Templates|Start " &_
  "Menu and Taskbar|" & vbCRLF & "Remove links and access to Windows " &_
  "Update}"
  
  'THIS MUST BE THE LAST ARRAY ROW
  arNames(9,0) = "DisableWindowsUpdateAccess"
  arNames(9,1) = "[disables Windows Update web site functionality]"
  arNames(9,2) = "{User Configuration|Administrative Templates|Windows " &_
  "Components|" & vbCRLF & "Windows Update|Remove access to use all " &_
  "Windows Update features}"
  
  'for every array member
  For i = 0 To UBound(arNames,1)
  
  'reset key & sub-title for WindowsUpdate value
  If i = 9 Then
  strKey = "Software\Microsoft\Windows\CurrentVersion\Policies\WindowsUpdate"
  strSubTitle = "HKCU\" & strKey & "\"
  End If
  
  'try to retrieve the value
  intErrNum = oReg.GetDWORDValue (HKCU,strKey,arNames(i,0),intValue)
  
  'if value exists And sets GP
  If intErrNum = 0 And (intValue And 1) = 1 Then
  
  flagSkip = False 'assume not skipped
  strWarn = "HIJACK WARNING! " : strOut = "" 'empty output string
  
  Select Case i
  
  Case 0 'ClassicShell disables AD (exc in W98; in WMe, stops WP value
  ' from choosing WP but allows WP value
  ' to disable Background tab)
  flagADClassicShell = True : flagADviaSS = False
  flagADDisabled = True : strWarn = ""
  If strOS = "W98" Or strOS = "NT4" Then
  flagADClassicShell = False : flagADviaSS = True
  flagADDisabled = False
  End If
  
  Case 1 'ForceActiveDesktopOn
  
  flagFADO = True
  
  If (strOS <> "W98" And strOS <> "NT4" And Not flagADClassicShell) Then
  flagADEnabled = True 'ForceActiveDesktopOn overrules NoActiveDesktop
  flagADviaSS = False
  ElseIf strOS = "W98" Or strOS = "NT4" Then
  flagFADO = False : flagSkip = True 'value not used in these O/S's
  End If
  
  Case 2 'NoActiveDesktop
  
  flagNAD = True : strWarn = ""
  
  If Not flagFADO Then 'if FADO not set
  flagADDisabled = True : flagADviaSS = False
  Else 'FADO enabled
  arNames(2,1) = "[normally disables Active Desktop, but overruled " &_
  "by " & Chr(34) & "ForceActiveDesktopOn" & Chr(34) & "]"
  If Not flagADClassicShell Then flagADDisabled = False
  End If
  
  Case 3 'NoActiveDesktopChanges
  flagNADC = True
  
  Case 4
  flagSkip = True 'value ignored in W2K & WXP
  
  Case 9
  'DisableWindowsUpdateAccess has no effect in W9x
  If strOS = "W98" Or strOS = "WME" Or strOS = "NT4" Then flagSkip = True
  
  End Select
  
  If Not flagSkip Then 'output title lines
  
  If strTitle <> "" Then
  TitleLineWrite
  Else
  oFN.WriteBlankLines(1)
  End If
  
  'output name=value, description, GP policy location
  oFN.WriteLine strWarn & Chr(34) & arNames(i,0) & Chr(34) &_
  "=dword:00000001 " & vbCRLF & arNames(i,1) & strOut
  If flagGP Then oFN.WriteLine arNames(i,2)
  
  End If 'flagSkip?
  
  Else 'value doesn't exist or doesn't set GP
  
  If flagShowAll Then TitleLineWrite
  
  End If 'value = 1?
  
  Next 'array member
  
  
  'DisallowCpl"
  'look for omitted Control Panel applets
  strKey = "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\DisallowCpl"
  strSubTitle = "HKCU\" & strKey & "\"
  
  If strOS = "W2K" Or strOSXP = "Windows XP Home" Then 'only works in these O/S's
  
  '.CPL file names & applet titles can be used to hide Control Panel applets
  'script will not not detect applet exclusion via title on foreign-language versions
  'detection of English-language title on foreign-language W2K version
  'would provide false positive, so recognition of titles abandoned -- any
  'unrecognized value string is output as suspect
  Dim arCplets : Set arCplets = CreateObject("Scripting.Dictionary") 'key, item
  
  'W2K: appwiz.cpl omits both Add/Remove Programs and Folder Options,
  'but title allows individual exclusion (which will *not* be detected here)
  'WXPH: appwiz.cpl only omits Add and Remove Programs
  If strOS = "W2K" Then
  arCplets.Add "appwiz.cpl", Chr(34) & "Add/Remove Programs" & Chr(34) &_
  ", " & Chr(34) & "Folder Options" & Chr(34)
  ElseIf strOS = "WXP" Then
  arCplets.Add "appwiz.cpl", Chr(34) & "Add or Remove Programs" & Chr(34)
  End If
  
  arCplets.Add "desk.cpl", Chr(34) & "Display Properties" & Chr(34)
  arCplets.Add "inetcpl.cpl", Chr(34) & "Internet Options" & Chr(34)
  
  If strOS = "WXP" Then
  arCplets.Add "firewall.cpl", Chr(34) & "Windows Firewall" & Chr(34)
  arCplets.Add "wscui.cpl", Chr(34) & "Windows Security Center" & Chr(34)
  End If
  
  Dim arCpletsk : arCpletsk = arCplets.Keys
  Dim arCpletsi : arCpletsi = arCplets.Items
  
  'retrieve list of hidden cpl names
  intErrNum2 = oReg.EnumValues (HKCU,strKey,arDisCplNames,arType)
  
  'if names exist
  If intErrNum2 = 0 And IsArray(arDisCplNames) Then
  
  strSubSubTitle = "HIJACK WARNING! The following applets are not " &_
  "displayed in Control Panel:" & vbCRLF
  
  'for each name
  For Each strDisCplName In arDisCplNames
  
  'retrieve the value
  intErrNum3 = oReg.GetStringValue(HKCU, strKey, strDisCplName, strDisCplValue)
  
  'if value exists
  If intErrNum3 =0 And strDisCplValue <> "" Then
  
  strOut = "" : flagMatch = False
  
  'look for matching applet file name
  For j = 0 To UBound(arCpletsk)

  0
• Treadstone71

  February 2006 edited February 2006

  'if match found, output Control Panel applet name and title
  If LCase(Trim(strDisCplValue)) = LCase(arCpletsk(j)) Then
  strOut = Space(2) & arCpletsk(j) & " (" & arCpletsi(j) & ")"
  flagMatch = True : Exit For
  End If
  
  Next 'cpl applet
  
  If Not flagMatch Then strOut = Space(2) & strDisCplValue &_
  " (unrecognized file name)"
  
  TitleLineWrite
  
  On Error Resume Next
  oFN.WriteLine strOut : intErrNum = Err.Number : Err.Clear
  On Error Goto 0
  If intErrNum <> 0 Then oFN.WriteLine " (unwritable string)"
  
  End If 'value exists?
  
  Next 'value name
  
  If flagGP Then oFN.WriteLine vbCRLF & arNames(4,2)
  strSubSubTitle = ""
  
  Else 'names don't exist
  
  If flagShowAll Then TitleLineWrite
  
  End If 'names exist?
  
  'empty the dictionary
  arCplets.RemoveAll : Set arCplets=Nothing
  
  End If 'W2K/WXPH?
  
  
  'examine Policies at System key
  strKey = "Software\Microsoft\Windows\CurrentVersion\Policies\System"
  strWarn = "HIJACK WARNING! "
  strSubTitle = "HKCU\" & strKey & "\"
  
  ReDim arNames(4,2)
  arNames(0,0) = "DisableRegistryTools"
  If strOS = "W98" Or strOS = "WME" Or strOS = "WXP" Then
  arNames(0,1) = "[prohibits launch of REGEDIT.EXE]"
  Else 'NT4 or W2K
  arNames(0,1) = "[prohibits launch of REGEDIT.EXE and REGEDT32.EXE]"
  End If
  arNames(0,2) = "{User Configuration|Administrative Templates|System|" &_
  vbCRLF & "Disable registry editing tools}"
  If strOS = "WXP" Then arNames(0,2) = "{User Configuration|" &_
  "Administrative Templates|System|Prevent access to" & vbCRLF &_
  "registry editing tools}"
  
  arNames(1,0) = "NoDispBackgroundPage"
  arNames(1,1) = "[removes Display Properties, Background (tab)]"
  If strOS = "WXP" Then arNames(1,1) = "[removes Display Properties, Desktop (tab)]"
  arNames(1,2) = "{User Configuration|Administrative Templates|Control Panel" &_
  "|Display|" & vbCRLF & "Hide Background tab}"
  If strOS = "WXP" Then arNames(1,2) = "{User Configuration|" &_
  "Administrative Templates|Control Panel|Display|" & vbCRLF &_
  "Hide Desktop tab}"
  
  arNames(2,0) = "NoDispCpl"
  arNames(2,1) = "[disables Display in Control Panel]"
  arNames(2,2) = "{User Configuration|Administrative Templates|Control Panel" &_
  "|Display|" & vbCRLF & "Disable Display in Control Panel}"
  If strOS = "WXP" Then arNames(2,2) = "{User Configuration|" &_
  "Administrative Templates|Control Panel|Display|" & vbCRLF &_
  "Remove Display in Control Panel}"
  
  arNames(3,0) = "Wallpaper"
  arNames(3,1) = "[disables Display Properties|Background (tab); " &_
  "selects wallpaper if" & vbCRLF & "Active Desktop is enabled]"
  If strOS = "WXP" Then
  arNames(3,1) = "[disables the Display Properties|Desktop (tab) " &_
  "(except the " & Chr(34) & "Customize" & vbCRLF & "Desktop..." &_
  Chr(34) & " button); selects wallpaper if Active Desktop is enabled]"
  If strOSXP = "Windows XP Professional SP2" Then _
  arNames(3,1) = "[disables the Display Properties|Desktop (tab) " &_
  "(except the " & Chr(34) & "Customize" & vbCRLF & "Desktop..." &_
  Chr(34) & " button); selects wallpaper and enables Active Desktop]"
  Else 'for any non-XP O/S
  If flagNAD And Not flagFADO Then
  arNames(3,1) = "[normally disables Display Properties|" &_
  "Background (tab) and" & vbCRLF & "selects wallpaper if Active " &_
  "Desktop is enabled, but overruled" & vbCRLF & "by " & Chr(34) &_
  "NoActiveDesktop" & Chr(34) & "]"
  ElseIf flagNADC Then
  arNames(3,1) = "[normally disables Display Properties|" &_
  "Background (tab), but" & vbCRLF & "overruled by " & Chr(34) &_
  "NoActiveDesktopChanges" & Chr(34) & "; selects wallpaper if" &_
  vbCRLF & "Active Desktop is enabled]"
  End If 'flagNAD/flagFADO/flagNADC?
  End If 'WXP?
  arNames(3,2) = "{User Configuration|Administrative Templates|Desktop" &_
  "|Active Desktop|" & vbCRLF & "Active Desktop Wallpaper|Wallpaper Name:}"
  
  arNames(4,0) = "WallpaperStyle"
  arNames(4,1) = "[disables " & Chr(34) & "Picture Display:" & Chr(34) &_
  " control only in Display Properties|" & vbCRLF & "Background (tab)]"
  If strOS = "WXP" Then arNames(4,1) = "[selects " & Chr(34) & "Position:" &_
  Chr(34) & " in Display Properties|Desktop (tab)" & vbCRLF &_
  "if Active Desktop is enabled]"
  arNames(4,2) = "{User Configuration|Administrative Templates|Desktop" &_
  "|Active Desktop|" & vbCRLF & "Active Desktop Wallpaper|Wallpaper Style:}"
  
  For i = 0 To UBound(arNames,1)
  
  If i < 3 Then intErrNum = oReg.GetDWORDValue (HKCU,strKey,arNames(i,0),intValue)
  'Wallpaper & WallpaperStyle values are strings
  If i = 3 Or i = 4 Then intErrNum = oReg.GetStringValue (HKCU,strKey,arNames(i,0),strValue)
  
  If intErrNum = 0 Then 'if value exists
  
  flagSkip = True 'assume value not output
  
  Select Case i
  
  Case 0 'DisableRegistryTools
  
  If (intValue And 1) = 1 Then flagSkip = False
  strOut = "HIJACK WARNING! " & Chr(34) & arNames(i,0) & Chr(34) &_
  "=dword:00000001 " & vbCRLF & arNames(i,1)
  
  Case 1 'NoDispBackgroundPage
  
  If (intValue And 1) = 1 Then flagSkip = False
  strOut = "HIJACK WARNING! " & Chr(34) & arNames(i,0) & Chr(34) &_
  "=dword:00000001 " & vbCRLF & arNames(i,1)
  
  Case 2 'NoDispCpl
  
  If (intValue And 1) = 1 Then flagSkip = False
  strOut = "HIJACK WARNING! " & Chr(34) & arNames(i,0) & Chr(34) &_
  "=dword:00000001 " & vbCRLF & arNames(i,1)
  
  Case 3 'Wallpaper
  
  If strOS = "W98" Or strOS = "NT4" Then
  flagSkip = True 'value not used under W98 & NT4
  Else 'any other O/S
  flagSkip = False
  If Not flagADDisabled Then
  flagGPWPEntry = True 'value may be looked at unless GP already disabled
  If strOSXP = "Windows XP Professional SP2" Then
  'under WXP Pro SP2, value enables AD unless AD already disabled
  flagADEnabled = True : flagADviaSS = False
  End If 'strOSXP?
  End If 'flagADDisabled?
  strOut = "HIJACK WARNING! " & Chr(34) & arNames(i,0) & Chr(34) &_
  " = " & Chr(34) & strValue & Chr(34) & vbCRLF & arNames(i,1)
  End If 'strOS?
  
  Case 4 'WallpaperStyle
  
  If strOS = "W98" Or strOS = "NT4" Then
  flagSkip = True
  Else
  If strValue <> "" Then flagSkip = False
  
  intValue = CInt(strValue) 'convert to integer
  
  'WallpaperStyle (0 centered, 1 tiled, 2 stretched)
  
  If intValue = 0 Then
  strLine1 = "Center"
  ElseIf (intValue And 1) = 1 Then
  strLine1 = "Tile"
  ElseIf (intValue And 2) = 2 Then
  strLine1 = "Stretch"
  End If
  
  strOut = "HIJACK WARNING! " & Chr(34) & arNames(i,0) & Chr(34) &_
  " = " & Chr(34) & CStr(intValue) & Chr(34) &_
  " [" & strLine1 & "]" & vbCRLF & arNames(i,1)
  
  End If 'strOS?
  
  End Select
  
  If Not flagSkip Then
  
  If strTitle <> "" Then
  TitleLineWrite
  Else
  oFN.WriteBlankLines(1)
  End If
  
  On Error Resume Next
  oFN.WriteLine strOut
  intErrNum1 = Err.Number : Err.Clear
  On Error Goto 0
  
  If intErrNum1 <> 0 Then _
  oFN.WriteLine Chr(34) & arNames(i,0) & Chr(34) &_
  " = (value not set)" & vbCRLF & arNames(i,1)
  If flagGP Then oFN.WriteLine arNames(i,2)
  
  End If 'flagSkip?
  
  Else 'value not found
  
  If flagShowAll Then TitleLineWrite
  
  End If 'value exists?
  
  Next 'array value
  
  
  'examine Policies at ActiveDesktop key
  strKey = "Software\Microsoft\Windows\CurrentVersion\Policies\ActiveDesktop"
  strSubTitle = "HKCU\" & strKey & "\"
  
  ReDim arNames(3,2)
  arNames(0,0) = "NoChangingWallPaper"
  arNames(0,1) = "[disables options on Display Properties|Background (tab)]"
  If flagNADC Then arNames(0,1) = "[normally disables options on Display " &_
  "Properties|Background (tab)," & vbCRLF & "but overruled by " &_
  Chr(34) & "NoActiveDesktopChanges" & Chr(34) & "]"
  If strOS = "WXP" Then arNames(0,1) = _
  "[disables " & Chr(34) & "Background:" & Chr(34) & " list on Display " &_
  "Properties|Desktop (tab)]"
  arNames(0,2) = "{User Configuration|Administrative Templates|Control " &_
  "Panel|Display|" & vbCRLF & "Disable changing wallpaper}"
  If strOS = "WXP" Then arNames(0,2) = "{User Configuration|Administrative " &_
  "Templates|Control Panel|Display|" & vbCRLF & "Prevent changing wallpaper}"
  
  arNames(1,0) = "NoClosingComponents"
  arNames(1,1) = "[disables close button for web content on desktop; " &_
  "removes open/close" & vbCRLF & "check box from web content on " &_
  "Display Properties|Web (tab)]"
  If strOS = "WXP" Then arNames(1,1) = _
  "[" & Chr(34) & "Web pages:" & Chr(34) & " list items on Display " &_
  "Properties|Desktop (tab)|" & vbCRLF & "Customize Desktop... (button)|" &_
  "Desktop Items (window)|Web (tab)" & vbCRLF & "have no check box]"
  arNames(1,2) = "{User Configuration|Administrative Templates|Desktop" &_
  "|Active Desktop|" & vbCRLF & "Prohibit closing items}"
  
  arNames(2,0) = "NoDeletingComponents"
  arNames(2,1) = "[disables " & Chr(34) & "Delete" & Chr(34) & " button " &_
  "on Display Properties|Web (tab)]"
  If strOS = "WXP" Then arNames(2,1) = _
  "[disables " & Chr(34) & "Delete" & Chr(34) & " button on Display " &_
  "Properties|Desktop (tab)|" & vbCRLF & "Customize Desktop... (button)|" &_
  "Desktop Items (window)|Web (tab)]"
  arNames(2,2) = "{User Configuration|Administrative Templates|Desktop" &_
  "|Active Desktop|" & vbCRLF & "Prohibit deleting items}"
  
  arNames(3,0) = "NoEditingComponents"
  arNames(3,1) = "[disables " & Chr(34) & "Properties" & Chr(34) & " button " &_
  "on Display Properties|Web (tab)]"
  If strOS = "WXP" Then arNames(3,1) = _
  "[disables " & Chr(34) & "Properties" & Chr(34) & " button on Display " &_
  "Properties|Desktop (tab)|" & vbCRLF & "Customize Desktop... (button)|" &_
  "Desktop Items (window)|Web (tab)]"
  arNames(3,2) = "{User Configuration|Administrative Templates|Desktop" &_
  "|Active Desktop|" & vbCRLF & "Prohibit editing items}"
  
  
  For i = 0 To UBound(arNames,1)
  
  'get the value
  intErrNum = oReg.GetDWORDValue (HKCU,strKey,arNames(i,0),intValue)
  
  'if value exists and GP set
  If intErrNum = 0 And (intValue And 1) = 1 Then
  
  If strTitle <> "" Then
  TitleLineWrite
  Else
  oFN.WriteBlankLines(1)
  End If
  
  oFN.WriteLine "HIJACK WARNING! " & Chr(34) & arNames(i,0) & Chr(34) &_
  "=dword:00000001 " & vbCRLF & arNames(i,1)
  If flagGP Then oFN.WriteLine arNames(i,2)
  
  Else 'value doesn't exist or doesn't set GP
  
  If flagShowAll Then TitleLineWrite
  
  End If 'value = 1?
  
  Next 'array value
  
  
  'examine Internet Explorer Policies
  strKey = "Software\Policies\Microsoft\Internet Explorer\Control Panel"
  strSubTitle = "HKCU\" & strKey & "\"
  strWarn = "HIJACK WARNING! "
  
  ReDim arNames(8,2)
  
  arNames(0,0) = "GeneralTab"
  arNames(0,1) = "[removes the Internet Options|General (tab)]"
  arNames(0,2) = "{User Configuration|Administrative Templates|" &_
  "Windows Components|" & vbCRLF & "Internet Explorer|Internet " &_
  "Control Panel|Disable the General page}"
  
  arNames(1,0) = "HomePage"
  arNames(1,1) = "[disables the Home page field in Internet Options|" &_
  "General (tab)]"
  arNames(1,2) = "{User Configuration|Administrative Templates|" &_
  "Windows Components|" & vbCRLF & "Internet Explorer|Disable " &_
  "changing home page settings}"
  
  arNames(2,0) = "ConnectionsTab"
  arNames(2,1) = "[removes the Internet Options|Connections (tab)]"
  arNames(2,2) = "{User Configuration|Administrative Templates|" &_
  "Windows Components|" & vbCRLF & "Internet Explorer|Internet " &_
  "Control Panel|Disable the Connections page}"
  
  arNames(3,0) = "Connection Settings"
  arNames(3,1) = "[disables all controls except the the " & Chr(34) &_
  "Setup..." & Chr(34) & " button in" & vbCRLF & "Internet Options|" &_
  "Connections (tab)]"
  arNames(3,2) = "{User Configuration|Administrative Templates|" &_
  "Windows Components|" & vbCRLF & "Internet Explorer|Disable " &_
  "changing connection settings}"
  
  arNames(4,0) = "Proxy"
  arNames(4,1) = "[disables controls in Internet Options|Connections (tab)|" &_
  vbCRLF & "LAN Settings...|Proxy server]"
  arNames(4,2) = "{User Configuration|Administrative Templates|" &_
  "Windows Components|" & vbCRLF & "Internet Explorer|Disable " &_
  "changing proxy settings}"
  
  arNames(5,0) = "SecurityTab"
  arNames(5,1) = "[removes the Internet Options|Security (tab)]"
  arNames(5,2) = "{User Configuration|Administrative Templates|" &_
  "Windows Components|" & vbCRLF & "Internet Explorer|Internet " &_
  "Control Panel|Disable the Security page}"
  
  arNames(6,0) = "ResetWebSettings"
  arNames(6,1) = "[disables the " & Chr(34) & "Reset Web Settings..." &_
  Chr(34) & " button in Internet Options|" & vbCRLF & "Programs (tab)]"
  arNames(6,2) = "{User Configuration|Administrative Templates|" &_
  "Windows Components|" & vbCRLF & "Internet Explorer|Disable " &_
  "the Reset Web Settings feature}"
  
  'THIS ROW CHANGES THE POLICIES KEY
  arNames(7,0) = "NoBrowserOptions"
  arNames(7,1) = "[disables Tools|Internet Options... in Internet Explorer]"
  arNames(7,2) = "{User Configuration|Administrative Templates|" &_
  "Windows Components|" & vbCRLF & "Internet Explorer|Browser Menus|" &_
  "Tools menu: Disable Internet" & vbCRLF & "Options... menu option}"
  
  arNames(8,0) = "NoExtensionManagement"
  arNames(8,1) = "[disables Settings radio buttons in Tools|Manage " &_
  "Add-ons... in Internet Explorer]"
  arNames(8,2) = "{User Configuration|Administrative Templates|" &_
  "Windows Components|" & vbCRLF & "Internet Explorer|Do not allow " &_
  "users to enable or disable add-ons}"
  
  'for every array member
  For i = 0 To UBound(arNames,1)
  
  flagSkip = False
  
  'set up different key for NoBrowserOptions & NoExtensionManagement
  If i = 7 Then
  strKey = "Software\Policies\Microsoft\Internet Explorer\Restrictions"
  strSubTitle = "HKCU\" & strKey & "\"
  End If
  
  If i = 8 And strOSLong <> "Windows XP SP2" Then flagSkip = True
  
  If Not flagSkip Then
  
  'try to retrieve the value
  intErrNum = oReg.GetDWORDValue (HKCU,strKey,arNames(i,0),intValue)
  
  'if value exists And sets GP
  If intErrNum = 0 And (intValue And 1) = 1 Then
  
  'output titles
  If strSubTitle <> "" Then
  TitleLineWrite
  Else
  oFN.WriteBlankLines(1)
  End If
  
  'output name=value, description, GP location
  oFN.WriteLine strWarn & Chr(34) & arNames(i,0) & Chr(34) &_
  "=dword:00000001 " & vbCRLF & arNames(i,1)
  If flagGP Then oFN.WriteLine arNames(i,2)
  
  Else 'value doesn't exist or doesn't set GP
  
  If flagShowAll Then TitleLineWrite
  
  End If 'value = 1?
  
  End If 'flagSkip?
  
  Next 'array member
  
  
  'has no effect in WMe
  If strOS = "WXP" Then
  
  'examine Policies at HKLM... Windows NT key
  strKey = "Software\Policies\Microsoft\Windows NT\SystemRestore"
  strSubTitle = "HKLM\" & strKey & "\"
  
  ReDim arNames(1,2)
  arNames(0,0) = "DisableSR"
  arNames(0,1) = "[removes Control Panel|System|System Restore (tab) and disables applet]"
  arNames(0,2) = "{Computer Configuration|Administrative Templates|System|" &_
  "System Restore|" & vbCRLF & "Turn off System Restore}"
  
  arNames(1,0) = "DisableConfig"
  arNames(1,1) = "[disables options on Control Panel|System|System Restore (tab)]"
  arNames(1,2) = "{Computer Configuration|Administrative Templates|System|" &_
  "System Restore|" & vbCRLF & "Turn off Configuration}"
  
  'for every array member
  For i = 0 To UBound(arNames,1)
  
  'try to retrieve the value
  intErrNum = oReg.GetDWORDValue (HKLM,strKey,arNames(i,0),intValue)
  
  'if value exists And sets GP
  If intErrNum = 0 And (intValue And 1) Then
  
  'output titles
  If strSubTitle <> "" Then
  TitleLineWrite
  Else
  oFN.WriteBlankLines(1)
  End If
  
  'output name=value, description, GP location
  oFN.WriteLine strWarn & Chr(34) & arNames(i,0) & Chr(34) &_
  "=dword:00000001 " & vbCRLF & arNames(i,1)
  If flagGP Then oFN.WriteLine arNames(i,2)
  
  Else 'value doesn't exist or doesn't set GP
  
  If flagShowAll Then TitleLineWrite
  
  End If 'value = 1?
  
  Next 'array member
  
  End If 'WXP?
  
  
  strTitle = "" : strSubTitle = "" : strSubSubTitle = ""
  
  'recover array memory
  ReDim arNames(0)
  
  End If 'flagTest?
  
  
  
  
  'XV. Active Desktop, wallpaper & screen saver
  
  If Not flagTest Then 'skip if testing
  
  Dim arBValue()
  Dim flagIEWPSet : flagIEWPSet = False
  
  'title line string
  strTitle = "Active Desktop and Wallpaper:"
  
  
  'Active Desktop
  
  If flagADviaSS Then
  
  '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
  flagADEnabled = True
  ReDim arBValue(0) 'recover array memory
  TitleLineWrite
  oFN.WriteLine vbCRLF & "Active Desktop is enabled at this entry:" &_
  vbCRLF & "HKCU\" & strKey & "\ShellState"
  Else
  TitleLineWrite : flagADDisabled = True
  oFN.WriteLine vbCRLF & "Active Desktop is 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?
  
  ElseIf flagADEnabled Then
  
  TitleLineWrite
  oFN.WriteLine vbCRLF & "Active Desktop enabled via " & strPolName & "Policy."
  
  ElseIf flagADDisabled Then
  
  TitleLineWrite
  oFN.WriteLine vbCRLF & "Active Desktop disabled via " & strPolName & "Policy."
  
  End If 'flagADviaSS?
  
  
  'Wallpaper
  
  'if AD enabled And WP Not set in GP
  If flagADEnabled And Not flagGPWPEntry Then
  
  'check for AD wallpaper
  strKey = "Software\Microsoft\Internet Explorer\Desktop\General"
  strSubTitle = "HKCU\" & strKey & "\"
  
  intErrNum = oReg.GetStringValue (HKCU,strKey,"Wallpaper",strValue)
  
  'if AD wallpaper value set
  If intErrNum = 0 And strValue <> "" Then 'exc for W2K!
  
  'toggle flag
  flagIEWPSet = True
  
  'write value
  On Error Resume Next
  TitleLineWrite
  oFN.WriteLine Chr(34) & "Wallpaper" & Chr(34) & " = " &_
  Chr(34) & strValue & Chr(34)
  intErrNum1 = Err.Number : Err.Clear
  On Error Goto 0
  If intErrNum1 <> 0 Then oFN.WriteLine Chr(34) & "Wallpaper" &_
  Chr(34) & " = (value not set)"
  
  End If 'AD wallpaper value set?
  
  ElseIf flagADEnabled And flagGPWPEntry Then
  
  oFN.WriteLine vbCRLF & "Wallpaper selected via " & strPolName & "Policy."
  
  End If 'flagADEnabled And Not flagGPWPEntry?
  
  
  'if WP not set via IE, look for it at HKCU\Control Panel\Desktop
  If Not flagGPWPEntry And Not flagIEWPSet Then
  
  'retrieve Wallpaper value
  strKey = "Control Panel\Desktop"
  strSubTitle = "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 Chr(34) & "Wallpaper" & Chr(34) & " = " &_
  Chr(34) & strValue & Chr(34)
  intErrNum2 = Err.Number : Err.Clear
  On Error Goto 0
  If intErrNum2 <> 0 Then oFN.WriteLine Chr(34) & "Wallpaper" &_
  Chr(34) & " = (value not set)"
  
  Else 'WP value not present
  
  If flagShowAll Then
  TitleLineWrite
  oFN.WriteLine Chr(34) & "Wallpaper" & Chr(34) & " = (value not set)"
  End If
  
  End If 'wallpaper value set?
  
  End If 'flagADDisabled Or W2K?
  
  
  'web content
  
  If flagADEnabled Then
  
  '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:"
  
  '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 Chr(34) & "FriendlyName" & Chr(34) & " = " &_
  Chr(34) & strValue1 & Chr(34)
  intErrNum2 = Err.Number : Err.Clear
  If intErrNum2 <> 0 Then oFN.WriteLine Chr(34) & "FriendlyName" &_
  Chr(34) & " = (value not set)"
  
  oFN.WriteLine Chr(34) & "Source" & Chr(34) & " = " &_
  Chr(34) & strValue2 & Chr(34)
  intErrNum2 = Err.Number : Err.Clear
  If intErrNum2 <> 0 Then oFN.WriteLine Chr(34) & "Source" &_
  Chr(34) & " = (value not set)"
  
  oFN.WriteLine Chr(34) & "SubscribedURL" & Chr(34) & " = " &_
  Chr(34) & strValue3 & Chr(34)
  intErrNum2 = Err.Number : Err.Clear
  If intErrNum2 <> 0 Then oFN.WriteLine Chr(34) & "SubscribedURL" &_
  Chr(34) & " = (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
  
  End If 'flagADEnabled?
  
  strSubTitle = ""
  
  
  '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 Chr(34) & "SCRNSAVE.EXE" & Chr(34) & " = " &_
  Chr(34) & strValue & Chr(34) & strLFN & CoName(IDExe(strValue))
  intErrNum = Err.Number : Err.Clear
  On Error Goto 0
  
  If intErrNum <> 0 Then oFN.WriteLine Chr(34) & "SCRNSAVE.EXE" &_
  Chr(34) & " = (value not set)"
  
  Else 'Scrnsave.exe value doesn't exist
  
  'if ShowAll, output title line
  If flagShowAll Then
  
  TitleLineWrite
  oFN.WriteLine Chr(34) & "SCRNSAVE.EXE" & Chr(34) & " = (value not set)"
  
  End If 'flagShowAll
  
  End If 'Scrnsave.exe value exists?
  
  End If 'strOS <> W98/WME?
  
  strTitle = "" : strSubTitle = "" : strSubSubTitle = ""
  
  End If 'flagTest?
  
  
  
  
  'XVI. For W98/WME, check inside WIN.INI (load=, run=), SYSTEM.INI (shell=) &
  ' for W98 only, list contents of non-empty WINSTART.BAT
  
  If Not flagTest Then 'skip if testing
  
  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?
  
  End If 'strOS = W98/WME
  
  strTitle = "" : strSubTitle = "" : strSubSubTitle = ""
  
  End If 'flagTest?
  
  
  
  
  'XVII. AUTORUN.INF in root directory of local fixed disks for which
  ' autorun is enabled
  
  If Not flagTest Then 'skip if testing
  
  '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,
  'integer work variable
  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:"
  
  'HKLM NoDriveTypeAutoRun Fixed Disks Enabled
  Public flagHKLM_NDTAR_FDE : flagHKLM_NDTAR_FDE = True
  'HKCU NoDriveTypeAutoRun Fixed Disks Enabled
  Public flagHKCU_NDTAR_FDE : flagHKCU_NDTAR_FDE = True
  
  'HKLM NoDriveTypeAutoRun value exists
  Public flagHKLM_NDTAR : flagHKLM_NDTAR = False
  'HKCU NoDriveTypeAutoRun value exists (unused, passed for consistency)
  Public flagHKCU_NDTAR : flagHKCU_NDTAR = False
  
  'HKLM NoDriveAutoRun value exists
  Public flagHKLM_NDAR : flagHKLM_NDAR = False
  'HKCU NoDriveAutoRun value exists (unused, passed for consistency)
  Public flagHKCU_NDAR : flagHKCU_NDAR = False
  
  strKey = "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer"
  
  NDTAR HKLM, flagHKLM_NDTAR, flagHKLM_NDTAR_FDE
  If Not flagHKLM_NDTAR Then NDTAR HKCU, flagHKCU_NDTAR, flagHKCU_NDTAR_FDE
  
  'if NoDriveTypeAutoRun permits autorun on fixed disks, look at
  'individual disks
  If flagHKLM_NDTAR_FDE And flagHKCU_NDTAR_FDE Then
  
  'enumerate fixed disks
  Set colDisks = GetObject("winmgmts:\root\cimv2")._
  ExecQuery("SELECT * FROM Win32_LogicalDisk WHERE DriveType = 3")
  
  j = 0
  
  'fmt of DeviceID & Name is "A:"
  For Each oDisk in colDisks
  
  'for every dict entry
  For i = 0 To 25
  
  'find dictionary element number for drive letter
  If dictDL.Item(i) = oDisk.DeviceID Then
  
  'store disk letter, power of two for that letter,
  'set autorun flag to True, increment counter
  ReDim Preserve arFixedDisks(2,j)
  arFixedDisks(0,j) = oDisk.DeviceID
  arFixedDisks(1,j) = 2^i
  arFixedDisks(2,j) = True
  j = j + 1
  
  End If 'dict drive letter located?
  
  Next 'dict entry
  
  Next 'disk in colDisks
  
  NDAR HKLM, flagHKLM_NDAR
  If Not flagHKLM_NDAR Then NDAR HKCU, flagHKCU_NDAR
  
  'for every fixed disk
  For i = 0 To UBound(arFixedDisks,2)
  
  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 -> (" & Chr(34) & "open" & Chr(34) &_
  " & " & Chr(34) & "shellexecute" & Chr(34) & " 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 'flagTest?
  
  
  
  
  'XVIII. Check for DESKTOP.INI in local hard disk directories
  
  If Not flagTest Then 'skip if testing
  
  '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")
  
  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 'flagTest?
  
  
  
  
  'XIX. Enumerate contents of startup directories
  
  If Not flagTest Then 'skip if testing
  
  'All Users StartUp Folder title string (empty by default)
  Dim flagAUSUF : flagAUSUF = False
  Dim flagFE : flagFE = True 'folder exists flag
  
  'in W98/WME, see if local-language-specific All Users startup folder location
  'appears in registry and form title string if it does
  If strOS = "W98" Or strOS = "WME" Then
  
  'look for Common Startup value
  strKey = "Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders"
  oReg.GetStringValue HKLM,strKey,"Common Startup",strValue
  
  'if Common Startup name exists and value not empty, toggle flag
  If Not IsNull(strValue) And strValue <> "" Then flagAUSUF = True
  
  End If
  
  'startup folder short names
  If strOS = "W98" Or strOS = "WME" Then
  arSUFN = Array("Startup")
  Else
  arSUFN = Array("Startup","AllUsersStartup")
  End If
  
  'form output file section title string
  strLine = "Startup items in "
  
  'in W98/WME, omit username & "All Users" folder if absent from registry
  If strOS = "W98" Or strOS = "WME" Then
  strLine = strLine & Chr(34) & "Startup" & Chr(34)
  If flagAUSUF Then
  strLine = strLine & " & " & Chr(34) & "All Users...Startup" &_
  Chr(34) & " folders:"
  Else
  strLine = strLine & " folder:"
  End If
  Else 'all other O/S's
  strLine = strLine & Chr(34) & Wshso.ExpandEnvironmentStrings("%USERNAME%") &_
  Chr(34) & " & " & Chr(34) & "All Users" & Chr(34) & " startup folders:"
  End If
  
  strTitle = strLine
  
  'for each startup folder name
  For i = 0 To 1 '0 = user folder, 1 = All Users folder
  
  'get the startup folder
  'in W98/WME, set flagFE to False if "All Users" folder doesn't exist
  If i = 1 And (strOS = "W98" Or strOS = "WME") Then
  If flagAUSUF Then
  If Fso.FolderExists(strValue) Then
  Set oSUF = Fso.GetFolder(strValue)
  Else
  flagFE = False 'folder doesn't exist
  End If
  Else
  flagFE = False 'registry key doesn't exist
  End If
  Else 'all other O/S's at all times
  Set oSUF = Fso.GetFolder(Wshso.SpecialFolders(arSUFN(i)))
  End If
  
  strSubTitle = oSUF.Path
  
  'if startup folder exists
  If flagFE Then
  
  'for each file in the startup folder
  For Each oSUFi in oSUF.Files
  
  strLine = "" 'empty the line
  
  'treat file as a shortcut
  On Error Resume Next
  Set oSUSC = Wshso.CreateShortcut(oSUFi)
  intErrNum = Err.Number : Err.Clear
  On Error Goto 0
  
  'if file is a shortcut
  If intErrNum = 0 Then
  
  If LCase(Fso.GetExtensionName(oSUFi)) = "url" Then 'shortcut is URL
  
  'prepare the shortcut file base name and the target path & arguments
  strLine = Chr(34) & Fso.GetBaseName (oSUFi.Path) & Chr(34) & " -> URL shortcut to: " &_
  Chr(34) & oSUSC.TargetPath
  
  Else
  
  'prepare the shortcut file base name and the target path & arguments
  strLine = Chr(34) & Fso.GetBaseName (oSUFi.Path) & Chr(34) & " -> shortcut to: " &_
  Chr(34) & oSUSC.TargetPath
  
  If oSUSC.Arguments <> "" Then
  strLine = strLine & " " & oSUSC.Arguments & Chr(34)
  Else
  strLine = strLine & Chr(34)
  End If
  
  'add co-name
  strLine = strLine & CoName(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 = Chr(34) & Fso.GetBaseName(oSUFi.Path) & Chr(34) &_
  " -> PIF to: " & Chr(34) & strPIFTgt & Chr(34) &_
  CoName(IDExe(strPIFTgt))
  
  'file is neither shortcut nor PIF
  Else
  
  'file is probably an executable so write out an INFECTION WARNING and
  ' the file name, using the full path as IDExe argument
  If LCase(Fso.GetFileName(oSUFi)) <> "desktop.ini" Then _
  strLine = "INFECTION WARNING! " & Chr(34) & oSUFi.Name & Chr(34) &_
  CoName(IDExe(oSUFi.Path))
  
  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 = ""
  
  'recover array memory
  ReDim arSUFN(0)
  
  End If 'flagTest?
  
  
  
  
  'XX. Enumerate enabled Scheduled Tasks
  
  If Not flagTest Then 'skip if testing
  
  ' Byte Disabled Enabled
  '00000030: #####1## #####0## <--
  
  'file in Tasks directory
  Dim oFi2
  
  'prepare section title lines
  strTitle = "Enabled Scheduled Tasks:"
  
  '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 & Chr(34) & oFi2.Name & Chr(34) &_
  " -- insufficient permission to read this file!"
  
  End If '.JOB file opened successfully?
  
  End If '.JOB file extension selected?
  
  Next 'file in TASKS directory
  
  '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 " & Chr(34) &_
  Wshso.ExpandEnvironmentStrings("%WINDIR%") & "\Tasks" & Chr(34) &_
  " directory cannot be found."
  
  End If 'Tasks directory exists?
  
  Set oJobF=Nothing
  
  strTitle = "" : strSubTitle = "" : strSubSubTitle = ""
  
  End If 'flagTest?
  
  
  
  
  'XXI. Enumerate Winsock2 Service Provider DLLs
  
  If Not flagTest Then 'skip if testing
  
  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 3 x n array
  ReDim arTSPFi(2,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

  0
• Treadstone71

  February 2006 edited February 2006

  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 &_
  "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" & " = " & Chr(34) &_
  strNSSP & Chr(34) & 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 & "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 &_
  "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) & " = " & Chr(34) &_
  arATSPFi(1,i) & Chr(34) & 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 & "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 'flagTest?
  
  
  
  
  'XXII. Internet Explorer Toolbars, Explorer Bars, Extensions
  
  If Not flagTest Then 'skip if testing
  
  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(), strCLSIDKey, 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 = 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
  
  ResolveCLSID arHives(i,1), strKey, strCLSID, strCLSIDTitle, strIPSDLL
  
  If strIPSDLL <> "" Then 'IPS exists?
  
  'output toolbar CLSID value name
  If strSubSubTitle <> "" Then
  TitleLineWrite : oFN.WriteLine Chr(34) & strCLSID & Chr(34) &_
  " = " & strCLSIDTitle
  Else
  oFN.WriteLine vbCRLF & Chr(34) & strCLSID & Chr(34) & " = " &_
  strCLSIDTitle
  End If
  
  'output InProcServer32 value
  oFN.WriteLine " -> {CLSID}\InProcServer32\(Default) = " &_
  Chr(34) & strIPSDLL & Chr(34) & CoName(IDExe(strIPSDLL))
  
  End If 'strIPSDLL <> ""?
  
  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
  
  ResolveCLSID HKCU,strKey & "\" & strSKName,strValue,strValue2,strValue1
  
  'if InProcServer32 value exists
  If strValue1 <> "" Then
  
  'output toolbar CLSID
  If strSubSubTitle <> "" Then
  TitleLineWrite : oFN.WriteLine Chr(34) & strValue & Chr(34) &_
  " = " & strValue2
  Else
  oFN.WriteLine vbCRLF & Chr(34) & strValue & Chr(34) &_
  " = " & strValue2
  End If
  
  'output InProcServer32 value
  oFN.WriteLine " -> {CLSID}\InProcServer32\(Default) = " &_
  StringFilter(strValue1,True) & CoName(IDExe(strValue1))
  
  End If 'IPS exists?
  
  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(7) '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
  
  
  strKey = "Software\Microsoft\Internet Explorer\Explorer Bars"
  
  'for HKCU & HKLM hives
  For i = 0 To 1
  
  strSubSubTitle = 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
  
  ResolveCLSID arHives(i,1), "", strHKExplorerBar, strValue2, strValue1
  
  'if InProcServer32 value exists
  If strValue1 <> "" Then
  
  'output explorer bar CLSID
  If strSubSubTitle <> "" Then
  TitleLineWrite : oFN.WriteLine strHKExplorerBar & "\" & " = " &_
  strValue2
  Else
  oFN.WriteLine vbCRLF & strHKExplorerBar & "\" & " = " &_
  strValue2
  End If
  
  'output InProcServer32 value
  oFN.WriteLine " -> {CLSID}\InProcServer32\(Default) = " &_
  Chr(34) & strValue1 & Chr(34) & CoName(IDExe(strValue1))
  
  End If 'IPS exists?
  
  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
  
  
  If flagShowAll Or flagSupp Then
  
  'check CLSIDs for dormant (!) Explorer Bars
  
  Dim datDEBStart : datDEBStart = Now
  
  strKey = "Software\Classes\CLSID"
  
  strSubSubTitle = "Dormant Explorer Bars in " & Chr(34) &_
  "View, Explorer Bar" & Chr(34) & " menu"
  
  'get CLSIDs
  oReg.EnumKey HKLM,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 (HKLM,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(HKLM,"Software\Classes\CLSID\" &_
  strCLSIDKey & "\InProcServer32","",strValue3)
  
  'if InProcServer32 value exists
  If intErrNum3 = 0 And strValue3 <> "" Then
  
  'get CLSID title
  oReg.GetStringValue HKLM,"Software\Classes\CLSID\" &_
  strCLSIDKey,"",strValue4
  
  TitleLineWrite
  
  'output CLSID + title, prepare output string,
  'output Implemented Categories key, InProcServer32
  If strValue4 <> "" Then
  oFN.WriteLine vbCRLF & "HKLM\Software\Classes\CLSID\" &_
  strCLSIDKey & "\ = " & StringFilter(strValue4,True)
  Else
  oFN.WriteLine vbCRLF & "HKLM\Software\Classes\CLSID\" &_
  strCLSIDKey & "\ = (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) = " &_
  Chr(34) & strvalue3 & Chr(34) & 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?
  
  'determine -supp seconds used
  Dim strDEBTime : strDEBTime = DateDiff("s",datDEBStart,Now) & " seconds"
  
  End If 'flagShowAll Or flagSupp?
  
  
  '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 = 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)
  
  ResolveCLSID arHives(i,1), "", strValue3, strCLSIDTitle, strValue6
  
  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 Chr(34) & "ButtonText" & Chr(34) & " = " &_
  Chr(34) & strValue1 & Chr(34)
  If intErrNum2 = 0 And strValue2 <> "" Then _
  oFN.WriteLine Chr(34) & "MenuText" & Chr(34) & " = " & Chr(34) &_
  strValue2 & Chr(34)
  If intErrNum3 = 0 And strValue3 <> "" Then
  Err.Clear 'required to reset Err if ButtonText or MenuText missing
  oFN.WriteLine Chr(34) & "CLSIDExtension" & Chr(34) & " = " &_
  Chr(34) & strValue3 & Chr(34)
  If strValue6 <> "" Then oFN.WriteLine " -> {CLSID}\InProcServer32\" &_
  "(Default) = " & StringFilter(strValue6,True) & CoName(IDExe(strValue6))
  End If 'CLSIDExtension value exists
  
  If intErrNum4 = 0 And strValue4 <> "" Then oFN.WriteLine Chr(34) &_
  "Script" & Chr(34) & " = " & Chr(34) & strValue4 & Chr(34) &_
  CoName(IDExe(strValue4))
  If intErrNum5 = 0 And strValue5 <> "" Then oFN.WriteLine Chr(34) &_
  "Exec" & Chr(34) & " = " & Chr(34) & strValue5 & Chr(34) &_
  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 'flagTest?
  
  
  
  
  'XXIII. Internet Explorer URL Prefixes
  
  If Not flagTest Then 'skip if testing
  
  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 (" & Chr(34) &_
  "domain-name-here.com" & Chr(34) & ")" & vbCRLF & vbCRLF & "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
  If Trim(LCase(strValue)) <> "http://&quot; Then strWarn = "HIJACK WARNING! "
  
  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://&quot;
  arPrefix(0,1) = "gopher" : arPrefix(1,1) = "gopher://"
  arPrefix(0,2) = "home" : arPrefix(1,2) = "http://&quot;
  arPrefix(0,3) = "mosaic" : arPrefix(1,3) = "http://&quot;
  arPrefix(0,4) = "www" : arPrefix(1,4) = "http://&quot;
  
  'find all the names in the key
  intErrNum1 = oReg.EnumValues (HKLM, strKey & "\Prefixes", arNames, arType)
  
  strSubTitle = "Prefix for specific service (i.e., " & Chr(34) & "www" &_
  Chr(34) & ")" & vbCRLF & vbCRLF & "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 = "HIJACK WARNING! "
  
  '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
  
  On Error Resume Next
  
  'output warning, name, value
  oFN.WriteLine strWarn & StringFilter(strName,True) & " = " &_
  Chr(34) & strValue & Chr(34)
  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 'flagTest?
  
  
  
  
  
  'check IERESET.INF integrity, URLSearchHooks, AboutURLs (error pages)
  'XXIV. Misc. IE Hijack Points
  
  If Not flagTest Then 'skip if testing
  
  '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 = "HIJACK WARNING! "
  
  '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 = "HKLM\" & strKey & "\Version = " & strIELVer
  strSubSubTitle = strIERFN & " (used to " & Chr(34) & "Reset Web " &_
  "Settings" & Chr(34) & ")"
  
  '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 = "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 " & Chr(34) & "Reset Web Settings" &_
  Chr(34) & ")"
  strSubSubTitle = ""
  End If
  
  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""&quot;
  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""&quot;
  arIER(15,0)="[RestoreBrowserSettings.reg]" : arIER(15,1)="HKLM,""Software\Microsoft\Windows\CurrentVersion\Internet Settings\SafeSites"",%SAFESITE_VALUE%,0,""http://ie.search.msn.com/*""&quot;
  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""&quot;
  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=&quot; & strIEShVer & "&ar=msnhome"""
  arIER(27,0)="[Strings]" : arIER(27,1)="START_PAGE_URL=""http://www.msn.com""&quot;
  arIER(28,0)="[Strings]" : arIER(28,1)="SAFESITE_VALUE=""http://home.microsoft.com/""&quot;
  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=&quot; & strIEShVer & "&ar=msnhome"""
  arIER(31,0)="[Strings]" : arIER(31,1)="MS_START_PAGE_URL=""http://www.msn.com""&quot;
  
  '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?
  
  If strTitle <> "" And flagShowAll Then
  strSubTitle = strIERFN & " (used to " & Chr(34) &_
  "Reset Web Settings" & Chr(34) & " -- no anomalies found)"
  strSubSubTitle = "" : 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!"
  
  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!"
  
  End If 'should file exist?
  
  End If 'IERESET.INF found?
  
  
  '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 strCLSID <> "{CFBFAE00-17A6-11D0-99CB-00C04FD64497}" Or _
  flagShowAll Then
  
  ResolveCLSID HKCU, strKey, strCLSID, strOut, strIPSDLL
  
  If strIPSDLL <> "" Then
  
  strWarn = ""
  If strCLSID <> "{CFBFAE00-17A6-11D0-99CB-00C04FD64497}" Then _
  strWarn = "HIJACK WARNING! "
  
  TitleLineWrite
  
  oFN.WriteLine Chr(34) & strCLSID & Chr(34) & " = " & strOut
  
  oFN.WriteLine " -> {CLSID}\InProcServer32\(Default) = " &_
  StringFilter(strIPSDLL,True) & CoName(IDExe(strIPSDLL))
  
  End If 'IPS exists?
  
  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 = "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", "270"
  arSK.Add "mozilla", "res://mshtml.dll/about.moz"
  arSK.Add "PostNotCached", "res://mshtml.dll/repost.htm"
  
  'value not set or IE 5-6
  If 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"
  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"
  End If 'IE>5?
  
  arSKk = arSK.Keys : arSKi = arSK.Items
  
  For i = 0 To UBound(arNames)
  
  strWarn = "HIJACK WARNING! "
  
  '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
  
  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 'flagTest?
  
  
  
  
  'XXV. Examine HOSTS file
  
  If Not flagTest Then 'skip if testing
  
  'left-trimmed HOSTS line, IP address, HOSTS Path, tab pos'n
  Dim strLineWk, strIP, strHP, intTabPosn
  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)
  strTmp = Trim(strValue) 'trim it
  'lop off trailing backslash
  If Right(strTmp,1) = "\" Then strTmp = Left(strTmp,Len(strTmp)-1)
  
  'set HOSTS location from registry value
  strHP = strTmp & "\HOSTS"
  
  'if registry value exists
  If intErrNum = 0 And strValue <> "" Then
  
  'output warning if not identical to default value
  strWarn = ""
  If LCase(strTmp) <> LCase(strFPSF) & "\drivers\etc" Then _
  strWarn = "HIJACK WARNING! "
  
  If LCase(strTmp) <> LCase(strFPSF) & "\drivers\etc" Or flagShowAll Then
  
  TitleLineWrite
  
  oFN.WriteLine vbCRLF & "HKLM\" & strKey & "\" & vbCRLF & strWarn &_
  Chr(34) & "DataBasePath" & Chr(34) & " = " & Chr(34) & strValue &_
  Chr(34)
  
  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

  0
• Treadstone71

  February 2006 edited February 2006

  '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" 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 'flagTest?
  
  
  
  
  'XXVI. Enumerate Started or Non-disabled Services
  
  If Not flagTest Then 'skip if testing
  
  '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
  Dim arMSSvc(), intMSSvcNo, strExeName
  
  'set up MS default services array for WXP/W2K/NT4
  'service name, service executable, DLL file name for svchost.exe-dependent service
  
  If strOS = "WXP" Then
  
  ReDim arMSSvc(91,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) = ""
  
  'WS2K3 only
  arMSSvc(85,0) = "dfs" : arMSSvc(85,1) = "dfssvc.exe" : arMSSvc(85,2) = ""
  arMSSvc(86,0) = "httpfilter" : arMSSvc(86,1) = "lsass.exe" : arMSSvc(86,2) = ""
  arMSSvc(87,0) = "srvcsurg" : arMSSvc(87,1) = "srvcsurg.exe" : arMSSvc(87,2) = ""
  arMSSvc(88,0) = "appmgr" : arMSSvc(88,1) = "appmgr.exe" : arMSSvc(88,2) = ""
  arMSSvc(89,0) = "snmp" : arMSSvc(89,1) = "snmp.exe" : arMSSvc(89,2) = ""
  arMSSvc(90,0) = "elementmgr" : arMSSvc(90,1) = "elementmgr.exe" : arMSSvc(90,2) = ""
  arMSSvc(91,0) = "w3svc" : arMSSvc(91,1) = "svchost.exe" : arMSSvc(91,2) = "iisw3adm.dll"
  
  ElseIf strOS = "W2K" Then
  
  ReDim arMSSvc(66,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) = "utilman" : arMSSvc(51,1) = "utilman.exe" : arMSSvc(51,2) = ""
  arMSSvc(52,0) = "msiserver" : arMSSvc(52,1) = "msiexec.exe" : arMSSvc(52,2) = ""
  arMSSvc(53,0) = "winmgmt" : arMSSvc(53,1) = "winmgmt.exe" : arMSSvc(53,2) = ""
  arMSSvc(54,0) = "wmi" : arMSSvc(54,1) = "services.exe" : arMSSvc(54,2) = ""
  arMSSvc(55,0) = "w32time" : arMSSvc(55,1) = "services.exe" : arMSSvc(55,2) = ""
  arMSSvc(56,0) = "wzcsvc" : arMSSvc(56,1) = "svchost.exe" : arMSSvc(56,2) = "wzcsvc.dll"
  arMSSvc(57,0) = "lanmanworkstation" : arMSSvc(57,1) = "services.exe" : arMSSvc(57,2) = ""
  arMSSvc(58,0) = "w3svc" : arMSSvc(58,1) = "inetinfo.exe" : arMSSvc(58,2) = ""
  arMSSvc(59,0) = "wmdm pmsp service" : arMSSvc(59,1) = "mspmspsv.exe" : arMSSvc(59,2) = ""
  arMSSvc(60,0) = "msftpsvc" : arMSSvc(60,1) = "inetinfo.exe" : arMSSvc(60,2) = ""
  arMSSvc(61,0) = "irmon" : arMSSvc(61,1) = "svchost.exe" : arMSSvc(61,2) = "irmon.dll"
  
  'W2KS
  arMSSvc(62,0) = "dhcpServer" : arMSSvc(62,1) = "tcpsvcs.exe" : arMSSvc(62,2) = ""
  arMSSvc(63,0) = "dfs" : arMSSvc(63,1) = "dfssvc.exe" : arMSSvc(63,2) = ""
  arMSSvc(64,0) = "dns" : arMSSvc(64,1) = "dns.exe" : arMSSvc(64,2) = ""
  arMSSvc(65,0) = "ias" : arMSSvc(65,1) = "svchost.exe" : arMSSvc(65,2) = "ias.dll"
  arMSSvc(66,0) = "licenseservice" : arMSSvc(66,1) = "llssrv.exe" : arMSSvc(66,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) = ""
  
  End If 'filling MS default services array
  
  '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, 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 or WXP?
  
  '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
  TitleLineWrite
  oFN.WriteLine vbCRLF & "INFECTION WARNING! " &_
  "The running services cannot be counted." & vbCRLF &_
  "Presence of a spyware service is suspected." & vbCRLF &_
  "The script has been forced to exit." & vbCRLF
  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
  arSvces(i,2) = oSvce.PathName : 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)
  
  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) & ", " &_
  StringFilter(arSvces(i,2),True) & 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) & ", " &_
  StringFilter(arSvces(i,2),True) & 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\"
  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 strValue <> "" Then strLine = " {" & Chr(34) & strValue &_
  Chr(34) & strCN & "}"
  
  'find last backslash in ServiceDLL
  intLBSP = InStrRev(strValue,"\")
  'set position to 0 if no backslash present
  If IsNull(intLBSP) Then intLBSP = 0
  'extract ServiceDLL
  strDLL = Mid(IDExe(strValue),intLBSP+1)
  
  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) & ", " &_
  StringFilter(arSvces(i,2),True) & strLine
  
  End If
  
  'services.exe
  Else
  
  'find last backslash in ServiceDLL
  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)
  
  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) & ", " &_
  StringFilter(arSvces(i,2),True) & 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 'flagTest?
  
  
  
  
  'XXVII. Keyboard Driver Filters
  
  If Not flagTest Then 'skip if testing
  
  'prepare title line
  strTitle = "Keyboard Driver Filters:"
  
  Dim arValue() 'multi-string value
  strOut = "" 'empty output string
  flagInfect = False
  
  'for W2K Or WXP
  If strOS = "W2K" Or strOS = "WXP" 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
  
  '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 & ", INFECTION WARNING! " & Chr(34) &_
  arValue(i) & Chr(34) & strCN
  Else 'skip leading comma if output string empty
  strOut = "INFECTION WARNING! " & Chr(34) &_
  arValue(i) & Chr(34) & 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 & ", " & Chr(34) & arValue(i) & Chr(34) & strCN
  Else 'skip leading comma if output string empty
  strOut = Chr(34) & arValue(i) & Chr(34) & 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 & Chr(34) &_
  "UpperFilters" & Chr(34) & " = " & strOut
  
  End If 'output necessary?
  
  End If 'arValue empty?
  
  Else 'arValue not returned
  
  If flagShowAll Then
  TitleLineWrite : oFN.WriteLine vbCRLF & "HKLM\" & strKey & "\" & vbCRLF & Chr(34) &_
  "UpperFilters" & Chr(34) & " = (value not found)"
  End If
  
  End If 'arValue returned?
  
  'recover array memory
  ReDim arValue(0)
  
  End If 'W2K/WXP?
  
  strTitle = "" : strSubTitle = "" : strSubSubTitle = ""
  
  End If 'flagTest?
  
  
  
  
  'XXVIII. Enumerate Print Monitors
  
  If Not flagTest Then 'skip if testing
  
  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 = "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 = "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 = " &_
  Chr(34) & strValue & Chr(34) & 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 'flagTest?
  
  
  
  
  '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
  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 strHeader : strHeader = vbCRLF & vbCRLF & String(10,"-")
  Dim strFooter : strFooter = vbCRLF & String(10,"-") &_
  strRunTime
  
  If Not flagShowAll Then
  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 and all Registry CLSIDs for dormant Explorer Bars," &_
  vbCRLF & " use the -supp parameter or answer " & Chr(34) & "No" & Chr(34) &_
  " at the first message box."
  Else 'flagSupp=True
  strBody = strBody &_
  vbCRLF & "+ The search for DESKTOP.INI DLL launch points on all local fixed drives" &_
  vbCRLF & " took " & strDTITime & "." &_
  vbCRLF & "+ The search for all Registry CLSIDs containing dormant Explorer Bars" &_
  vbCRLF & " took " & strDEBTime & "."
  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
  
  Wshso.PopUp "All Done! The results are in the file:" &_
  vbCRLF & vbCRLF & strFN,intClosePUBSec,"Silent Runners R" & strRevNo & " Complete", _
  vbOKOnly + vbInformation + vbSystemModal
  
  Else
  
  WScript.Echo "Silent Runners R" & strRevNo & " is done! The results " &_
  "are in the file:" & vbCRLF & vbCRLF & strFN
  
  End If
  
  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
  Function FmtHMS (datIn)
  
  FmtHMS = 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, i
  
  flagNVP = False
  
  'find all the names in the key
  oReg.EnumValues hexHive, strRunKey, arNames, arType
  
  'excludes W2K/WXP with no name/value pairs
  If IsArray(arNames) Then
  
  'try to get array UBound
  On Error Resume Next
  intUB = UBound(arNames)
  intErrNum = Err.Number : Err.Clear
  On Error Goto 0
  
  'excludes WS2K3 with no name/value pairs
  If intErrNum = 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
  Function RtnValue (hexHive, strKey, strName, intType)
  
  'value as string, integer, array, counter, error number
  Dim strValue, intValue, arValue, i, intErrNum
  
  Select Case intType
  
  'string value
  Case REG_SZ
  
  'return the string-type value
  oReg.GetStringValue hexHive,strKey,strName,strValue
  If IsNull(strValue) Then strValue = "(no data)"
  If strValue = "" Then strValue = "(empty string)"
  RtnValue = strValue
  
  'expandable-string value
  Case REG_EXPAND_SZ
  
  'return the expanded string-type value
  oReg.GetExpandedStringValue hexHive,strKey,strName,strValue
  RtnValue = strValue
  
  'binary value
  Case REG_BINARY
  
  'return the binary-type value as array
  oReg.GetBinaryValue hexHive,strKey,strName,arValue
  
  'set name = default if name is empty string
  If strName = "" Then
  strMsg = strMsg & Chr(34) & "(Default)" & Chr(34) & " = "
  Else
  strMsg = strMsg & Chr(34) & strName & Chr(34) & " = "
  End If
  
  'delimit every two-bytes by space
  For i = LBound(arValue) To UBound(arValue)
  strMsg = strMsg & arValue(j) & Space(1)
  Next
  
  strMsg = RTrim(strMsg) 'lop off trailing space
  RtnValue = strMsg
  
  '4-byte value
  Case REG_DWORD
  
  'return the DWORD-type value
  oReg.GetDWORDValue hexHive,strKey,strName,intValue
  RtnValue = CStr(intValue)
  
  'multiple-string value
  Case REG_MULTI_SZ
  
  'return the multiple-string-type value
  oReg.GetMultiStringValue hexHive,strKey,strName,strValue
  
  'set name = default if name is empty string
  If strName = "" Then
  strMsg = strMsg & Chr(34) & "(Default)" & Chr(34) & " = "
  Else
  strMsg = strMsg & Chr(34) & strName & Chr(34) & " = "
  End If
  
  'delimit every quote-enclosed string by "|"
  For j = LBound(strValue) To UBound(strValue)
  strMsg = strMsg & Chr(34) & strValue(j) & Chr(34) & "|"
  Next
  
  strMsg = RTrim(strMsg) 'lop off trailing "|"
  RtnValue = strMsg
  
  'any other type
  Case Else
  
  'admit we don't know what it is
  RtnValue = Chr(34) & strName & Chr(34) & " = (data in unrecognized format!)"
  
  End Select 'data type
  
  End Function
  
  
  
  
  'write name/value pair to file
  Function WriteValueData (strName, strValue, intType, strWarn)
  
  Dim strOQEC 'Optionally Quote-Enclosed Comment"
  
  'enclose strings in quotes and append CoName,
  ' except for missing data declarations
  'do not enclose BINARY or DWORD values
  If intType = REG_DWORD Or intType = REG_BINARY Then
  strOQEC = strValue
  ElseIf strValue = "(no data)" Or strValue = "(empty string)" Then
  strOQEC = strValue
  Else
  strOQEC = Chr(34) & strValue & Chr(34) & CoName(IDExe(strValue))
  End If
  
  'output the quote-delimited name and value
  If strName = "" Then
  oFN.WriteLine strWarn & Chr(34) & "(Default)" & Chr(34) & " = " & strOQEC
  intErrNum = Err.Number : Err.Clear
  Else 'name is non-empty string
  On Error Resume Next
  oFN.WriteLine strWarn & Chr(34) & strName & Chr(34) & " = " & strOQEC
  intErrNum = Err.Number : Err.Clear
  On Error GoTo 0
  If intErrNum <> 0 Then oFN.WriteLine strWarn & Chr(34) & strName &_
  Chr(34) & " = (value not set)"
  End If
  
  End Function
  
  
  
  
  'output registry name/value if value <> ref
  Function RegDataChk (cHive, strKey, strName, strValue, strRef)
  
  Dim strHive, strValWrk
  Dim strWarn : strWarn = ""
  Dim strCoName : strCoName = ""
  Dim strQVal : strQVal = ""
  Dim intErrNum, intErrNum1
  
  If cHive = HKCU Then strHive = "HKCU"
  If cHive = HKLM Then strHive = "HKLM"
  
  intErrNum = oReg.GetStringValue (cHive,strKey,strName,strValue)
  
  'if name exists And value set (exc for W2K!)
  If intErrNum = 0 And strValue <> "" Then
  
  'store work value
  strValWrk = Trim(LCase(strValue))
  
  'fill warning if necessary
  If strValWrk <> LCase(strRef) Then strWarn = "INFECTION WARNING! "
  
  'output if value <> reference Or ShowAll
  If (strValWrk <> LCase(strRef)) Or flagShowAll Then
  
  'output title lines if not already done
  TitleLineWrite
  
  'if value <> reference, parse load/run/shell lines to set up output strings
  If (strValWrk <> LCase(strRef)) And _
  (LCase(strName) = "load" Or LCase(strName) = "run" Or _
  LCase(strName) = "shell") Then
  
  strCoName = LRParse(strValue)
  strQVal = Chr(34) & strValue & Chr(34) & strCoName
  
  'if any other value not empty, set up output strings
  ElseIf strValue <> "" Then
  
  strCoName = CoName(IDExe(strValue))
  strQVal = Chr(34) & strValue & Chr(34) & strCoName
  
  End If
  
  'write name and value to file
  On Error Resume Next
  oFN.WriteLine strWarn & Chr(34) & strName & Chr(34) &_
  " = " & strQVal
  intErrNum1 = Err.Number : Err.Clear
  On Error Resume Next
  If intErrNum1 <> 0 Then oFN.WriteLine Chr(34) & strName & Chr(34) &_
  " = (value not set)"
  
  End If 'value <> reference Or ShowAll
  
  Else 'name doesn't exist Or value not set (exc for W2K!)
  
  'output title lines & key & value names if ShowAll
  If flagShowAll Then
  TitleLineWrite
  oFN.WriteLine Chr(34) & strName & Chr(34) &_
  " = (no data)"
  End If
  
  End If 'value exists
  
  End Function
  
  
  
  
  'set NoDriveTypeAutoRun flag
  Function NDTAR (cHive, strValueFlag, strFDFlag)
  
  'DWORD or BINARY value, binary value array
  Dim hVal, arBVal
  
  strKey = "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer"
  
  'if cHive NoDriveTypeAutoRun DWORD value exists
  If oReg.GetDWORDValue(cHive,strKey,"NoDriveTypeAutoRun",hVal) = 0 Then
  
  strValueFlag = True
  
  'if autorun for fixed drives is disabled, set flag
  If (hVal And 8) = 8 Then strFDFlag = False
  
  'if cHive NoDriveTypeAutoRun BINARY value exists
  ElseIf oReg.GetBinaryValue(cHive,strKey,"NoDriveTypeAutoRun",arBVal) = 0 Then
  
  'UBound = -1 if value not set (zero-length binary value)
  If UBound(arBVal) = -1 Then
  
  'if O/S = W2K/WXP SP0/1, "value not set" interpreted by O/S as
  '0 instead of null!
  If strOS = "W2K" Or strOS = "WXP" Then
  strValueFlag = True
  End If 'W2K/WXP?
  
  Else 'UBound <> -1, so value set
  
  strValueFlag = True : hVal = 0
  
  'binary value retrieved as array in increments of 16^2
  For i = 0 To UBound(arBVal)
  hVal = hVal + arBVal(i) * 256^i
  Next
  
  'if autorun for fixed drives is disabled, set flag
  If (hVal And 8) = 8 Then strFDFlag = False
  
  End If 'UBound = -1?
  
  End If 'NoDriveTypeAutoRun value exists?
  
  End Function
  
  
  
  
  'detect if autorun disabled for individual drives
  Function NDAR (cHive, strValueFlag)
  
  'DWORD or BINARY value, binary value array
  Dim hVal, arBVal
  
  strKey = "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer"
  
  'if cHive NoDriveAutoRun DWORD value exists
  If oReg.GetDWORDValue(cHive,strKey,"NoDriveAutoRun",hVal) = 0 Then
  
  strValueFlag = True
  
  'for every fixed disk
  For i = 0 To UBound(arFixedDisks,2)
  
  'if autorun for fixed drive is disabled, set flag
  If (hVal And arFixedDisks(1,i)) = arFixedDisks(1,i) Then
  
  arFixedDisks(2,i) = False
  
  End If 'autorun disabled for this drive?
  
  Next 'fixed disk
  
  'if cHive NoDriveAutoRun BINARY value exists
  ElseIf oReg.GetBinaryValue(cHive,strKey,"NoDriveAutoRun",arBVal) = 0 Then
  
  'UBound = -1 if value not set (zero-length binary value)
  If UBound(arBVal) = -1 Then
  
  'if O/S = W2K/WXP SP0/1, "value not set" interpreted by O/S as
  '0 instead of null!
  If strOS = "W2K" Or strOS = "WXP" Then
  
  strValueFlag = True
  
  'set all NDAR flags to True
  For i = 0 To UBound(arFixedDisks,2)
  arFixedDisks(2,i) = True
  Next
  
  End If 'W2K/WXP?
  
  Else 'UBound <> -1, so value set
  
  strValueFlag = True
  
  hVal = 0
  
  'binary value retrieved as array in increments of 16^2
  For i = 0 To UBound(arBVal)
  hVal = hVal + arBVal(i) * 256^i
  Next
  
  'for every fixed disk
  For i = 0 To UBound(arFixedDisks,2)
  
  'if autorun for the fixed disk is disabled, set flag
  If (hVal And arFixedDisks(1,i)) = arFixedDisks(1,i) Then
  
  arFixedDisks(2,i) = False
  
  End If 'autorun disabled for fixed disk?
  
  Next 'fixed disk
  
  End If 'hive NoDriveAutoRun value set?
  
  End If 'hive NoDriveAutoRun value exists?
  
  End Function
  
  
  
  
  'INI/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 Then strWarn = "INFECTION WARNING! "
  
  'suppress warning for screensaver
  If strEquiv = "anything" Then strWarn = ""
  
  'concatenate line for load or run
  If LCase(strVerb) = "load" Or LCase(strVerb) = "run" Then
  
  strOutput = strWarn & Chr(34) & strInput & Chr(34) & LRParse(strExe)
  
  'concatenate line for open or shellexecute
  ElseIf LCase(strVerb) = "open" Or LCase(strVerb) = "shellexecute" Then
  
  strOutput = strWarn & strDisk & "\AUTORUN.INF -> " &_
  Chr(34) & strInput & Chr(34) & 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 & Chr(34) & strInput & Chr(34) & strLFN &_
  CoName(IDExe(strExe))
  
  'concatenate line for all other verbs
  Else

  0
• Treadstone71

  February 2006 edited February 2006

  strOutput = strWarn & Chr(34) & strInput & Chr(34) & 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")
  
  'look for leading double quote, embedded " /", " """ (parameter prefixes)
  If Left(strPWk,1) = Chr(34) Then
  'if find it, then look for second quote
  int2Q = InStr(2, strPWk, """")
  'if find it, reset the path string to what was between the quotes
  If int2Q > 0 Then strPWk = 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
  Dim oFile, strMftr, intErrNum, strFNWk
  
  strFNWk = StringFilter(strFN,False)
  
  '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 " &_
  Chr(34) & strScrFN & Chr(34)
  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 = Chr(34) & strAction & Chr(34) & " -> launches: "
  If flagActionWritten = True Then strArrow = Space(intActL+2) & " -> launches: "
  
  'output script command, reset script command & saved script number
  oFN.WriteLine strArrow & Chr(34) & strSC & Chr(34) & 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 = Chr(34) & strAction & Chr(34) & " -> launches: "
  If flagActionWritten = True Then strArrow = Space(intActL+2) & " -> launches: "
  TitleLineWrite
  oFN.WriteLine strArrow & Chr(34) & strSC & Chr(34) & 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)
  
  '# 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) '# bytes at unicode chr 35 (byte 70)
  
  '# chrs includes final zero chr so subtract one chr
  intUChrCtr = AscW(oJobFi.Read(1))-1
  
  'check for 0 or negative executable length
  If intUChrCtr <= 0 Then
  JobFileReadError oFile, " (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 Chr(34) & Fso.GetBaseName(oFile.Path) & Chr(34) &_
  " -> 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 Chr(34) & Fso.GetBaseName(oFile.Path) & Chr(34) &_
  " -> " & "WARNING -- The file " & Chr(34) & oFile.Name & Chr(34) &_
  " 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
  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 < 32 Or (Asc returns "?" but AscW doesn't)
  If 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 = Chr(34) & strOut & Chr(34) & " (unwritable string)"
  Else
  StringFilter = strOut & " (unwritable string)"
  End If 'flagEmbedQ?
  
  Else 'input string is writable
  
  If flagEmbedQ Then
  StringFilter = Chr(34) & strOut & Chr(34)
  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
  
  
  
  
  'for CLSID name, recover CLSID title, CLSID\InProcServer32 DLL name
  Sub ResolveCLSID (hexHive, strCLSIDKey, strCLSID, strCLSIDTitle, strIPSDLL)
  
  Dim strValue2, strKey2, strKey3, intErrNum, intErrNum2, intErrNum3
  
  'assign default values
  flagIsCLSID = False : strCLSIDTitle = "" : strIPSDLL = ""
  
  'toggle flag if strCLSID in correct format
  If Len(strCLSID) = 38 And Left(strCLSID,1) = "{" And _
  Right(strCLSID,1) = "}" Then flagIsCLSID = True
  
  'try getting title from value
  'title retrieved successfully even if value of type REG_EXPAND_SZ
  'avoid query if CLSID is key name, not value name
  If strCLSIDKey <> "" Then
  intErrNum = oReg.GetStringValue (hexHive,strCLSIDKey,strCLSID,strValue2)
  If intErrNum = 0 And strValue2 <> "" Then _
  strCLSIDTitle = StringFilter(strValue2, True)
  End If
  
  'if value not set, may be able to obtain title from the CLSID (exc W2K!)
  If strCLSIDTitle = "" Then
  
  strKey2 = "Software\Classes\CLSID\" & strCLSID
  intErrNum2 = oReg.GetStringValue (HKLM,strKey2,"",strValue2)
  
  'if CLSID key exists And default value set
  If intErrNum2 = 0 And strValue2 <> "" Then
  strCLSIDTitle = StringFilter(strValue2, True) & " [from CLSID]"
  Else 'either CLSID key doesn't exist or title not present
  strCLSIDTitle = "(no title provided)"
  End If
  
  End If 'strCLSIDTitle=""?
  
  'strIPSDLL = InProcServer32 DLL
  'resolve the name via HKLM\Software\Classes\CLSID\{name}\InProcServer32
  strKey3 = "Software\Classes\CLSID\" & strCLSID & "\InProcServer32"
  intErrNum3 = oReg.GetExpandedStringValue (HKLM,strKey3,"",strIPSDLL)
  
  'if InProcServer32 value not returned, ensure IPS name is set to blank
  If intErrNum3 <> 0 Then strIPSDLL = ""
  
  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
  cntFo = cntFo + 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?
  
  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"
  
  'get the CLSID IPS from the registry
  intErrNum = oReg.GetExpandedStringValue (HKLM,strKey,"", strIPSDLL)
  
  'if the IPS DLL exists, check if it's allowed
  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 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
  
  strOut = vbCRLF & strDTIFN & vbCRLF & "[.ShellClassInfo]" &_
  vbCRLF & strLine & vbCRLF & " -> {CLSID}\InProcServer32\" &_
  "(Default) = " & Chr(34) & strIPSDLL & Chr(34) & strCN
  
  Else 'strOut already contains one launch point, so concatenate & exit
  
  DTIParse = strOut & vbCRLF & strLine & vbCRLF &_
  " -> {CLSID}\InProcServer32\" & "(Default) = " & Chr(34) &_
  strIPSDLL & Chr(34) & strCN
  Exit Function
  
  End If 'strOut empty?
  
  End If 'DLL not allowed?
  
  End If 'IPS DLL exists?
  
  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
  
  
  
  
  '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

  0
• Treadstone71

  February 2006 edited February 2006

  '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
  
  
  '** Updated Revision Number on line #15 **
  
  
  
  WHEW...that's the whole log. Thanks again, Sean.

  0
• skywalker45 Bloomington, IN. USA

  February 2006 edited February 2006

  Yeah, I'm sorry about that. I really only needed to see part of that log. I don't see any problems with it. My suggestion at this point is that you completely uninstall Ad-Aware and then reinstall it fresh. There may be a problem with the program or a conflict with another security related program. Please do this and let me know how it goes.

  0
• Treadstone71

  February 2006 edited February 2006

  skywalker45 wrote:

  Yeah, I'm sorry about that. I really only needed to see part of that log. I don't see any problems with it. My suggestion at this point is that you completely uninstall Ad-Aware and then reinstall it fresh. There may be a problem with the program or a conflict with another security related program. Please do this and let me know how it goes.

  
  Hmm, ok I'll give that a try. Actually, I'll uninstall both Spybot and Ad-Aware, reinstall both, and see what happens.
  
  I'm away until Monday, but I'll try it then and keep you posted. Thanks again!
  
  Sean.

  0
• skywalker45 Bloomington, IN. USA

  February 2006 edited February 2006

  Good idea. Just do them both. I'll be waiting for your reply.

  0
• Treadstone71

  February 2006 edited February 2006

  Hi there...I just uninstalled both and erased their remaining folders, then reinstalled both. Ad-Aware is still crashing in the same spot in my registry.
  
  And another peculiar thing, my floppy drive seems to be malfunctioning. It will scan (with no disk or encouragement) itself once in a while, as I'm using the machine.
  
  I'm really frustrated with this now. Since Ad-Aware crashed that first time last week, it's been one thing after another. Just in case you hadn't notice, I've really appreciated your help Skywalker.
  
  My latest hijack this log...
  
  Logfile of HijackThis v1.99.1
  Scan saved at 11:33:28 PM, on 27/02/2006
  Platform: Windows XP SP1 (WinNT 5.01.2600)
  MSIE: Internet Explorer v6.00 SP1 (6.00.2800.1106)
  
  Running processes:
  C:\WINDOWS\System32\smss.exe
  C:\WINDOWS\system32\csrss.exe
  C:\WINDOWS\system32\winlogon.exe
  C:\WINDOWS\system32\services.exe
  C:\WINDOWS\system32\lsass.exe
  C:\WINDOWS\system32\svchost.exe
  C:\WINDOWS\System32\svchost.exe
  C:\WINDOWS\System32\svchost.exe
  C:\WINDOWS\System32\svchost.exe
  C:\WINDOWS\system32\spoolsv.exe
  C:\WINDOWS\Explorer.EXE
  C:\Program Files\Common Files\Real\Update_OB\realsched.exe
  C:\WINDOWS\System32\RunDll32.exe
  C:\Program Files\Saitek\Software\SaiSmart.exe
  C:\Program Files\Saitek\Software\SaiMfd.exe
  C:\Program Files\AntiVir PersonalEdition Classic\avgnt.exe
  C:\Program Files\Zone Labs\ZoneAlarm\zlclient.exe
  C:\WINDOWS\System32\ctfmon.exe
  C:\WINDOWS\System32\alg.exe
  C:\Program Files\AntiVir PersonalEdition Classic\sched.exe
  C:\Program Files\AntiVir PersonalEdition Classic\avguard.exe
  C:\Program Files\ewido anti-malware\ewidoctrl.exe
  C:\WINDOWS\System32\nvsvc32.exe
  C:\WINDOWS\System32\svchost.exe
  C:\WINDOWS\System32\wdfmgr.exe
  C:\WINDOWS\system32\ZoneLabs\vsmon.exe
  C:\WINDOWS\system32\fxssvc.exe
  C:\Documents and Settings\Sean\My Documents\Driver Updates\HijackThis!\HijackThis.exe
  
  R0 - HKCU\Software\Microsoft\Internet Explorer\Main,Start Page = http://www.ascforums.com/
  O1 - Hosts: localhost 127.0.0.1
  O2 - BHO: (no name) - {53707962-6F74-2D53-2644-206D7942484F} - C:\Program Files\Spybot - Search & Destroy\SDHelper.dll
  O3 - Toolbar: &Radio - {8E718888-423F-11D2-876E-00A0C9082467} - C:\WINDOWS\System32\msdxm.ocx
  O4 - HKLM\..\Run: [NeroCheck] C:\WINDOWS\system32\NeroCheck.exe
  O4 - HKLM\..\Run: [QuickTime Task] "C:\Program Files\QuickTime\qttask.exe" -atboottime
  O4 - HKLM\..\Run: [TkBellExe] "C:\Program Files\Common Files\Real\Update_OB\realsched.exe" -osboot
  O4 - HKLM\..\Run: [HGTXPEI] C:\WINDOWS\System32\FirstReboot.exe
  O4 - HKLM\..\Run: [SoundFusion] RunDll32 hercplgs.cpl,BootEntryPoint
  O4 - HKLM\..\Run: [NvCplDaemon] RUNDLL32.EXE C:\WINDOWS\System32\NvCpl.dll,NvStartup
  O4 - HKLM\..\Run: [nwiz] nwiz.exe /install
  O4 - HKLM\..\Run: [NvMediaCenter] RUNDLL32.EXE C:\WINDOWS\System32\NvMcTray.dll,NvTaskbarInit
  O4 - HKLM\..\Run: [Profiler] C:\Program Files\Saitek\Software\Profiler.exe
  O4 - HKLM\..\Run: [SaiSmart] C:\Program Files\Saitek\Software\SaiSmart.exe
  O4 - HKLM\..\Run: [SaiMfd] C:\Program Files\Saitek\Software\SaiMfd.exe
  O4 - HKLM\..\Run: [avgnt] "C:\Program Files\AntiVir PersonalEdition Classic\avgnt.exe" /min
  O4 - HKLM\..\Run: [Zone Labs Client] C:\Program Files\Zone Labs\ZoneAlarm\zlclient.exe
  O4 - HKCU\..\Run: [CTFMON.EXE] C:\WINDOWS\System32\ctfmon.exe
  O4 - HKCU\..\Run: [SpybotSD TeaTimer] C:\Program Files\Spybot - Search & Destroy\TeaTimer.exe
  O8 - Extra context menu item: E&xport to Microsoft Excel - res://C:\PROGRA~1\MICROS~2\Office10\EXCEL.EXE/3000
  O9 - Extra button: ICQ - {6224f700-cba3-4071-b251-47cb894244cd} - C:\Program Files\ICQ\ICQ.exe
  O9 - Extra 'Tools' menuitem: ICQ - {6224f700-cba3-4071-b251-47cb894244cd} - C:\Program Files\ICQ\ICQ.exe
  O9 - Extra button: Real.com - {CD67F990-D8E9-11d2-98FE-00C0F0318AFE} - C:\WINDOWS\System32\Shdocvw.dll
  O9 - Extra button: Messenger - {FB5F1910-F110-11d2-BB9E-00C04F795683} - C:\Program Files\Messenger\MSMSGS.EXE
  O9 - Extra 'Tools' menuitem: Messenger - {FB5F1910-F110-11d2-BB9E-00C04F795683} - C:\Program Files\Messenger\MSMSGS.EXE
  O16 - DPF: {0585238B-9CA6-4CCB-A9B2-FE4BA495E880} (AXWebMon Control) - http://www.smilecam.com/home/ezwebcam/eng0/common/AXWebMonProj1.cab
  O16 - DPF: {41F17733-B041-4099-A042-B518BB6A408C} - http://a1540.g.akamai.net/7/1540/52/20020713/qtinstall.info.apple.com/samantha/us/win/QuickTimeInstaller.exe
  O16 - DPF: {6414512B-B978-451D-A0D8-FCFDF33E833C} (WUWebControl Class) - http://update.microsoft.com/windowsupdate/v6/V5Controls/en/x86/client/wuweb_site.cab?1124329491451
  O16 - DPF: {6B4788E2-BAE8-11D2-A1B4-00400512739B} (PWMediaSendControl Class) - http://216.249.24.140/code/PWActiveXImgCtl.CAB
  O17 - HKLM\System\CCS\Services\Tcpip\..\{257F8369-E411-4362-A9EA-744C4C93750F}: NameServer = 85.255.116.56,85.255.112.146
  O17 - HKLM\System\CCS\Services\Tcpip\..\{6CAA78A4-6AA0-4F23-81DA-3BB264801CD9}: NameServer = 85.255.116.56 85.255.112.146
  O17 - HKLM\System\CS1\Services\Tcpip\..\{257F8369-E411-4362-A9EA-744C4C93750F}: NameServer = 85.255.116.56,85.255.112.146
  O23 - Service: AntiVir Scheduler (AntiVirScheduler) - H+BEDV Datentechnik GmbH - C:\Program Files\AntiVir PersonalEdition Classic\sched.exe
  O23 - Service: AntiVir PersonalEdition Classic Service (AntiVirService) - H+BEDV Datentechnik GmbH - C:\Program Files\AntiVir PersonalEdition Classic\avguard.exe
  O23 - Service: ewido security suite control - ewido networks - C:\Program Files\ewido anti-malware\ewidoctrl.exe
  O23 - Service: NVIDIA Display Driver Service (NVSvc) - NVIDIA Corporation - C:\WINDOWS\System32\nvsvc32.exe
  O23 - Service: TrueVector Internet Monitor (vsmon) - Zone Labs, LLC - C:\WINDOWS\system32\ZoneLabs\vsmon.exe
  
  Thanks, Sean.
  
  EDIT: Any idea why in my system processes, I'm running svchost.exe four times?

  0
• skywalker45 Bloomington, IN. USA

  February 2006 edited February 2006

  Thank you for your appreciation Sean. I will continue to try to help you solve this problem possibly with some help from another forum since now you seem to have this issue with the floppy drive. As far as the svchost.exe process. It is fine to have more than one instance of it running. You may see it running multiple times and it's fine and nothing to worry about.
  
  Let me ask you a question. Did the problem with Ad-Aware begin before of after you used Registry Mechanic? I'm starting to become concerned that the Registry Mechanic tool that you used may have made a registry change that makes Ad-Aware hang. I'm not saying you did wrong by getting the registry tool but sometimes these work almost too good and remove things that are better left alone. Of course all that is moot if you had the problem before using the registry tool. Unless you are having hallmark symptoms of malware: inability to run certain programs, homepage hijacks, pop-ups and other related maladies then I really don't think we're seeing a problem here with malware but with something different. When Ad-Aware hangs, can you see the entire name of the registry key where it stops? If so can you post that key name here in its entirety. Also have you considered upgrading your Windows installation to SP2? I notice you're still running SP1. If you have a fast internet connection you might consider upgrading now. Please let me know the key name if it's visible in its entirety. If it isn't we'll think of something else. I'll do some more research.
  
  On another note. It's also possible that spybot's tea timer is causing the problem with Ad-Aware. You might want to disable the tea timer and do another scan to see what happens.

  0
• Treadstone71

  February 2006 edited February 2006

  skywalker45 wrote:

  Let me ask you a question. Did the problem with Ad-Aware begin before of after you used Registry Mechanic? I'm starting to become concerned that the Registry Mechanic tool that you used may have made a registry change that makes Ad-Aware hang. I'm not saying you did wrong by getting the registry tool but sometimes these work almost too good and remove things that are better left alone. Of course all that is moot if you had the problem before using the registry tool. Unless you are having hallmark symptoms of malware: inability to run certain programs, homepage hijacks, pop-ups and other related maladies then I really don't think we're seeing a problem here with malware but with something different.

  
  Hi again...no, I installed registry mechanic thinking it might fix the problem. Obviously, although it did help performance a bit, the main problem is still there. And it might not be spyware...other than the floppy thing (which, knock on wood, seems to have stopped) I don't have any other evidence of spyware. No pop-ups, no hijacks.
  
  

  skywalker45 wrote:

  When Ad-Aware hangs, can you see the entire name of the registry key where it stops? If so can you post that key name here in its entirety.

  
  No, all I see is HKEY_LOCAL_MACHINE\Software\.. when it hangs. I let it sit for half an hour at the longest, but should I try leaving it for longer? I've never had ad-aware sit on the registry for that long.
  

  skywalker45 wrote:

  Also have you considered upgrading your Windows installation to SP2? I notice you're still running SP1. If you have a fast internet connection you might consider upgrading now.

  
  I'm considering that now, but I hadn't before. I'd heard horror stories of things that SP2 bollocksed up, so I figured if it wasn't broke, I wasn't going to fix it.
  

  skywalker45 wrote:

  On another note. It's also possible that spybot's tea timer is causing the problem with Ad-Aware. You might want to disable the tea timer and do another scan to see what happens.

  
  Alas, I turned tea timer off entirely and it was still hanging. I didn't have tea timer when this all started...it was an option when I reinstalled spybot, so I grabbed it out of curiosity.
  
  If you think it's worth a shot, I might start Ad-Aware and let it sit overnight to see if it makes a difference, although I've never had to let it sit that long before.
  
  Cheers,
  Sean.

  0
• skywalker45 Bloomington, IN. USA

  March 2006 edited March 2006

  There are tons of subkeys in this key: HKEY_LOCAL_MACHINE\Software\
  Maybe it would be best to let Ad-Aware try a little longer to get past it. You would be much better off at this point to upgrade to service pack 2. In the older days I would have told you to wait but not now. I'm going to continue some research. Let me know if Ad-Aware will get past this problem after letting it go for longer.

  0
• Treadstone71

  March 2006 edited March 2006

  Hi there, after letting it run overnight, AdAware seems to be running happily now!
  
  Thank you so much Skywalker45, I couldn't have done this without your help, thank you! Your help helped me to see what was wrong with my girlfriend's computer as well...if you're ever in Toronto, Canada, I owe you a pint!

  0
• skywalker45 Bloomington, IN. USA

  March 2006 edited March 2006

  No problem Treadstone. I'm glad I could help. I'll close this thread now. If you need it re-opened just PM me or one of the other moderators and we'll open it for you. I'll take you up on the pint if I ever make it up North

  0