Ошибка 0xc004d307 превышено максимально допустимое число сбросов таймера активации

Are you getting “Error 0xc004d307: The maximum allowed number of re-arms has been exceeded” error message while trying to convert a not genuine windows operating system to genuine?

If YES then don’t worry as you can easily deal with this issue. This error message may appear when you run the “SLMGR -REARM” command more than three times.

The command “SLMGR -REARM” is used to convert the trial version of Windows 7 to full version, and during the conversion process of not genuine windows to genuine windows, you may get the error 0xc004d307 when you have tried this command for more than three times.

In this tutorial you will learn the different techniques to fix Error 0xc004d307 or the maximum number of rearms exceeded windows 7 or slmgr rearm not working after reboot “Error 0xc004d307: The maximum allowed number of re-arms has been exceeded”.

As above discussed, while converting not genuine windows to genuine, you may receive this error message (Error 0xc004d307). You can’t run the SLMGR – REARM command more than three times and when the user exceeds the limit this error pops up.

In order to get rid of this error message, you have to reinstall the OS (Operating System). But, if you want to remove Error 0xc004d307 without reinstalling OS then you can do it by following the given steps. But before applying the solutions let’s know what happened when the user run SLMGR -REARM command more than 3 times.

When you execute the command SLMGR -REARM more than 3 times then the value of the “SkipRearm” registry key will turn to “0”. So, we have to change the “SkipRearm” registry key to “1”.

To do this we have to find out the “SkipRearm” key using the registry editor window, the whole process is given below.

1: Open the run dialogue box, by pressing the “Windows + R” keys. After opening the run box, type “Regedit” and press the Enter key. This command will open up the Registry editor window.

Now we have to follow the below-given path:

HKEY_LOCAL_MACHINE/SOFTWARE/Microsoft/WindowsNT/CurrentVersion/SoftwareProtectionPlatform

2: Click on the arrow mark present along with “HKEY_LOCAL_MACHINE”.

3: Click on the arrow mark present along with “SOFTWARE”.

4: Click on the arrow mark present along with “Microsoft”.

5: Click on the arrow mark present along with “Windows NT”.

6: Click on the arrow mark present along with “CurrentVersion”.

7: After it, you have to click on the word “SoftwareProtectionPlatform”

8: Now, right-click on the “SkipRearm” present in the right window.

9: Click on the “Modify” and here change the “Value Data” to “1”.

10: At last, reboot your computer.

Now you can run the command SLMGR -REARM and convert your non-genuine Windows to a genuine operating system without any error message.

Check Your Windows PC/Laptop Health

You can also scan your system with the PC Repair Tool, this tool is designed with an advanced algorithm and help you scan, detect, and fix various PC related issues and errors.

It will automatically scan your entire system and fix several issues related to the registry database, DLL errors, driver confliction, system file integrity, and more. And the most important part of this tool, you don’t need any professional experience to operate it as this software is completely automatic and deal with those errors that you can’t fix manually.

Get PC Repair Tool, to fix errors and optimize Windows PC performance

Conclusion

After applying the above-given technique you can easily convert the trial version of Windows 7 to the full version. But it is recommended to apply the above-discussed solutions very carefully as a small mistake while operating the Windows registry may affect your entire computer.

If you don’t have the knowledge to operate the registry keys then you should avoid these steps and contact a professionally skilled person.

You can also run the automatic Registry Repair Tool, to fix corrupted, damaged registry entries automatically.

Despite this, we would like to hear from you, share your valuable comments, suggestions, or queries on our Facebook page.

Good Luck..!

Issue

In a Windows environment, trying to rearm Office 2013 gets this error:

Possible Cause

#1. The rearm count of Office has been exceeded.

#2. Office was reinstalled or previously upgraded and somehow got corrupted.

Solution #1. Uninstall/Install Office

The rearm count in Office has been exceeded. There is no way to fix this. Office needs to be uninstalled and then reinstalled so that you get your rearms back.

1. Uninstall Office in Programs and Features
2. Restart the OS
3. Install Office
4. Restart the OS
5. Run the OSPPREARM.exe command again

You should now see:

Note: If Solution #1 doesn’t work, try Solution #2.

Solution #2. Run the Office removal VBS

I opened a support case with Microsoft after Solution #1 didn’t work. They told me that while uninstalling Office usually resets the rearms, sometimes every component isn’t removed .  This causes a problem when trying to rearm on the fresh install. Running the script (get code below) fully removes all components from Windows.

1. Uninstall Office in Programs and Features
2. Copy the script data (get code below) into a text file called script.vbs and save it to the C drive.
   (Note: Make sure you see a script icon and not a text file icon. If you see a text file icon, you need to go into folder options, unhide known file extensions and then remove the .txt from the end of the file name. Make sure it only shows script.vbs)
3. Double click the script.vbs file to run it 
4. Restart the OS
5. Install Office
6. Restart the OS
7. Run the OSPPREARM.exe command again

You should now see:

Office Removal VBS

NOTE: I make no promises and am not liable for any problems caused by using this script. It is exactly intact as the way that it was given to me by Microsoft. No modifications have been made. This only works for Office 2013. It does not work in 2016.

'=======================================================================================================
' Name: OffScrub_O15msi.vbs
' Author: Microsoft Customer Support Services
' Copyright (c) 2011, 2012 Microsoft Corporation
' Script to remove (scrub) Office 2013 MSI products
' when a regular uninstall is no longer possible
'=======================================================================================================
Option Explicit

Const SCRIPTVERSION = "1.72"
Const SCRIPTFILE    = "OffScrub_O15msi.vbs"
Const SCRIPTNAME    = "OffScrub_O15msi"
Const OVERSION      = "15.0"
Const OVERSIONMAJOR = "15"
Const OREF          = "Office15"
Const OREGREF       = "OFFICE15."
Const ONAME         = "Office 2013 MSI"
Const OPACKAGE      = "PackageRefs"
Const OFFICEID      = "000000FF1CE}"
Const HKCR          = &H80000000
Const HKCU          = &H80000001
Const HKLM          = &H80000002
Const HKU           = &H80000003
Const FOR_WRITING   = 2
Const PRODLEN       = 12
Const COMPPERMANENT = "00000000000000000000000000000000"
Const UNCOMPRESSED  = 38
Const SQUISHED      = 20
Const COMPRESSED    = 32
Const REG_ARP       = "SOFTWAREMicrosoftWindowsCurrentVersionUninstall"
Const VB_YES        = 6
Const MSIOPENDATABASEREADONLY = 0

'=======================================================================================================
Dim oFso, oMsi, oReg, oWShell, oWmiLocal, oShellApp
Dim ComputerItem, Item, LogStream, TmpKey
Dim arrTmpSKUs, arrDeleteFiles, arrDeleteFolders, arrMseFolders, arrVersion
Dim dicKeepProd, dicKeepLis, dicApps, dicKeepFolder, dicDelRegKey, dicKeepReg
Dim dicInstalledSku, dicRemoveSku, dicKeepSku, dicSrv, dicCSuite, dicCSingle
Dim f64, fLegacyProductFound
Dim sErr, sTmp, sSkuRemoveList, sDefault, sWinDir, sWICacheDir, sMode
Dim sAppData, sTemp, sScrubDir, sProgramFiles, sProgramFilesX86, sCommonProgramFiles
Dim sAllusersProfile, sOSinfo, sOSVersion, sCommonProgramFilesX86, sProfilesDirectory
Dim sProgramData, sLocalAppData, sOInstallRoot
Dim iVersionNT

'=======================================================================================================
'Main
'=======================================================================================================
'Configure defaults
Dim sLogDir : sLogDir = ""
Dim sMoveMessage: sMoveMessage = ""
Dim fRemoveOse      : fRemoveOse = False
Dim fRemoveOspp     : fRemoveOspp = False
Dim fRemoveAll      : fRemoveAll = False
Dim fRemoveCSuites  : fRemoveCSuites = False
Dim fRemoveCSingle  : fRemoveCSingle = False
Dim fRemoveSrv      : fRemoveSrv = False
Dim fKeepUser       : fKeepUser = True  'Default to keep per user settings
Dim fSkipSD         : fSkipSD = False 'Default to not Skip the Shortcut Detection
Dim fDetectOnly     : fDetectOnly = False
Dim fQuiet          : fQuiet = False
Dim fBasic          : fBasic = False
Dim fNoCancel       : fNoCancel = False
Dim fNoElevate      : fNoElevate = False
Dim fIsElevated     : fIsElevated = False
Dim fTryReconcile   : fTryReconcile = False
'CAUTION! -> "fForce" will kill running applications which can result in data loss! <- CAUTION
Dim fForce          : fForce = False
'CAUTION! -> "fForce" will kill running applications which can result in data loss! <- CAUTION
Dim fLogInitialized : fLogInitialized = False
Dim fBypass_Stage1  : fBypass_Stage1 = True 'Component Detection
Dim fBypass_Stage2  : fBypass_Stage2 = False 'Setup
Dim fBypass_Stage3  : fBypass_Stage3 = False 'Msiexec
Dim fBypass_Stage4  : fBypass_Stage4 = False 'CleanUp
Dim fRebootRequired : fRebootRequired = False

'Create required objects
Set oWmiLocal   = GetObject("winmgmts:{(Debug)}\.rootcimv2")
Set oWShell     = CreateObject("Wscript.Shell")
Set oShellApp   = CreateObject("Shell.Application")
Set oFso        = CreateObject("Scripting.FileSystemObject")
Set oMsi        = CreateObject("WindowsInstaller.Installer")
Set oReg        = GetObject("winmgmts:\.rootdefault:StdRegProv")

'Get environment path info
sAppData            = oWShell.ExpandEnvironmentStrings("%appdata%")
sLocalAppData       = oWShell.ExpandEnvironmentStrings("%localappdata%")
sTemp               = oWShell.ExpandEnvironmentStrings("%temp%")
sAllUsersProfile    = oWShell.ExpandEnvironmentStrings("%allusersprofile%")
RegReadValue HKLM, "SOFTWAREMicrosoftWindows NTCurrentVersionProfileList", "ProfilesDirectory", sProfilesDirectory, "REG_EXPAND_SZ"
If NOT oFso.FolderExists(sProfilesDirectory) Then 
sProfilesDirectory  = oFso.GetParentFolderName(oWShell.ExpandEnvironmentStrings("%userprofile%"))
End If
sProgramFiles       = oWShell.ExpandEnvironmentStrings("%programfiles%")
'Deferred until after architecture check
'sProgramFilesX86 = oWShell.ExpandEnvironmentStrings("%programfiles(x86)%")

sCommonProgramFiles = oWShell.ExpandEnvironmentStrings("%commonprogramfiles%")
'Deferred until after architecture check
'sCommonProgramFilesX86 = oWShell.ExpandEnvironmentStrings("%CommonProgramFiles(x86)%")

sProgramData        = oWSHell.ExpandEnvironmentStrings("%programdata%")
sWinDir             = oWShell.ExpandEnvironmentStrings("%windir%")
sWICacheDir         = sWinDir & "" & "Installer"
sScrubDir           = sTemp & "" & SCRIPTNAME

'Detect if we're running on a 64 bit OS
Set ComputerItem = oWmiLocal.ExecQuery("Select * from Win32_ComputerSystem")
For Each Item In ComputerItem
f64 = Instr(Left(Item.SystemType,3),"64") > 0
If f64 Then Exit For
Next
If f64 Then sProgramFilesX86 = oWShell.ExpandEnvironmentStrings("%programfiles(x86)%")
If f64 Then sCommonProgramFilesX86 = oWShell.ExpandEnvironmentStrings("%CommonProgramFiles(x86)%")

'Get OS details and VersionNT
Set ComputerItem =oWmiLocal.ExecQuery("Select * from Win32_OperatingSystem")
For Each Item in ComputerItem 
sOSinfo = sOSinfo & Item.Caption 
sOSinfo = sOSinfo & Item.OtherTypeDescription
sOSinfo = sOSinfo & ", " & "SP " & Item.ServicePackMajorVersion
sOSinfo = sOSinfo & ", " & "Version: " & Item.Version
sOsVersion = Item.Version
sOSinfo = sOSinfo & ", " & "Codepage: " & Item.CodeSet
sOSinfo = sOSinfo & ", " & "Country Code: " & Item.CountryCode
sOSinfo = sOSinfo & ", " & "Language: " & Item.OSLanguage
Next

'Build the VersionNT number
arrVersion = Split(sOsVersion,Delimiter(sOsVersion))
iVersionNt = CInt(arrVersion(0))*100 + CInt(arrVersion(1))

fIsElevated = CheckRegPermissions
If NOT fIsElevated AND NOT fNoElevate Then
'Try to relaunch elevated
RelaunchElevated

'Can't relaunch. Exit out
If UCase(Mid(Wscript.FullName, Len(Wscript.Path) + 2, 1)) = "C" Then
If Not fLogInitialized Then CreateLog
Log "Insufficient registry access permissions - exiting"
End If
'Undo temporary entries created in ARP
TmpKeyCleanUp
wscript.quit 
End If

'Ensure CScript as engine
If Not UCase(Mid(Wscript.FullName, Len(Wscript.Path) + 2, 1)) = "C" Then RelaunchAsCScript

'Create Dictionaries
Set dicKeepProd = CreateObject("Scripting.Dictionary")
Set dicInstalledSku = CreateObject("Scripting.Dictionary")
Set dicRemoveSku = CreateObject("Scripting.Dictionary")
Set dicKeepSku = CreateObject("Scripting.Dictionary")
Set dicKeepLis = CreateObject("Scripting.Dictionary")
Set dicKeepFolder = CreateObject("Scripting.Dictionary")
Set dicApps = CreateObject("Scripting.Dictionary")
Set dicDelRegKey = CreateObject("Scripting.Dictionary")
Set dicKeepReg = CreateObject("Scripting.Dictionary")
Set dicSrv = CreateObject("Scripting.Dictionary")
Set dicCSuite = CreateObject("Scripting.Dictionary")
Set dicCSingle = CreateObject("Scripting.Dictionary")

'Create the temp folder
If Not oFso.FolderExists(sScrubDir) Then oFso.CreateFolder sScrubDir

'Set the default logging directory
sLogDir = sScrubDir

'Call the command line parser
ParseCmdLine

'Get Office Install Folder
If NOT RegReadValue(HKLM,"SOFTWAREMicrosoftOffice"&OVERSION&"CommonInstallRoot","Path",sOInstallRoot,"REG_SZ") Then 
sOInstallRoot = sProgramFiles & "Microsoft Office"&OREF
End If

'Ensure integrity of WI metadata which could fail used APIs otherwise
EnsureValidWIMetadata HKCU,"SoftwareClassesInstallerProducts",COMPRESSED
EnsureValidWIMetadata HKCR,"InstallerProducts",COMPRESSED
EnsureValidWIMetadata HKLM,"SOFTWAREMicrosoftWindowsCurrentVersionInstallerUserDataS-1-5-18Products",COMPRESSED
EnsureValidWIMetadata HKLM,"SOFTWAREMicrosoftWindowsCurrentVersionInstallerUserDataS-1-5-18Components",COMPRESSED
EnsureValidWIMetadata HKCR,"InstallerComponents",COMPRESSED

'Add initial known .exe files that might need to be closed
dicApps.Add "communicator.exe", "communicator.exe"
dicApps.Add "setup.exe", "setup.exe"
Select Case OVERSIONMAJOR
Case "12"
Case "14"
dicApps.Add "bcssync.exe","bcssync.exe"
dicApps.Add "officesas.exe","officesas.exe"
dicApps.Add "officesasscheduler.exe","officesasscheduler.exe"
dicApps.Add "msosync.exe","msosync.exe"
dicApps.Add "onenotem.exe","onenotem.exe"
Case "15"
Case Else
End Select

'-------------------
'Stage # 0 - Basics |
'-------------------
'Build a list with installed/registered Office products
sTmp = "Stage # 0 " & chr(34) & "Basics" & chr(34) & " (" & Time & ")"
Log vbCrLf & sTmp & vbCrLf & String(Len(sTmp),"=") & vbCrLf

FindInstalledOProducts
If dicInstalledSku.Count > 0 Then Log "Found registered product(s): " & Join(RemoveDuplicates(dicInstalledSku.Items),",") &vbCrLf

'Validate the list of products we got from the command line if applicable
ValidateRemoveSkuList

'Log detection results
If dicRemoveSku.Count > 0 Then Log "Product(s) to be removed: " & Join(RemoveDuplicates(dicRemoveSku.Items),",")
sMode = "Selected " & ONAME & " products"
If Not dicRemoveSku.Count > 0 Then sMode = "Orphaned " & ONAME & " products"
If fRemoveAll Then sMode = "All " & ONAME & " products"
Log "Final removal mode: " & sMode
Log "Remove OSE service: " & fRemoveOse &vbCrLf

'Log preview mode if applicable
If fDetectOnly Then Log "*************************************************************************"
If fDetectOnly Then Log "*                          PREVIEW MODE                                 *"
If fDetectOnly Then Log "* All uninstall and delete operations will only be logged not executed! *"
If fDetectOnly Then Log "*************************************************************************" & vbCrLf

'Check if there are legacy products installed
CheckForLegacyProducts
If fLegacyProductFound Then Log "Found legacy Office products that will not be removed." Else Log "No legacy Office products found."

'Cache .msi files
If dicRemoveSku.Count > 0 Then CacheMsiFiles

'Log Sku/Prod detection results
LogSkuResults

'UnPin Shortcuts
If NOT fSkipSD AND dicRemoveSku.Count > 0 Then
On Error Resume Next
Log " Searching for pinned shortcuts"
CleanShortcuts sAllUsersProfile, False, True
CleanShortcuts sProfilesDirectory, False, True
On Error Goto 0
End If 'NOT SkipSD


'--------------------------------
'Stage # 1 - Component Detection |
'--------------------------------
sTmp = "Stage # 1 " & chr(34) & "Component Detection" & chr(34) & " (" & Time & ")"
Log vbCrLf & sTmp & vbCrLf & String(Len(sTmp),"=") & vbCrLf
If Not fBypass_Stage1 OR fForce Then
'Build a list with files which are installed/registered to a product that's going to be removed
Log "Prepare for CleanUp stages."
Log "Identifying removable elements. This can take several minutes."
ScanComponents 
Else
Log "Not running Component Detection in default removal."
End If

'End all running Office applications
If fForce OR fQuiet Then CloseOfficeApps

'----------------------
'Stage # 2 - Setup.exe |
'----------------------
sTmp = "Stage # 2 " & chr(34) & "Setup.exe" & chr(34) & " (" & Time & ")"
Log vbCrLf & sTmp & vbCrLf & String(Len(sTmp),"=") & vbCrLf
If Not fBypass_Stage2 Then
SetupExeRemoval
Else
Log "Skipping Setup.exe because bypass was requested."
End If

'------------------------
'Stage # 3 - Msiexec.exe |
'------------------------
sTmp = "Stage # 3 " & chr(34) & "Msiexec.exe" & chr(34) & " (" & Time & ")"
Log vbCrLf & sTmp & vbCrLf & String(Len(sTmp),"=") & vbCrLf
If Not fBypass_Stage3 Then
MsiexecRemoval
Else
Log "Skipping Msiexec.exe because bypass was requested."
End If

'--------------------
'Stage # 4 - CleanUp |
'--------------------
'Removal of files and registry settings
sTmp = "Stage # 4 " & chr(34) & "CleanUp" & chr(34) & " (" & Time & ")"
Log vbCrLf & sTmp & vbCrLf & String(Len(sTmp),"=") & vbCrLf
If Not fBypass_Stage4 Then

'Office Source Engine
If fRemoveOse Then RemoveOSE

'Local Installation Source (MSOCache)
WipeLIS

'Obsolete files
If fRemoveAll Then 
FileWipeAll 
Else 
FileWipeIndividual
End If

'Empty Folders
DeleteEmptyFolders

'Restore Explorer if needed
If fForce OR fQuiet Then RestoreExplorer

'Registry data
RegWipe

'Wipe orphaned files from Windows Installer cache
MsiClearOrphanedFiles

'Temporary .msi files in scrubcache
DeleteMsiScrubCache

'Temporary files
DelScrubTmp

Else
Log "Skipping CleanUp because bypass was requested."
End If

If Not sMoveMessage = "" Then Log vbCrLf & "Please remove this folder after next reboot: " & sMoveMessage

'THE END
Log vbCrLf & "End removal: " & Now & vbCrLf
Log vbCrLf & "For detailed logging please refer to the log in folder " &chr(34)&sScrubDir&chr(34)&vbCrLf

If fRebootRequired Then
Log vbCrLf & "A restart is required to complete the operation!"
If NOT fQuiet Then
If MsgBox("Do you want to reboot now?",vbYesNo,"Reboot Required") = VB_YES Then
Dim colOS, oOS
Dim oWmiReboot
Set oWmiReboot = GetObject("winmgmts:{impersonationLevel=impersonate,(Shutdown)}!\.rootcimv2")
Set colOS = oWmiReboot.ExecQuery ("Select * from Win32_OperatingSystem")
For Each oOS in colOS
oOS.Reboot()
Next
End If
End If
End If

If NOT fQuiet Then
For Each Item in Wscript.Arguments
If Item = "UAC" Then 
wscript.stdout.write "Press <Enter> to close this window"
sTemp = wscript.stdin.read(1)
End If
Next 'Argument
End If
'=======================================================================================================
'=======================================================================================================

'Stage 0 - 4 Subroutines
'=======================================================================================================

'Office configuration products are listed with their configuration product name in the "Uninstall" key
'To identify an Office configuration product all of these condiditions have to be met:
' - "SystemComponent" does not have a value of "1" (DWORD) 
' - "OPACKAGE" (see constant declaration) entry exists and is not empty
' - "DisplayVersion" exists and the 2 leftmost digits are "OVERSIONMAJOR"
Sub FindInstalledOProducts
Dim ArpItem, File
Dim sCurKey, sValue, sConfigName, sProdC, sCVHValue
Dim sProductCodeList, sProductCode 
Dim arrKeys, arrMultiSzValues
Dim fSystemComponent0, fPackages, fDisplayVersion, fReturn, fCategorized

If dicInstalledSku.Count > 0 Then Exit Sub 'Already done from InputBox prompt

'Handle orphaned products to get them added to the detection scope
If fTryReconcile Then
For Each File in oFso.GetFolder(sWICacheDir).Files
If Len(File.Name)>3 Then
Select Case LCase(Right(File.Name,4))
Case ".msi"
sProductCode = ""
sProductCode = GetMsiProductCode(File.Path)
If InScope(sProductCode) Then
If NOT RegKeyExists(HKLM,REG_ARP & sProductCode) Then
'Ensure the orphaned item is getting removed
If Len(sSkuRemoveList) > 0 Then
sSkuRemoveList = sSkuRemoveList & "," & GetProductID(Mid(sProductCode,11,4))
Else
sSkuRemoveList = GetProductID(Mid(sProductCode,11,4))
End If
'Add to ScrubDir
oFso.CopyFile File.Path,sScrubDir & "" & prod & ".msi",True
'Register the product with MSI
MsiRegisterProduct File.Path
End If 'NOT sProductCode
End If 'InScope
Case Else
End Select
End If '>3
Next 'File
End If 'fTryReconcile

'Locate standalone Office products that have no configuration product entry and create a
'temporary configuration entry
ReDim arrTmpSKUs(-1)
If RegEnumKey(HKLM,REG_ARP,arrKeys) Then
For Each ArpItem in arrKeys
If InScope(ArpItem) Then
sCurKey = REG_ARP & ArpItem & ""
fSystemComponent0 = Not (RegReadValue(HKLM,sCurKey,"SystemComponent",sValue,"REG_DWORD") AND (sValue = "1"))
If (fSystemComponent0 AND (NOT RegReadValue(HKLM,sCurKey,"CVH",sCVHValue,"REG_DWORD"))) Then
RegReadValue HKLM,sCurKey,"DisplayVersion",sValue,"REG_SZ"
Redim arrMultiSzValues(0)
'Logic changed to drop the LCID identifier
'sConfigName = GetProductID(Mid(ArpItem,11,4)) & "_" & CInt("&h" & Mid(ArpItem,16,4))
sConfigName = OREGREF & GetProductID(Mid(ArpItem,11,4))
If NOT RegKeyExists(HKLM,REG_ARP&sConfigName) Then
'Create a new ARP item
ReDim Preserve arrTmpSKUs(UBound(arrTmpSKUs)+1)
arrTmpSKUs(UBound(arrTmpSKUs)) = sConfigName
oReg.CreateKey HKLM,REG_ARP & sConfigName
arrMultiSzValues(0) = sConfigName
oReg.SetMultiStringValue HKLM,REG_ARP & sConfigName,OPACKAGE,arrMultiSzValues
arrMultiSzValues(0) = ArpItem
oReg.SetStringValue HKLM, REG_ARP & sConfigName, "Comment", "Temporary OffScrub generated key. Please delete this key!"
oReg.SetMultiStringValue HKLM,REG_ARP & sConfigName,"ProductCodes",arrMultiSzValues
oReg.SetStringValue HKLM,REG_ARP & sConfigName,"DisplayVersion",sValue
oReg.SetStringValue HKLM,REG_ARP & sConfigName,"DisplayName",SCRIPTNAME & "_" & sConfigName
oReg.SetDWordValue HKLM,REG_ARP & sConfigName,"SystemComponent",0
Else
'Update the existing temporary ARP item
fReturn = RegReadValue(HKLM,REG_ARP&sConfigName,"ProductCodes",sProdC,"REG_MULTI_SZ")
If NOT InStr(sProdC,ArpItem)>0 Then sProdC = sProdC & chr(34) & ArpItem
oReg.SetMultiStringValue HKLM,REG_ARP & sConfigName,"ProductCodes",Split(sProdC,chr(34))
End If 'RegKeyExists
End If 'fSystemComponent0
End If 'InScope
Next 'ArpItem
End If 'RegEnumKey

'Find the configuration products
If RegEnumKey(HKLM,REG_ARP,arrKeys) Then
For Each ArpItem in arrKeys
sCurKey = REG_ARP & ArpItem & ""
sValue = ""
fSystemComponent0 = NOT (RegReadValue(HKLM,sCurKey,"SystemComponent",sValue,"REG_DWORD") AND (sValue = "1"))
fPackages = RegReadValue(HKLM,sCurKey,OPACKAGE,sValue,"REG_MULTI_SZ")
fDisplayVersion = RegReadValue(HKLM,sCurKey,"DisplayVersion",sValue,"REG_SZ")
If fDisplayVersion Then
If Len(sValue) > 1 Then
fDisplayVersion = (Left(sValue,2) = OVERSIONMAJOR)
Else
fDisplayVersion = False
End If
End If
If (fSystemComponent0 AND fPackages AND fDisplayVersion) Then
If InStr(ArpItem,".")>0 Then sConfigName = UCase(Mid(ArpItem,InStr(ArpItem,".")+1)) Else sConfigName = UCase(ArpItem)
If NOT dicInstalledSku.Exists(sConfigName) Then dicInstalledSku.Add sConfigName,sConfigName

'Categorize the SKU
'Three categories are available: ClientSuite, ClientSingleProduct, Server
If RegReadValue(HKLM, REG_ARP & OREGREF & sConfigName, "ProductCodes", sProductCodeList, "REG_MULTI_SZ") Then
fCategorized = False
For Each sProductCode in Split(sProductCodeList,chr(34))
If Len(sProductCode) = 38 Then
If NOT Mid(sProductCode,11,1) = "0" Then
'Server product
If NOT dicSrv.Exists(UCase(sConfigName)) Then dicSrv.Add UCase(sConfigName),sConfigName
fCategorized = True
Exit For
Else
Select Case Mid(sProductCode,11,4)
'Client Suites
Case "000F","0011","0012","0013","0014","0015","0016","0017","0018","0019","001A","001B","0029","002B","002E","002F","0030","0031","0033","0035","0037","003D","0044","0049","0061","0062","0066","006C","006D","006F","0074","00A1","00A3","00A9","00BA","00CA","00E0","0100","0103","011A"
If NOT dicCSuite.Exists(UCase(sConfigName)) Then dicCSuite.Add UCase(sConfigName),sConfigName
fCategorized = True
Exit For

Case Else
End Select
End If

End If 'Len 38
Next 'sProductCode
If NOT fCategorized Then
If NOT dicCSingle.Exists(UCase(sConfigName)) Then dicCSingle.Add UCase(sConfigName),sConfigName
End If 'fCategorized
End If 'RegReadValue "ProductCodes"

End If
Next 'ArpItem
End If 'RegEnumKey
End Sub 'FindInstalledOProducts
'=======================================================================================================

'Check if there are Office products from previous versions on the computer
Sub CheckForLegacyProducts
Const OLEGACY = "78E1-11D2-B60F-006097C998E7}.6000-11D3-8CFE-0050048383C9}.6000-11D3-8CFE-0150048383C9}.BDCA-11D1-B7AE-00C04FB92F3D}.6D54-11D4-BEE3-00C04F990354}"
Dim Product

'Set safe default
fLegacyProductFound = True

For Each Product in oMsi.Products
If Len(Product) = 38 Then
'Handle O09 - O11 Products
If InStr(OLEGACY, UCase(Right(Product, 28)))>0 Then
'Found legacy Office product. Keep flag in default and exit
Exit Sub
End If
If UCase(Right(Product,PRODLEN)) = OFFICEID Then
Select Case Mid(Product,4,2)
Case "12", "14"
'Found legacy Office product. Keep flag in default and exit
Exit Sub
Case Else
End Select
End If
End If '38
Next 'Product
fLegacyProductFound = False

End Sub 'CheckForLegacyProducts
'=======================================================================================================

'Create clean list of Products to remove.
'Strip off bad & empty contents
Sub ValidateRemoveSkuList
Dim Sku, Key, sProductCode, sProductCodeList
Dim arrRemoveSKUs

If fRemoveAll Then
'Remove all mode
For Each Key in dicInstalledSku.Keys
dicRemoveSku.Add Key,dicInstalledSku.Item(Key)
Next 'Key
Else
'Remove individual products or preconfigured configurations mode

'Ensure to have a string with no unexpected contents
sSkuRemoveList = Replace(sSkuRemoveList,";",",")
sSkuRemoveList = Replace(sSkuRemoveList," ","")
sSkuRemoveList = Replace(sSkuRemoveList,Chr(34),"")
While InStr(sSkuRemoveList,",,")>0
sSkuRemoveList = Replace(sSkuRemoveList,",,",",")
Wend

'Prepare 'remove' and 'keep' dictionaries to determine what has to be removed

'Initial pre-fill of 'keep' dic
For Each Key in dicInstalledSku.Keys
dicKeepSku.Add Key,dicInstalledSku.Item(Key)
Next 'Key

'Determine contents of keep and remove dic
'Individual products
arrRemoveSKUs = Split(UCase(sSkuRemoveList),",")
For Each Sku in arrRemoveSKUs
If Sku = "OSE" Then fRemoveOse = True
If dicKeepSku.Exists(Sku) Then
'A Sku to remove has been passed in
'remove the item from the keep dic
dicKeepSku.Remove(Sku)
'Now add it to the remove dic
If NOT dicRemoveSku.Exists(Sku) Then dicRemoveSku.Add Sku,Sku
End If
Next 'Sku

'Client Suite Category
If fRemoveCSuites Then
For Each Key in dicInstalledSku.Keys
If dicCSuite.Exists(Key) Then
If dicKeepSku.Exists(Key) Then dicKeepSku.Remove(Key)
If NOT dicRemoveSku.Exists(Key) Then dicRemoveSku.Add Key,Key
End If
Next 'Key
End If 'fRemoveCSuites

'Client Single/Standalone Category
If fRemoveCSingle Then
For Each Key in dicInstalledSku.Keys
If dicCSingle.Exists(Key) Then
If dicKeepSku.Exists(Key) Then dicKeepSku.Remove(Key)
If NOT dicRemoveSku.Exists(Key) Then dicRemoveSku.Add Key,Key
End If
Next 'Key
End If 'fRemoveCSingle

'Server Category
If fRemoveSrv Then
For Each Key in dicInstalledSku.Keys
If dicSrv.Exists(Key) Then
If dicKeepSku.Exists(Key) Then dicKeepSku.Remove(Key)
If NOT dicRemoveSku.Exists(Key) Then dicRemoveSku.Add Key,Key
End If
Next 'Key
End If 'fRemoveSrv

If NOT dicKeepSku.Count > 0 Then fRemoveAll = True

End If 'fRemoveAll

'Fill the KeepProd dic
For Each Sku in dicKeepSku.Keys
If RegReadValue(HKLM,REG_ARP & OREGREF & Sku,"ProductCodes",sProductCodeList,"REG_MULTI_SZ") Then
For Each sProductCode in Split(sProductCodeList,chr(34))
If Len(sProductCode) = 38 Then
If NOT dicKeepProd.Exists(sProductCode) Then dicKeepProd.Add sProductCode,Sku
End If '38
Next 'sProductCod 
End If
Next 'Sku

If fRemoveAll OR fRemoveOse Then CheckRemoveOSE
If fRemoveAll OR fRemoveOspp Then CheckRemoveOspp

End Sub 'ValidateRemoveSkuList
'=======================================================================================================

'Check if OSE service can be scrubbed
Sub CheckRemoveOSE
Const O11 = "6000-11D3-8CFE-0150048383C9}"
Dim Product

If fRemoveOse Then Exit Sub
For Each Product in oMsi.Products
If Len(Product) = 38 Then
If UCase(Right(Product,28)) = O11 Then 
'Found Office 2003 Product. Set flag to not remove the OSE service
Exit Sub
End If
If UCase(Right(Product,PRODLEN))=OFFICEID Then
Select Case Mid(Product,4,2)
Case "12","14","15","16","17"
'Found another Office product. Set flag to keep the OSE service
If NOT Mid(Product,4,2) = OVERSIONMAJOR Then
fRemoveOse = False
Exit Sub
End If
Case Else
End Select
End If
End If '38
Next 'Product
fRemoveOse = True
End Sub 'CheckRemoveOSE
'=======================================================================================================

'Check if OSPP service can be scrubbed
Sub CheckRemoveOSPP
Dim Product

If NOT CInt(OVERSIONMAJOR) > 12 Then 
fRemoveOspp = False
Exit Sub
End If

If fRemoveOspp Then Exit Sub
For Each Product in oMsi.Products
If Len(Product) = 38 Then
If UCase(Right(Product,PRODLEN))=OFFICEID Then
Select Case Mid(Product,4,2)
Case "14","15","16","17"
'Found another Office product. Set flag to keep the OSPP service
If NOT Mid(Product,4,2) = OVERSIONMAJOR Then
fRemoveOspp = False
Exit Sub
End If
Case Else
End Select
End If
End If '38
Next 'Product
fRemoveOspp = True
End Sub 'CheckRemoveOSPP
'=======================================================================================================

'Cache .msi files for products that will be removed in case they are needed for later file detection
Sub CacheMsiFiles
Dim Product
Dim sMsiFile

'Non critical routine for failures.
'Errors will be logged but must not fail the execution
On Error Resume Next
Log " Cache .msi files to temporary Scrub folder"
'Cache the files
For Each Product in oMsi.Products
'Ensure valid GUID length
If InScope(Product) Then
If (fRemoveAll OR CheckDelete(Product))Then
CheckError "CacheMsiFiles"
sMsiFile = oMsi.ProductInfo(Product,"LocalPackage") : CheckError "CacheMsiFiles"
LogOnly " - " & Product & ".msi"
If oFso.FileExists(sMsiFile) Then oFso.CopyFile sMsiFile,sScrubDir & "" & Product & ".msi",True
CheckError "CacheMsiFiles"
End If
End If 'InScope
Next 'Product

Err.Clear
End Sub 'CacheMsiFiles
'=======================================================================================================

'Build a list of all files that will be deleted
Sub ScanComponents
Const MSIINSTALLSTATE_LOCAL = 3

Dim FileList, RegList, ComponentID, CompClient, Record, qView, MsiDb, CompVerbose
Dim Processes, Process, Prop, prod
Dim sQuery, sSubKeyName, sPath, sFile, sMsiFile, sCompClient, sComponent, sCompReg
Dim fRemoveComponent, fAffectedComponent, fIsPermanent, fIsFile, fIsFolder
Dim i, iProgress, iCompCnt, iRemCnt
Dim dicFLError, oDic, oFolderDic, dicCompPath
Dim hDefKey

'Logfile
Set FileList = oFso.OpenTextFile(sScrubDir & "FileList.txt",FOR_WRITING,True,True)
Set RegList = oFso.OpenTextFile(sScrubDir & "RegList.txt",FOR_WRITING,True,True)
Set CompVerbose = oFso.OpenTextFile(sScrubDir & "CompVerbose.txt",FOR_WRITING,True,True)

'FileListError dic
Set dicFLError = CreateObject("Scripting.Dictionary")

Set oDic = CreateObject("Scripting.Dictionary")
Set oFolderDic = CreateObject("Scripting.Dictionary")
Set dicCompPath = CreateObject("Scripting.Dictionary")

'Prevent that API errors fail script execution
On Error Resume Next

iCompCnt = oMsi.Components.Count
If NOT Err = 0 Then
'API failure
Log "Error during components detection. Cannot complete this task."
Err.Clear
Exit Sub
End If

'Ensure to not divide by zero
If iCompCnt = 0 Then iCompCnt = 1
LogOnly " Scanning " & iCompCnt & " components"
'Enum all Components
For Each ComponentID In oMsi.Components
CompVerbose.WriteLine vbCrLf & "Checking Component: " & ComponentID

'Progress bar
i = i + 1
If iProgress < (i / iCompCnt) * 100 Then 
wscript.stdout.write "." : LogStream.Write "."
iProgress = iProgress + 1
If iProgress = 35 OR iProgress = 70 Then Log ""
End If

'Check if all ComponentClients will be removed
sCompClient = ""
iRemCnt = 0
fIsPermanent = False
fRemoveComponent = False 'Flag to track if the component will be completely removed
fAffectedComponent = False 'Flag to track if some clients remain installed who have a none shared location
dicCompPath.RemoveAll
Err.Clear
For Each CompClient In oMsi.ComponentClients(ComponentID)
CompVerbose.Write " CompClient " & CompClient & "-> "
If Err = 0 Then
'Ensure valid guid length
If Len(CompClient) = 38 Then
fRemoveComponent = InScope(CompClient)
If fRemoveComponent OR (CompClient = "{00000000-0000-0000-0000-000000000000}") Then
sPath = ""
sPath = LCase(oMsi.ComponentPath(CompClient,ComponentID))
sPath = Replace(sPath,"?",":")
'Scan for msidbComponentAttributesPermanent flag
If CompClient = "{00000000-0000-0000-0000-000000000000}" Then
fIsPermanent = True
iRemCnt = iRemCnt + 1
End If
If fRemoveComponent Then fRemoveComponent = CheckDelete(CompClient)
CompVerbose.Write "CheckDelete: " & fRemoveComponent & "; "
If fRemoveComponent Then
iRemCnt = iRemCnt + 1
fAffectedComponent = True
'Since the scope remains within one Office family the keypath for the component
'is assumed to be identical
If sCompClient = "" Then sCompClient = CompClient
' flag the CompClient entry for removal
sCompReg = "InstallerComponents"&GetCompressedGuid(ComponentID)&""&GetCompressedGuid(CompClient)
If NOT dicDelRegKey.Exists(sCompReg) Then
dicDelRegKey.Add sCompReg,HKCR
RegList.WriteLine HiveString(HKCR)&""&sCompReg
End If
sCompReg = "SOFTWAREMicrosoftWindowsCurrentVersionInstallerUserDataS-1-5-18Components"&GetCompressedGuid(ComponentID)&""&GetCompressedGuid(CompClient)
If NOT dicDelRegKey.Exists(sCompReg) Then
dicDelRegKey.Add sCompReg,HKLM
RegList.WriteLine HiveString(HKCR)&""&sCompReg
End If
Else
If NOT dicCompPath.Exists(sPath) Then dicCompPath.Add sPath,CompClient
End If
CompVerbose.WriteLine "AffectedComponent: " & fAffectedComponent
CompVerbose.WriteLine " CompClient now set to: " & sCompClient
Else
CompVerbose.Write "InScope: " & fRemoveComponent & "; "
End If
Else
CompVerbose.WriteLine "Error: Invalid metadata"
If NOT dicFLError.Exists("Error: Invalid metadata found. ComponentID: "&ComponentID &", ComponentClient: "&CompClient) Then _
dicFLError.Add "Error: Invalid metadata found. ComponentID: "&ComponentID &", ComponentClient: "&CompClient, ComponentID
End If '38
Else
CompVerbose.WriteLine "Error: " & Err.number & " " & Err.Description
Err.Clear
End If 'Err = 0
Next 'CompClient

'Determine if the component resources go away
sPath = ""
fRemoveComponent = fAffectedComponent AND (iRemCnt = oMsi.ComponentClients(ComponentID).Count)
CompVerbose.WriteLine " Component goes away: " & fRemoveComponent
' This caused unintentional removals
'        If NOT fRemoveComponent AND fAffectedComponent Then
'            'Flag as removable if component has a unique keypath
'            sPath = LCase(oMsi.ComponentPath(sCompClient,ComponentID))
'            sPath = Replace(sPath,"?",":")
'            fRemoveComponent = NOT dicCompPath.Exists(sPath)
'        End If
If fRemoveComponent Then
'Check msidbComponentAttributesPermanent flag
If fIsPermanent AND NOT fForce Then fRemoveComponent = False
CompVerbose.WriteLine " msidbComponentAttributesPermanent: " & NOT fRemoveComponent
End If

If fRemoveComponent Then
CompVerbose.WriteLine " RESULT: Component IN SCOPE for removal"
fIsFile = False : fIsFolder = False

'Component resources go away for this product
Err.Clear
'Add the component registration key to ensure removal
sCompReg = "InstallerComponents"&GetCompressedGuid(ComponentID)&""
If NOT dicDelRegKey.Exists(sCompReg) Then
dicDelRegKey.Add sCompReg,HKCR
RegList.WriteLine HiveString(HKCR)&""&sCompReg
End If
sCompReg = "SOFTWAREMicrosoftWindowsCurrentVersionInstallerUserDataS-1-5-18Components"&GetCompressedGuid(ComponentID)&""
If NOT dicDelRegKey.Exists(sCompReg) Then
dicDelRegKey.Add sCompReg,HKLM
RegList.WriteLine HiveString(HKCR)&""&sCompReg
End If
'Get the component path
If sPath = "" Then
sPath = LCase(oMsi.ComponentPath(sCompClient,ComponentID))
sPath = Replace(sPath,"?",":")
End If
CompVerbose.WriteLine " Path: " & sPath
If Len(sPath) > 4 Then
If Left(sPath,1) = "0" Then
'Registry keypath

Select Case Left(sPath,2)
Case "00"
sPath = Mid(sPath,5)
hDefKey = HKCR
Case "01"
sPath = Mid(sPath,5)
hDefKey = HKCU
Case "02","22"
sPath = Mid(sPath,5)
hDefKey = HKLM
Case Else
'
End Select
If NOT dicDelRegKey.Exists(sPath) Then
dicDelRegKey.Add sPath,hDefKey
RegList.WriteLine HiveString(hDefKey)&""&sPath
End If
Else

'File or Folder
If oFso.FileExists(sPath) OR oFso.FolderExists(sPath) Then
If Right(sPath,1) = "" Then
fIsFolder = True
CompVerbose.WriteLine " Folder check OK"
Else
fIsFile = True
CompVerbose.WriteLine " File check OK"
End If
If fIsFile Then sPath = oFso.GetFile(sPath).ParentFolder
If Not oFolderDic.Exists(sPath) Then
oFolderDic.Add sPath,sPath
FileList.WriteLine sPath & vbTab & "(FOLDER)"
End If
'Get the .msi file
If oFso.FileExists(sScrubDir & "" & sCompClient & ".msi") Then
sMsiFile = sScrubDir & "" & sCompClient & ".msi"
Else
sMsiFile = oMsi.ProductInfo(sCompClient,"LocalPackage")
End If
CompVerbose.WriteLine " Set msi file to : " & sMsiFile
If Not Err = 0 Then
CompVerbose.WriteLine " Error: Failed to obtain .msi file for product " & sCompClient
If NOT dicFLError.Exists("Failed to obtain .msi file for product "&sCompClient) Then _
dicFLError.Add "Failed to obtain .msi file for product "&sCompClient, ComponentID
Err.Clear
End If
CompVerbose.Write " Open .msi file for reading returned: "
Set MsiDb = oMsi.OpenDatabase(sMsiFile,MSIOPENDATABASEREADONLY)

If Err = 0 Then
CompVerbose.WriteLine " SUCCESS"
'Get the component name from the 'Component' table
sQuery = "SELECT `Component`,`ComponentId` FROM Component WHERE `ComponentId` = '" & ComponentID &"'"
Set qView = MsiDb.OpenView(sQuery) : qView.Execute
Set Record = qView.Fetch()
If Not Record Is Nothing Then sComponent = Record.Stringdata(1)
CompVerbose.WriteLine " Obtained ComponentId as: " & sComponent

'Get filenames from the 'File' table
sQuery = "SELECT `Component_`,`FileName` FROM File WHERE `Component_` = '" & sComponent &"'"
Set qView = MsiDb.OpenView(sQuery) : qView.Execute
Set Record = qView.Fetch()
Do Until Record Is Nothing
'Read the filename
sFile = Record.StringData(2)
If InStr(sFile,"|") > 0 Then sFile = Mid(sFile,InStr(sFile,"|")+1,Len(sFile))
'sFile = sPath & "" & sFile
CompVerbose.WriteLine "  File: " & sPath& "" & sFile
If Not oDic.Exists(sPath & "" & sFile) Then 
'Exception handler
fAdd = True
Select Case UCase(sFile)
Case "FPERSON.DLL"
'Catch exception caused by changed .msi keypath authoring logic for smart tags
For Each prod in oMsi.Products
If NOT Checkdelete(prod) Then
If oMsi.FeatureState(prod, "MSTagPluginNamesFiles") = MSIINSTALLSTATE_LOCAL Then
fAdd = False
Exit For
End If
End If
Next 'prod
Case Else
End Select
If fAdd Then
CompVerbose.WriteLine "  Added as new file to dictionary"
oDic.Add sPath & "" & sFile,sFile
FileList.WriteLine sFile & vbTab & sPath & "" & sFile
If Len(sFile)>4 Then
sFile = LCase(sFile)
If Right(sFile,4) = ".exe" Then
If NOT dicApps.Exists(sFile) Then
Select Case sFile
Case "setup.exe","ose.exe","osppsvc.exe","explorer.exe"
Case Else
dicApps.Add sFile,LCase(sPath) & "" & sFile
CompVerbose.WriteLine "  Added to the list of processes that need to be closed."
End Select
End If 'dicApps.Exists
End If '.exe
End If 'Len > 4
End If 'fAdd
End If 'oDic.Exists
Set Record = qView.Fetch()
Loop
Set Record = Nothing
qView.Close
Set qView = Nothing
Else
CompVerbose.WriteLine " Error: Could not read from .msi file"
If NOT dicFLError.Exists("Error: Could not read from .msi file: "&sMsiFile) Then _
dicFLError.Add "Error: Could not read from .msi file: "&sMsiFile, ComponentID
Err.Clear
End If 'Err = 0
Else
CompVerbose.WriteLine " Error: File check FAILED"
End If 'FileExists(sPath)
End If
End If 'Len(sPath) > 4
Else
CompVerbose.WriteLine " RESULT: Component NOT in scope for removal"
If fAffectedComponent Then
'Add the path to the 'Keep' dictionary
Err.Clear
For Each CompClient In oMsi.ComponentClients(ComponentID)
'Get the component path
sPath = "" : sPath = LCase(oMsi.ComponentPath(CompClient,ComponentID))
sPath = Replace(sPath,"?",":")

If Len(sPath) > 4 Then
If Left(sPath,1) = "0" Then
'Registry keypath

Select Case Left(sPath,2)
Case "00"
sPath = Mid(sPath,5)
hDefKey = HKCR
Case "01"
sPath = Mid(sPath,5)
hDefKey = HKCU
Case "02","22"
sPath = Mid(sPath,5)
hDefKey = HKLM
Case Else
'
End Select
If NOT dicKeepReg.Exists(LCase(sPath)) Then
dicKeepReg.Add LCase(sPath),hDefKey
End If
Else
'File keypath
If oFso.FileExists(sPath) Then
If NOT dicKeepFolder.Exists(LCase(sPath)) Then dicKeepFolder.Add LCase(sPath)
sPath = LCase(oFso.GetFile(sPath).ParentFolder) & ""
If NOT dicKeepFolder.Exists(sPath) Then AddKeepFolder sPath
End If
'Folder keypath
If oFso.FolderExists(sPath) Then AddKeepFolder sPath
End If 'Is Registry
End If 'sPath > 4
Next 'CompClient
End If 'fAffectedComponent
End If 'fRemoveComponent
Err.Clear
Next 'ComponentID
On Error Goto 0

Log " Done" & vbCrLf
If dicFLError.Count > 0 Then LogOnly Join(dicFLError.Keys,vbCrLf)
If Not oFolderDic.Count = 0 Then arrDeleteFolders = oFolderDic.Keys Else Set arrDeleteFolders = Nothing
If Not oDic.Count = 0 Then arrDeleteFiles = oDic.Keys Else Set arrDeleteFiles = Nothing
End Sub 'ScanComponents
'=======================================================================================================


'Try to remove the products by calling setup.exe
Sub SetupExeRemoval
Dim OseService, Service, TextStream
Dim iSetupCnt, RetVal
Dim Sku, sConfigFile, sUninstallCmd, sCatalyst, sDll, sDisplayLevel, sNoCancel

iSetupCnt = 0
If Not dicRemoveSku.Count > 0 Then
Log " Nothing to remove for Setup.exe"
Exit Sub
End If

'Ensure that the OSE service is *installed, *not disabled, *running under System context.
'If validation fails exit out of this sub.
Set OseService = oWmiLocal.Execquery("Select * From Win32_Service Where Name like 'ose%'")
If OseService.Count = 0 Then Exit Sub
For Each Service in OseService
If (Service.StartMode = "Disabled") AND (Not Service.ChangeStartMode("Manual")=0) Then Exit Sub
If (Not Service.StartName = "LocalSystem") AND (Service.Change( , , , , , , "LocalSystem", "")) Then Exit Sub
Next 'Service

For Each Sku in dicRemoveSku.Keys
If Sku="CLICK2RUN" Then
'Already done
Else
'Create an "unattended" config.xml file for uninstall
If fQuiet AND NOT fBasic Then sDisplayLevel = "None" Else sDisplayLevel="Basic"
If fNoCancel Then sNoCancel="Yes" Else sNoCancel="No"
Set TextStream = oFso.OpenTextFile(sScrubDir & "config.xml",FOR_WRITING,True,True)
TextStream.Writeline "<Configuration Product=""" & Sku & """>"
TextStream.Writeline "<Display Level=""" & sDisplayLevel & """ CompletionNotice=""No"" SuppressModal=""Yes"" NoCancel=""" & sNoCancel & """ AcceptEula=""Yes"" />"
TextStream.Writeline "<Logging Type=""Verbose"" Path=""" & sLogDir & """ Template=""Microsoft Office " & Sku & " Setup(*).txt"" />"
TextStream.Writeline "<Setting Id=""MSIRESTARTMANAGERCONTROL"" Value=""Disable"" />"
TextStream.Writeline "<Setting Id=""SETUP_REBOOT"" Value=""Never"" />"
TextStream.Writeline "</Configuration>"
TextStream.Close
Set TextStream = Nothing

'Ensure path to setup.exe is valid to prevent errors
sDll = ""
If RegReadValue(HKLM,REG_ARP & OREGREF & Sku,"UninstallString",sCatalyst,"REG_SZ") Then
If InStr(LCase(sCatalyst),"/dll")>0 Then sDll = Right(sCatalyst,Len(sCatalyst)-InStr(LCase(sCatalyst),"/dll")+2)
If InStr(sCatalyst,"/")>0 Then sCatalyst = Left(sCatalyst,InStr(sCatalyst,"/")-1)
sCatalyst = Trim(Replace(sCatalyst,Chr(34),""))
If NOT oFso.FileExists(sCatalyst) Then
sCatalyst = sCommonProgramFiles & "" & OREF & "Office Setup Controllersetup.exe"
If NOT oFso.FileExists(sCatalyst) AND f64 Then
sCatalyst = sCommonProgramFilesX86 & "" & OREF & "Office Setup Controllersetup.exe"
End If
End If
If oFso.FileExists(sCatalyst) Then
sUninstallCmd = Chr(34) & sCatalyst & Chr(34) & " /uninstall " & Sku & " /config " & Chr(34) & sScrubDir & "config.xml" & Chr(34) & sDll 
iSetupCnt = iSetupCnt + 1
Log " - Calling Setup.exe to remove " & Sku '& vbCrLf & sUninstallCmd 
If Not fDetectOnly Then 
On Error Resume Next
' end other instances of setup
EndCurrentInstalls
' call uninstall
RetVal = oWShell.Run(sUninstallCmd,0,True) : CheckError "SetupExeRemoval"
Log " - Setup.exe returned: " & SetupRetVal(Retval) & " (" & RetVal & ")" & vbCrLf
fRebootRequired = fRebootRequired OR (RetVal = "3010")
On Error Goto 0
Else
Log " -> Removal suppressed in preview mode."
End If
Else
Log " Error: Office setup.exe appears to be missing"
End If 'RetVal = 0) AND oFso.FileExists
End If 'RegReadValue
End If 
Next 'Sku
If iSetupCnt = 0 Then Log " Nothing to remove for setup."
End Sub 'SetupExeRemoval
'=======================================================================================================

'Invoke msiexec to remove individual .MSI packages
Sub MsiexecRemoval

Dim Product
Dim i
Dim sCmd, sReturn, sMsiProp
Dim fRegWipe

fRegWipe = False

Select Case OVERSIONMAJOR
Case "11"
sMsiProp = " REBOOT=ReallySuppress NOLOCALCACHEROLLBACK=1"
Case "12"
fRegWipe = True
sMsiProp = " REBOOT=ReallySuppress NOREMOVESPAWN=True"
Case "14"
fRegWipe = True
sMsiProp = " REBOOT=ReallySuppress NOREMOVESPAWN=True"
Case "15"
fRegWipe = True
sMsiProp = " REBOOT=ReallySuppress NOREMOVESPAWN=True"
Case Else
End Select

'Clear up ARP first to avoid possible custom action dependencies
If fRegWipe Then RegWipeARP

'Check MSI registered products
'Office System does only support per machine installation so it's sufficient to use Installer.Products
i = 0
'sMsiProp = " MSIRESTARTMANAGERCONTROL=Disable" & sMsiProp
For Each Product in oMsi.Products
If InScope(Product) Then
If fRemoveAll OR CheckDelete(Product) Then
i = i + 1 
Log " Calling msiexec.exe to remove " & Product
sCmd = "msiexec.exe /x" & Product & sMsiProp
If fQuiet AND NOT fBasic Then 
sCmd = sCmd & " /q"
Else
sCmd = sCmd & " /qb-"
End If
sCmd = sCmd & " /l*v+ "&chr(34)&sLogDir&"Uninstall_"&Product&".log"&chr(34)
If NOT fDetectOnly Then 
' end other instances of setup
EndCurrentInstalls

'Execute the uninstall
LogOnly " - Calling msiexec with '"&sCmd&"'"
sReturn = oWShell.Run(sCmd, 0, True)
Log " - msiexec returned: " & SetupRetVal(sReturn) & " (" & sReturn & ")" & vbCrLf
fRebootRequired = fRebootRequired OR (sReturn = "3010") OR (sReturn = "1618")
Else
Log "  -> Removal suppressed in preview mode."
LogOnly "  -> Command: "&sCmd
End If
End If 'CheckDelete
End If 'InScope
Next 'Product
If i = 0 Then Log " Nothing to remove for msiexec"
End Sub 'MsiexecRemoval
'=======================================================================================================

'Remove the OSE (Office Source Engine) service
Sub RemoveOSE
On Error Resume Next
Log vbCrLf & "OSE CleanUp"
DeleteService "ose"
'Delete the folder
DeleteFolder sCommonProgramFiles & "Microsoft SharedSource Engine"
'Delete the registration
RegDeleteKey HKLM,"SYSTEMCurrentControlSetServicesose"
End Sub 'RemoveOSE
'=======================================================================================================


'File cleanup operations for the Local Installation Source (MSOCache)
Sub WipeLIS
Const LISROOT = "MSOCacheAll Users"
Dim LogicalDisks, Disk, Folder, SubFolder, MseFolder, File, Files
Dim arrSubFolders
Dim sFolder
Dim fRemoveFolder

Log vbCrLf & "LIS CleanUp"
'Search all hard disks
Set LogicalDisks = oWmiLocal.ExecQuery("Select * From Win32_LogicalDisk WHERE DriveType=3")
For Each Disk in LogicalDisks
If oFso.FolderExists(Disk.DeviceID & "" & LISROOT) Then
Set Folder = oFso.GetFolder(Disk.DeviceID & "" & LISROOT)
For Each Subfolder in Folder.Subfolders
If Len(Subfolder) > 37 Then
If fRemoveAll Then 
If  (Mid(Subfolder.Name,27,PRODLEN) = OFFICEID AND Mid(SubFolder.Name,4,2)=OVERSIONMAJOR) OR _
LCase(Right(Subfolder.Name,7)) = OVERSIONMAJOR &".data" Then DeleteFolder Subfolder.Path
Else
If  (Mid(Subfolder.Name,27,PRODLEN) = OFFICEID AND Mid(SubFolder.Name,4,2)=OVERSIONMAJOR) AND _
CheckDelete(UCase(Left(Subfolder.Name,38))) AND _
UCase(Right(Subfolder,1))= UCase(Left(Disk.DeviceID,1))Then DeleteFolder Subfolder.Path
End If
End If 'Len > 37
Next 'Subfolder
If (Folder.Subfolders.Count = 0) AND (Folder.Files.Count = 0) Then 
sFolder = Folder.Path
Set Folder = Nothing
SmartDeleteFolder sFolder
End If
End If 'oFso.FolderExists
Next 'Disk

'MSECache
If EnumFolders(sProgramFiles,arrSubFolders) Then
For Each SubFolder in arrSubFolders
If UCase(Right(SubFolder,9))="MSECACHE" Then
ReDim arrMseFolders(-1)
Set Folder = oFso.GetFolder(SubFolder)
GetMseFolderStructure Folder
For Each MseFolder in arrMseFolders
If oFso.FolderExists(MseFolder) Then
fRemoveFolder = False
Set Folder = oFso.GetFolder(MseFolder)
Set Files = Folder.Files
For Each File in Files
If (LCase(Right(File.Name,4))=".msi") Then
If CheckDelete(ProductCode(File.Path)) Then 
fRemoveFolder = True
Exit For
End If 'CheckDelete
End If
Next 'File
Set Files = Nothing
Set Folder = Nothing
If fRemoveFolder Then SmartDeleteFolder MseFolder
End If 'oFso.FolderExists(MseFolder)
Next 'MseFolder
End If
Next 'SubFolder
End If 'oFso.FolderExists
End Sub 'WipeLis
'=======================================================================================================

'Wipe files and folders as documented in KB 928218
Sub FileWipeAll
Dim sFolder
Dim Folder, Subfolder

If fForce OR fQuiet Then CloseOfficeApps

'Handle other services.
Select Case OVERSIONMAJOR
Case "11"
Case "12"
Case "14"
DeleteService "odserv"
DeleteService "Microsoft Office Groove Audit Service"
DeleteService "Microsoft SharePoint Workspace Audit Service"
Case "15"
Case Else
End Select

'User specific files
If NOT fKeepUser Then
'Delete files that should be backed up before deleting them
CopyAndDeleteFile sAppdata & "MicrosoftTemplatesNormal.dotm"
CopyAndDeleteFile sAppdata & "MicrosoftTemplatesNormalemail.dotm"
sFolder = sAppdata & "microsoftdocument building blocks"
If oFso.FolderExists(sFolder) Then 
Set Folder = oFso.GetFolder(sFolder)
For Each Subfolder In Folder.Subfolders
If oFso.FileExists(Subfolder & "blocks.dotx") Then CopyAndDeleteFile Subfolder & "blocks.dotx"
Next 'Subfolder
Set Folder = Nothing
End If 'oFso.FolderExists(sFolder)
End If  

'Run the individual filewipe from component detection first
FileWipeIndividual

'Take care of the rest
DeleteFolder sOInstallRoot
DeleteFolder sCommonProgramFiles & "Microsoft Shared" & OREF
DeleteFile sAllUsersProfile & "Application DataMicrosoftOfficeDataopa"&OVERSIONMAJOR&".dat"
DeleteFile sAllUsersProfile & "Application DataMicrosoftOfficeDataopa"&OVERSIONMAJOR&".bak"
DeleteFile sAllUsersProfile & "MicrosoftOfficeDataopa"&OVERSIONMAJOR&".dat"
DeleteFile sAllUsersProfile & "MicrosoftOfficeDataopa"&OVERSIONMAJOR&".bak"
If (fRemoveOspp OR fForce) AND CInt(OVERSIONMAJOR)>12 Then
DeleteService "osppsvc"
DeleteFolder sCommonProgramFiles & "Microsoft SharedOfficeSoftwareProtectionPlatform"
DeleteFolder sAllUsersProfile & "MicrosoftOfficeSoftwareProtectionPlatform"
End If
Select Case OVERSIONMAJOR
Case "12"
Case "14"
DeleteFile oWShell.SpecialFolders("AllUsersStartup")&"OfficeSAS.lnk"
DeleteFile oWShell.SpecialFolders("Startup")&"OneNote 2010 Screen Clipper and Launcher.lnk"
Case "15"
Case Else
End Select
End Sub 'FileWipeAll
'=======================================================================================================

'Wipe individual files & folders related to SKU's that are no longer installed
Sub FileWipeIndividual
Dim LogicalDisks, Disk,sc
Dim File, Files, XmlFile, scFiles, oFile, Folder, SubFolder, Processes, Process, item
Dim sFile, sFolder, sPath, sConfigName, sContents, sProductCode, sLocalDrives,sScQuery
Dim sValue, sScRoots
Dim arrSubfolders, arrShortCutRoots
Dim fKeepFolder, fDeleteSC
Dim iRet,iCnt,iPos

Log vbCrLf & "File CleanUp"
If IsArray(arrDeleteFiles) Then
If fForce OR fQuiet Then
Log " Doing Action: StopOSE"
iRet = StopService("ose")
Set Processes = oWmiLocal.ExecQuery("Select * From Win32_Process Where Name like 'ose%.exe'")
For Each Process in Processes
LogOnly " - Running process : " & Process.Name
Log " -> Ending process: " & Process.Name
iRet = Process.Terminate()
Next 'Process
LogOnly " End Action: StopOSE"
CloseOfficeApps
End If
'Wipe individual files detected earlier
LogOnly " Removing left behind files"
For Each sFile in arrDeleteFiles
If oFso.FileExists(sFile) Then DeleteFile sFile
Next 'File
End If 'IsArray

'Wipe Catalyst in commonfiles
sFolder = sCommonProgramFiles & "microsoft shared"&OREF&"Office Setup Controller"
If EnumFolderNames(sFolder,arrSubFolders) Then
For Each SubFolder in arrSubFolders
sPath = sFolder & SubFolder
If InStr(SubFolder,".")>0 Then sConfigName = UCase(Left(SubFolder,InStr(SubFolder,".")-1))Else sConfigName = UCase(Subfolder)
If GetFolderPath(sPath) Then
Set Folder = oFso.GetFolder(sPath)
Set Files = Folder.Files
fKeepFolder = False
For Each File In Files
If Len(File.Name)>3 Then
If (LCase(Right(File.Name,4))=".xml") Then
If Len(File.Name) >= Len(sConfigName) Then
If (UCase(Left(File.Name,Len(sConfigName)))=sConfigName) Then
Set XmlFile = oFso.OpenTextFile(File,1)
sContents = XmlFile.ReadAll
Set XmlFile = Nothing
sProductCode = ""
On Error Resume Next
sProductCode = Mid(sContents,InStr(sContents,"ProductCode=")+Len("ProductCode=")+1,38)
On Error Goto 0
If Len(sProductCode) = 38 Then
If CheckDelete(sProductCode) Then DeleteFile File.Path Else fKeepFolder = True
End If
End If 'sConfigName
End If 'Len >=
End If '.xml
End If 'Len(File.Name)>3
Next 'File
Set Files = Nothing
Set Folder = Nothing
If Not fKeepFolder Then DeleteFolder sPath
End If 'GetFolderPath
Next 'SubFolder
End If 'EnumFolderNames

'Wipe Shortcuts
If NOT fSkipSD Then
On Error Resume Next
Log " Searching for shortcuts"
CleanShortcuts sAllUsersProfile, True, False
CleanShortcuts sProfilesDirectory, True, False
On Error Goto 0
End If 'NOT SkipSD
Err.Clear

End Sub 'FileWipeIndividual
'=======================================================================================================

'-------------------------------------------------------------------------------
'   CleanShortcuts
'
'   Recursively search all profile folders for Office shortcuts in scope 
'-------------------------------------------------------------------------------
Sub CleanShortcuts (sFolder, fDelete, fUnPin)
Dim oFolder, fld, file, sc, item
Dim fDeleteSC

Set oFolder = oFso.GetFolder(sFolder)
' exclude system protected link folders
If CBool(oFolder.Attributes AND 1024) Then Exit Sub

On Error Resume Next
For Each fld In oFolder.SubFolders
If Err <> 0 Then
    CheckError "CleanShortcuts: " & vbTab & sFolder
Else
CleanShortcuts fld.Path, fDelete, fUnPin
End If
Next
For Each file In oFolder.Files
If LCase(Right(file.Path, 4)) = ".lnk" Then
set sc = oWShell.CreateShortcut(file.Path)
'Compare if the shortcut target is in the list of executables that will be removed
If Len(sc.TargetPath) > 0 Then
For Each item in dicApps.Items
If LCase(sc.TargetPath) = item Then
fDeleteSC = True
Exit For
End If
Next 'item
End If
'Handle Windows Installer shortcuts
If InStr(sc.TargetPath,"{") > 0 Then
If Len(sc.TargetPath) >= InStr(sc.TargetPath,"{") + 37 Then
If CheckDelete(Mid(sc.TargetPath, InStr(sc.TargetPath,"{"), 38)) Then fDeleteSC = True
End If
End If
If fDeleteSC Then 
If Not IsArray(arrDeleteFolders) Then ReDim arrDeleteFolders(0)
sFolder = file.Drive & file.Path
If Not arrDeleteFolders(UBound(arrDeleteFolders)) = sFolder Then
ReDim Preserve arrDeleteFolders(UBound(arrDeleteFolders) + 1)
arrDeleteFolders(UBound(arrDeleteFolders)) = sFolder
End If
If fUnPin Then UnPin file
If fDelete Then DeleteFile file.Path
End If 'fDeleteSC
End If
Next
On Error Goto 0
End Sub 'CleanShortcuts

'-------------------------------------------------------------------------------
'   UnPin
'
'   Unpins a shortcut from the taskbar or start menu 
'-------------------------------------------------------------------------------
Sub UnPin(file)
Dim fldItem, verb

On Error Resume Next
Set fldItem = oShellApp.NameSpace(file.ParentFolder.Path).ParseName(file.Name)
For Each verb in fldItem.Verbs
Select Case Replace(verb, "&", "")
Case "Unpin from Taskbar", "Von Taskleiste lösen", "Détacher du barre des tâches", "Détacher de la barre des tâches", "Desanclar de la barra de tareas", "Ta bort från Aktivitetsfältet", "??? ????????(K)", "?? ????? ??(K)", "????????? ?? ?????? ?????"
verb.DoIt
Case "Unpin from Start Menu", "Vom Startmenü lösen", "Détacher du menu Démarrer", "Détacher de la menu Démarrer"
If iVersionNT = 601 Then verb.DoIt
End Select
Next
On Error Goto 0
End Sub


'=======================================================================================================

Sub DelScrubTmp

On Error Resume Next
If oFso.FolderExists(sScrubDir & "ScrubTmp") Then oFso.DeleteFolder sScrubDir & "ScrubTmp",True

End Sub 'DelScrubTmp
'=======================================================================================================

'Ensure there are no unexpected .msi files in the scrub folder
Sub DeleteMsiScrubCache
Dim Folder, File, Files

Log vbCrLf & "ScrubCache CleanUp"
Set Folder = oFso.GetFolder(sScrubDir) : CheckError "DeleteMsiScrubCache"
Set Files = Folder.Files
For Each File in Files
CheckError "DeleteMsiScrubCache"
If LCase(Right(File.Name,4))=".msi" Then
CheckError "DeleteMsiScrubCache"
DeleteFile File.Path : CheckError "DeleteMsiScrubCache"
End If
Next 'File
End Sub 'DeleteMsiScrubCache
'=======================================================================================================

Sub MsiClearOrphanedFiles
Const USERSIDEVERYONE = "s-1-1-0"
Const MSIINSTALLCONTEXT_ALL = 7
Const MSIPATCHSTATE_ALL = 15

'Error handling inlined
On Error Resume Next

Dim Patch, AllPatches, Product, AllProducts
Dim File, Files, Folder
Dim sFName, sLocalMsp, sLocalMsi, sPatchList, sMsiList

Set Folder = oFso.GetFolder(sWinDir & "Installer")
Set Files = Folder.Files

Log vbCrLf & "Windows Installer cache CleanUp"
'Get a complete list of patches
Err.Clear
Set AllPatches = oMsi.PatchesEx("",USERSIDEVERYONE,MSIINSTALLCONTEXT_ALL,MSIPATCHSTATE_ALL)
If Err <> 0 Then
CheckError "MsiClearOrphanedFiles (msp)"
Else
'Fill a comma separated stringlist with all .msp patchfiles
For Each Patch in AllPatches
sLocalMsp = "" : sLocalMsp = LCase(Patch.Patchproperty("LocalPackage")) : CheckError "MsiClearOrphanedFiles (msp)"
sPatchList = sPatchList & sLocalMsp & ","
Next 'Patch

'Delete all non referenced .msp files from %windir%installer
For Each File in Files
sFName = "" : sFName = LCase(File.Path)
If LCase(Right(sFName,4)) = ".msp" Then
If Not InStr(sPatchList,sFName) > 0 Then
'While this is an orphaned file keep the scope of Office only
If InStr(UCase(MspTargets(File.Path)),OFFICEID)>0 Then DeleteFile File.Path
End If
End If 'LCase(Right(sFName,4))
Next 'File
End If 'Err=0

'Get a complete list products
Err.Clear
Set AllProducts = oMsi.ProductsEx("",USERSIDEVERYONE,MSIINSTALLCONTEXT_ALL)
If Err <> 0 Then
CheckError "MsiClearOrphanedFiles (msi)"
Else
'Fill a comma separated stringlist with all .msi files
For Each Product in AllProducts
sLocalMsi = "" : sLocalMsi = LCase(Product.InstallProperty("LocalPackage")) : CheckError "MsiClearOrphanedFiles (msi)"
sMsiList = sMsiList & sLocalMsi & ","
Next 'Product

'Delete all non referenced .msi files from %windir%installer
For Each File in Files
sFName = "" : sFName = LCase(File.Path)
If LCase(Right(sFName,4)) = ".msi" Then
If Not InStr(sMsiList,sFName) > 0 Then
'While this is an orphaned file keep the scope of Office only
If UCase(Right(ProductCode(File.Path),PRODLEN))=OFFICEID Then DeleteFile File.Path
End If
End If 'LCase(Right(sFName,4)) = ".msi"
Next 'File
End If 'Err=0

End Sub 'MsiClearOrphanedFiles
'=======================================================================================================

Sub RegWipe
Dim Item, Name, Sku, key
Dim hDefKey, sSubKeyName, sCurKey, value, sValue, sGuid
Dim fkeep, fSystemComponent0, fPackages, fDisplayVersion
Dim arrKeys, arrNames, arrTypes, arrMultiSzValues, arrMultiSzNewValues
Dim arrTestNames,arrTestTypes
Dim i, iLoopCnt, iPos
Dim fDelReg

Log vbCrLf & "Registry CleanUp"
'Wipe registry data

'User Profile settings
Log " - User Policies"
RegDeleteKey HKCU,"SoftwarePoliciesMicrosoftOffice" & OVERSION & ""
If NOT fKeepUser Then
RegDeleteKey HKCU,"SoftwareMicrosoftOffice" & OVERSION & ""
Log " - User Settings"
End If 'fKeepUser

'Computer specific settings
If fRemoveAll Then
Log " - Machine Settings"
RegDeleteKey HKLM,"SOFTWAREMicrosoftOffice" & OVERSION & ""
If fRemoveOse OR fForce Then
RegDeleteKey HKLM,"SOFTWAREMicrosoftOffice Test"
RegDeleteValue HKLM,"SOFTWAREMicrosoftOfficeCommon","LastAccessInstall", False
RegDeleteValue HKLM,"SOFTWAREMicrosoftOfficeCommon","MID", False
RegDeleteKey HKLM,"SOFTWAREMicrosoftOfficeExcelAddinsMicrosoft.PerformancePoint.Planning.Client.Excel"
RegDeleteValue HKLM,"SOFTWAREMicrosoftOfficeInfoPathConvertersImportInfoPath.DesignerExcelImportVersions",OVERSION, False
RegDeleteValue HKLM,"SOFTWAREMicrosoftOfficeInfoPathConvertersImportInfoPath.DesignerWordImportVersions",OVERSION, False
RegDeleteKey HKLM,"SOFTWAREMicrosoftOfficeOutlook"
RegDeleteKey HKLM,"SOFTWAREMicrosoftShared ToolsText ConvertersExportMEWord12"
RegDeleteKey HKLM,"SOFTWAREMicrosoftShared ToolsText ConvertersExportWord12"
RegDeleteKey HKLM,"SOFTWAREMicrosoftShared ToolsText ConvertersExportWord97"
RegDeleteKey HKLM,"SOFTWAREMicrosoftShared ToolsText ConvertersImportMEWord12"
RegDeleteKey HKLM,"SOFTWAREMicrosoftShared ToolsText ConvertersImportWord12"
RegDeleteKey HKLM,"SOFTWAREMicrosoftShared ToolsText ConvertersImportWord97"
RegDeleteValue HKLM,"SOFTWAREMicrosoftWindowsCurrentVersionRun","GrooveMonitor", False
RegDeleteValue HKLM,"SOFTWAREMicrosoftWindowsCurrentVersionRun","LobiServer", False
RegDeleteValue HKLM,"SOFTWAREMicrosoftWindowsCurrentVersionRun","BCSSync", False
RegDeleteKey HKLM,"SYSTEMCurrentControlSetServicesOutlook"
End If
RegDeleteValue HKLM,"SOFTWAREMicrosoftOfficeCommonOffDiagLocation",OVERSIONMAJOR, False
RegDeleteKey HKLM,"SOFTWAREMicrosoftWindows NTCurrentVersionTerminal ServerInstallSoftwareMicrosoftOffice" & OVERSION & ""
RegDeleteValue HKLM,"SOFTWAREMicrosoftOfficeCommonOffDiagLocation",OVERSIONMAJOR, False
RegDeleteKey HKLM,"SOFTWAREMicrosoftOfficeCustomizeWizard" & OVERSION & ""
RegDeleteKey HKLM,"SOFTWAREMicrosoftWindows NTCurrentVersionTerminal ServerInstallSOFTWAREMicrosoftOfficeCustomizeWizard" & OVERSION & ""

Select Case OVERSIONMAJOR
Case "11"
'Jet_Replication
sValue = ""
If RegReadValue(HKCR,"CLSID{CC2C83A6-9BE4-11D0-98E7-00C04FC2CAF5}InprocServer32","SystemDB",sValue,"REG_SZ") Then
If Len(sValue) > Len(sOInstallRoot) Then
If LCase(Left(sValue,Len(sOInstallRoot))) = LCase(sOInstallRoot) Then RegDeleteKey HKCR,"CLSID{CC2C83A6-9BE4-11D0-98E7-00C04FC2CAF5}InprocServer32"
End If
End If
Case "12"
Case "14"
RegDeleteKey HKLM,"SOFTWAREMicrosoftOfficeSoftwareProtectionPlatform"
RegDeleteKey HKLM,"SOFTWAREMicrosoftOfficeSoftwareProtectionPlatform_Test"
RegDeleteKey HKLM,"SOFTWAREMicrosoftOfficeCommonActiveX Compatibility{00024512-0000-0000-C000-000000000046}"
RegDeleteValue HKLM,"SOFTWAREMicrosoftOfficeOneNoteAdapters","{456B0D0E-49DD-4C95-8DB6-175F54DE69A3}", False
RegDeleteValue HKLM,"SOFTWAREMicrosoftWindowsCurrentVersionShell ExtensionsApproved","{42042206-2D85-11D3-8CFF-005004838597}", False
RegDeleteValue HKLM,"SOFTWAREMicrosoftWindowsCurrentVersionShell ExtensionsApproved","{993BE281-6695-4BA5-8A2A-7AACBFAAB69E}", False
RegDeleteValue HKLM,"SOFTWAREMicrosoftWindowsCurrentVersionShell ExtensionsApproved","{0006F045-0000-0000-C000-000000000046}", False
RegDeleteValue HKLM,"SOFTWAREMicrosoftWindowsCurrentVersionShell ExtensionsApproved","{C41662BB-1FA0-4CE0-8DC5-9B7F8279FF97}", False
RegDeleteValue HKLM,"SOFTWAREMicrosoftWindowsCurrentVersionShell ExtensionsApproved","{7CCA70DB-DE7A-4FB7-9B2B-52E2335A3B5A}", False
RegDeleteValue HKLM,"SOFTWAREMicrosoftWindowsCurrentVersionShell ExtensionsApproved","{506F4668-F13E-4AA1-BB04-B43203AB3CC0}", False
RegDeleteValue HKLM,"SOFTWAREMicrosoftWindowsCurrentVersionShell ExtensionsApproved","{D66DC78C-4F61-447F-942B-3FB6980118CF}", False
RegDeleteKey HKLM,"SOFTWAREMicrosoftWindowsCurrentVersionExplorerBrowser Helper Objects{B4F3A835-0E21-4959-BA22-42B3008E02FF}"
'Groove Extensions 
RegDeleteValue HKLM,"SOFTWAREMicrosoftWindowsCurrentVersionExplorerShellExecuteHooks","{B5A7F190-DDA6-4420-B3BA-52453494E6CD}", False
RegDeleteValue HKLM,"SOFTWAREMicrosoftWindowsCurrentVersionShell ExtensionsApproved","{99FD978C-D287-4F50-827F-B2C658EDA8E7}", False
RegDeleteValue HKLM,"SOFTWAREMicrosoftWindowsCurrentVersionShell ExtensionsApproved","{AB5C5600-7E6E-4B06-9197-9ECEF74D31CC}", False
RegDeleteValue HKLM,"SOFTWAREMicrosoftWindowsCurrentVersionShell ExtensionsApproved","{920E6DB1-9907-4370-B3A0-BAFC03D81399}", False
RegDeleteValue HKLM,"SOFTWAREMicrosoftWindowsCurrentVersionShell ExtensionsApproved","{16F3DD56-1AF5-4347-846D-7C10C4192619}", False
RegDeleteValue HKLM,"SOFTWAREMicrosoftWindowsCurrentVersionShell ExtensionsApproved","{2916C86E-86A6-43FE-8112-43ABE6BF8DCC}", False
RegDeleteValue HKLM,"SOFTWAREMicrosoftWindowsCurrentVersionShell ExtensionsApproved","{72853161-30C5-4D22-B7F9-0BBC1D38A37E}", False
RegDeleteValue HKLM,"SOFTWAREMicrosoftWindowsCurrentVersionShell ExtensionsApproved","{6C467336-8281-4E60-8204-430CED96822D}", False
RegDeleteValue HKLM,"SOFTWAREMicrosoftWindowsCurrentVersionShell ExtensionsApproved","{2A541AE1-5BF6-4665-A8A3-CFA9672E4291}", False
RegDeleteValue HKLM,"SOFTWAREMicrosoftWindowsCurrentVersionShell ExtensionsApproved","{B5A7F190-DDA6-4420-B3BA-52453494E6CD}", False
RegDeleteValue HKLM,"SOFTWAREMicrosoftWindowsCurrentVersionShell ExtensionsApproved","{A449600E-1DC6-4232-B948-9BD794D62056}", False
RegDeleteValue HKLM,"SOFTWAREMicrosoftWindowsCurrentVersionShell ExtensionsApproved","{3D60EDA7-9AB4-4DA8-864C-D9B5F2E7281D}", False
RegDeleteValue HKLM,"SOFTWAREMicrosoftWindowsCurrentVersionShell ExtensionsApproved","{387E725D-DC16-4D76-B310-2C93ED4752A0}", False
RegDeleteKey HKLM,"SOFTWAREClasses*shellexContextMenuHandlersXXX Groove GFS Context Menu Handler XXX"
RegDeleteKey HKLM,"SOFTWAREClassesAllFilesystemObjectsshellexContextMenuHandlersXXX Groove GFS Context Menu Handler XXX"
RegDeleteKey HKLM,"SOFTWAREClassesDirectoryshellexContextMenuHandlersXXX Groove GFS Context Menu Handler XXX"
RegDeleteKey HKLM,"SOFTWAREClassesFolderShellExContextMenuHandlersXXX Groove GFS Context Menu Handler XXX"
RegDeleteKey HKLM,"SOFTWAREClassesDirectoryBackgroundshellexContextMenuHandlersXXX Groove GFS Context Menu Handler XXX"
RegDeleteKey HKLM,"SOFTWAREMicrosoftWindowsCurrentVersionExplorerShellIconOverlayIdentifiersGroove Explorer Icon Overlay 1 (GFS Unread Stub)"
RegDeleteKey HKLM,"SOFTWAREMicrosoftWindowsCurrentVersionExplorerShellIconOverlayIdentifiersGroove Explorer Icon Overlay 2 (GFS Stub)"
RegDeleteKey HKLM,"SOFTWAREMicrosoftWindowsCurrentVersionExplorerShellIconOverlayIdentifiersGroove Explorer Icon Overlay 2.5 (GFS Unread Folder)"
RegDeleteKey HKLM,"SOFTWAREMicrosoftWindowsCurrentVersionExplorerShellIconOverlayIdentifiersGroove Explorer Icon Overlay 3 (GFS Folder)"
RegDeleteKey HKLM,"SOFTWAREMicrosoftWindowsCurrentVersionExplorerShellIconOverlayIdentifiersGroove Explorer Icon Overlay 4 (GFS Unread Mark)"
RegDeleteKey HKLM,"SOFTWAREMicrosoftWindowsCurrentVersionExplorerBrowser Helper Objects{72853161-30C5-4D22-B7F9-0BBC1D38A37E}"

Case 15

Case Else
End Select

'Win32Assemblies
Log " - Win32Assemblies"
If RegEnumKey(HKCR,"InstallerWin32Assemblies",arrKeys) Then
For Each Item in arrKeys
If InStr(UCase(Item),OREF)>0 Then RegDeleteKey HKCR,"InstallerWin32Assemblies"&Item & ""
Next 'Item
End If 'RegEnumKey
'Groove blocks reinstall if it locates groove.exe over this key
If RegKeyExists(HKCR,"GrooveFileShellOpenCommand") Then
sValue = ""
RegReadValue HKCR,"GrooveFileShellOpenCommand","",sValue,"REG_SZ"
If InStr(sValue,""&OREF&"")>0 Then RegDeleteKey HKCR,"GrooveFile"
End If 'RegKeyExists
End If 'fRemoveAll

Select Case OVERSIONMAJOR
Case "11"
For iLoopCnt = 1 to 3
Select Case iLoopCnt
Case 1
'CIW - HKCU
sSubKeyName = "SoftwareMicrosoftOfficeCustomizeWizard" & OVERSION & "RegKeyPaths"
hDefKey = HKCU
Case 2 
'CIW - HKLM
sSubKeyName = "SOFTWAREMicrosoftOfficeCustomizeWizard" & OVERSION & "RegKeyPaths"
hDefKey = HKLM
Case 3
'Add/Remove Programs
sSubKeyName = REG_ARP
hDefKey = HKLM
End Select

If RegEnumKey(hDefKey,sSubKeyName,arrKeys) Then
For Each Item in arrKeys
'OFFICEID id
If Len(Item)>37 Then
sGuid = UCase(Left(Item,38))
If Right(sGuid,PRODLEN)=OFFICEID Then
If CheckDelete(sGuid) Then 
RegDeleteKey hDefKey, sSubKeyName & Item & ""
End If
End If 'Right(Item,PRODLEN)=OFFICEID
End If 'Len(Item)>37
Next 'Item
If iLoopCnt < 3 Then
If RegEnumValues(hDefKey,sSubKeyName,arrNames,arrTypes) Then
i = 0
For Each Name in arrNames
If RegReadValue(hDefKey,sSubKeyName,Name,sValue,arrTypes(i)) Then
If sValue = sGuid Then RegDeleteValue hDefKey,sSubKeyName,Name, False
End If
i = i + 1
Next
End If
End If
End If
If NOT RegEnumKey(hDefKey,sSubKeyName,arrKeys) Then RegDeleteKey hDefKey,"SoftwareMicrosoftOfficeCustomizeWizard11.0"
If NOT RegEnumKey(hDefKey,"SoftwareMicrosoftOfficeCustomizeWizard11.0",arrKeys) Then RegDeleteKey hDefKey,"SoftwareMicrosoftOfficeCustomizeWizard"
Next 'iLoopCnt
Case "12"
'Add/Remove Programs
RegWipeARP 
Case "14"
'Add/Remove Programs
RegWipeARP 
Case Else
End Select

'UpgradeCodes, WI config, WI global config
For iLoopCnt = 1 to 5
Select Case iLoopCnt
Case 1
Log " - HKLM UpgradeCodes"
sSubKeyName = "SOFTWAREMicrosoftWindowsCurrentVersionInstallerUpgradeCodes"
hDefKey = HKLM
Case 2 
Log " - HKCR UpgradeCodes"
sSubKeyName = "InstallerUpgradeCodes"
hDefKey = HKCR
Case 3
Log " - HKLM Products"
sSubKeyName = "SOFTWAREMicrosoftWindowsCurrentVersionInstallerUserDataS-1-5-18Products"
hDefKey = HKLM
Case 4 
Log " - HKCR Features"
sSubKeyName = "InstallerFeatures"
hDefKey = HKCR
Case 5 
Log " - HKCR Products"
sSubKeyName = "InstallerProducts"
hDefKey = HKCR
Case Else
sSubKeyName = ""
hDefKey = ""
End Select
If RegEnumKey(hDefKey,sSubKeyName,arrKeys) Then
For Each Item in arrKeys
'Ensure we have the expected length for a compressed GUID
If Len(Item)=32 Then
'Expand the GUID
sGuid = GetExpandedGuid(Item) 
'Check if it's an Office key
If InScope(sGuid) Then
If fRemoveAll Then
RegDeleteKey hDefKey,sSubKeyName & Item & ""
Else
If iLoopCnt < 3 Then
'Enum all entries
RegEnumValues hDefKey,sSubKeyName & Item,arrNames,arrTypes
If IsArray(arrNames) Then
'Delete entries within removal scope
For Each Name in arrNames
If Len(Name)=32 Then
sGuid = GetExpandedGuid(Name)
If CheckDelete(sGuid) Then RegDeleteValue hDefKey, sSubKeyName & Item & "", Name, True
Else
'Invalid data -> delete the value
RegDeleteValue hDefKey, sSubKeyName & Item & "", Name, True
End If
Next 'Name
End If 'IsArray(arrNames)
'If all entries were removed - delete the key
RegEnumValues hDefKey,sSubKeyName & Item,arrNames,arrTypes
If Not IsArray(arrNames) Then RegDeleteKey hDefKey, sSubKeyName & Item & ""
Else 'iLoopCnt >= 3
If CheckDelete(sGuid) Then RegDeleteKey hDefKey, sSubKeyName & Item & ""
End If 'iLoopCnt < 3
End If 'fRemoveAll
End If 'InScope
End If 'Len(Item)=32
Next 'Item
End If 'RegEnumKey
Next 'iLoopCnt

'Components
Log " - Global Components"
sSubKeyName = "SOFTWAREMicrosoftWindowsCurrentVersionInstallerUserDataS-1-5-18Components"
If RegEnumKey(HKLM,sSubKeyName,arrKeys) Then
For Each Item in arrKeys
'Ensure we have the expected length for a compressed GUID
If Len(Item)=32 Then
If RegEnumValues(HKLM,sSubKeyName & Item,arrNames,arrTypes) Then
If IsArray(arrNames) Then
For Each Name in arrNames
If Len(Name)=32 Then
sGuid = GetExpandedGuid(Name)
If CheckDelete(sGuid) Then
RegDeleteValue HKLM, sSubKeyName & Item & "", Name, False
'Check if the key is now empty
If NOT RegEnumValues(HKLM,sSubKeyName & Item,arrTestNames,arrTestTypes) Then
If NOT dicDelRegKey.Exists(sSubKeyName&Item&"") Then dicDelRegKey.Add sSubKeyName&Item&"",HKCR
End If
End If
End If '32
Next 'Name
End If 'IsArray
End If 'RegEnumValues
End If '32
Next 'Item
End If 'RegEnumKey

'Published Components
Log " - Published Components"
sSubKeyName = "InstallerComponents"
If RegEnumKey(HKCR,sSubKeyName,arrKeys) Then
For Each Item in arrKeys
'Ensure we have the expected length for a compressed GUID
If Len(Item)=32 Then
If RegEnumValues(HKCR,sSubKeyName & Item,arrNames,arrTypes) Then
If IsArray(arrNames) Then
For Each Name in arrNames
If RegReadValue (HKCR,sSubKeyName & Item, Name, sValue,"REG_MULTI_SZ") Then
arrMultiSzValues = Split(sValue,chr(34))
If IsArray(arrMultiSzValues) Then
i = -1
ReDim arrMultiSzNewValues(-1)
fDelReg = False
For Each value in arrMultiSzValues
If Len(value) > 19 Then
sGuid = ""
If GetDecodedGuid(Left(value,SQUISHED),sGuid) Then
If CheckDelete(sGuid) Then
fDelReg = True
Else
i = i + 1 
ReDim Preserve arrMultiSzNewValues(i)
arrMultiSzNewValues(i) = value
End If 'CheckDelete
End If 'decode
End If '19
Next 'Value
If NOT (i = -1) Then
If NOT fDetectOnly Then 
If NOT UBound(arrMultiSzValues) = i Then oReg.SetMultiStringValue HKCR,sSubKeyName & Item,Name,arrMultiSzNewValues
End If
Else
If fDelReg Then
RegDeleteValue HKCR,sSubKeyName & Item & "", Name, False
'Check if the key is now empty
If NOT RegEnumValues(HKCR,sSubKeyName & Item,arrTestNames,arrTestTypes) Then
If NOT dicDelRegKey.Exists(sSubKeyName&Item&"") Then dicDelRegKey.Add sSubKeyName&Item&"",HKCR
End If
End If 'DelReg
End If
End If 'IsArray
End If
Next 'Name
End If 'IsArray
End If 'RegEnumValues
End If '32
Next 'Item
End If 'RegEnumKey

'Delivery
Log " - Delivery"
hDefKey = HKLM
sSubKeyName = "SOFTWAREMicrosoftOfficeDeliverySourceEngineDownloads"
If RegEnumKey(HKLM,sSubKeyName,arrKeys) Then
For Each Item in arrKeys
If Len(Item) > 37 Then
If fRemoveAll Then
If (Mid(Item,27,PRODLEN)=OFFICEID AND Mid(Item,4,2)=OVERSIONMAJOR) OR _
LCase(Right(Item,7))=OVERSIONMAJOR&".data" Then RegDeleteKey HKLM,sSubKeyName & Item & ""
Else
If (Mid(Item,27,PRODLEN)=OFFICEID AND Mid(Item,4,2)=OVERSIONMAJOR) AND _
CheckDelete(UCase(Left(Item,38))) Then RegDeleteKey HKLM,sSubKeyName & Item & ""
End If
End If '37
Next 'Item
End If 'RegEnumKey

'Registration
Log " - HKLM Registration"
hDefKey = HKLM
sSubKeyName = "SOFTWAREMicrosoftOffice"&OVERSION&"Registration"
If RegEnumKey(HKLM,sSubKeyName,arrKeys) Then
For Each Item in arrKeys
If Len(Item)>37 Then
If CheckDelete(UCase(Left(Item,38))) Then RegDeleteKey HKLM,sSubKeyName & Item & ""
End If
Next 'Item
End If 'RegEnumKey

'User Preconfigurations
Log " - HKLM User Preconfigurations"
hDefKey = HKLM
sSubKeyName = "SOFTWAREMicrosoftOffice"&OVERSION&"User Settings"
If RegEnumKey(HKLM,sSubKeyName,arrKeys) Then
For Each Item in arrKeys
If Len(Item)>37 Then
If CheckDelete(UCase(Left(Item,38))) Then RegDeleteKey HKLM,sSubKeyName & Item & ""
End If
Next 'Item
End If 'RegEnumKey

'Known Keypath settings
Log " - Detcted KeyPath settings"
For Each key in dicDelRegKey.Keys
If Right(key,1) = "" Then
RegDeleteKey dicDelRegKey.Item(key),key
Else
iPos = InStrRev(Key,"")
If iPos > 0 Then RegDeleteValue dicDelRegKey.Item(key), Left(key,iPos - 1), Mid(key,iPos+1), False
End If
Next

'Temporary entries in ARP
TmpKeyCleanUp
End Sub 'RegWipe
'=======================================================================================================

'Clean up Add/Remove Programs registry
Sub RegWipeARP

Dim Item, Name, Sku, key
Dim sSubKeyName, sCurKey, sValue, sGuid
Dim fkeep, fSystemComponent0, fPackages, fDisplayVersion
Dim arrKeys

'Add/Remove Programs
sSubKeyName = REG_ARP
If RegEnumKey(HKLM,sSubKeyName,arrKeys) Then
For Each Item in arrKeys
'*0FF1CE*
If Len(Item)>37 Then
sGuid = UCase(Left(Item,38))
If InScope(sGuid) Then
If CheckDelete(sGuid) Then RegDeleteKey HKLM, sSubKeyName & Item
End If 'InScope
End If 'Len(Item)>37

'Config entries
sCurKey = sSubKeyName & Item & ""
fSystemComponent0 = Not (RegReadValue(HKLM,sCurKey,"SystemComponent",sValue,"REG_DWORD") AND (sValue = "1"))
fPackages = RegReadValue(HKLM,sCurKey,OPACKAGE,sValue,"REG_MULTI_SZ")
fDisplayVersion = RegReadValue(HKLM,sCurKey,"DisplayVersion",sValue,"REG_SZ")
If fDisplayVersion AND Len(sValue) > 1 Then
fDisplayVersion = (Left(sValue,2) = OVERSIONMAJOR)
End If
If (fSystemComponent0 AND fPackages AND fDisplayVersion) Then
fKeep = False
If Not fRemoveAll Then
For Each Sku in dicKeepSku.Keys
If UCase(Item) =  OREGREF & Sku Then
fkeep = True
Exit For
End If
Next 'Sku
End If
If Not fkeep Then RegDeleteKey HKLM, sSubKeyName & Item
End If
Next 'Item
End If 'RegEnumKey

End Sub 'RegWipeARP
'=======================================================================================================

'Clean up temporary registry keys
Sub TmpKeyCleanUp
Dim TmpKey

If fLogInitialized Then Log " - temporary OffScrub registry entries"
If IsArray(arrTmpSKUs) Then
For Each TmpKey in arrTmpSKUs
oReg.DeleteKey HKLM, REG_ARP & TmpKey
Next 'Item
End If 'IsArray
End Sub 'TmpKeyCleanUp

'=======================================================================================================
' Helper Functions
'=======================================================================================================

'Create a log with the results of the SKU detection
Sub LogSkuResults
Dim SkuLog, SkuKey , p

On Error Resume Next 'Don't fail on logging

Set SkuLog = oFso.OpenTextFile(sScrubDir & "SkuLog.txt",FOR_WRITING,True,True)

SkuLog.WriteLine "Installed SKUs (All):"
SkuLog.WriteLine "====================="
For Each SkuKey in dicInstalledSku.Keys
SkuLog.WriteLine " - " & SkuKey
Next 'Key

SkuLog.WriteLine vbCrLf & "Server SKUs:"
SkuLog.WriteLine          "============"
For Each SkuKey in dicSrv.Keys
SkuLog.WriteLine " - " & SkuKey
Next 'Key

SkuLog.WriteLine vbCrLf & "Client Suite SKUs:"
SkuLog.WriteLine          "=================="
For Each SkuKey in dicCSuite.Keys
SkuLog.WriteLine " - " & SkuKey
Next 'Key

SkuLog.WriteLine vbCrLf & "Client Standalone SKUs:"
SkuLog.WriteLine          "======================="
For Each SkuKey in dicCSingle.Keys
SkuLog.WriteLine " - " & SkuKey
Next 'Key

SkuLog.WriteLine vbCrLf & "Installed Products (All):"
SkuLog.WriteLine          "========================="
For Each p in oMsi.Products
If InScope(p) Then
SkuLog.Write " - " & p & " - "
SkuLog.Write oMsi.ProductInfo(p, "ProductName")
SkuLog.WriteLine " "
End If
Next 'Product

SkuLog.WriteLine vbCrLf & "***************************************************************************************************" & vbCrLf

SkuLog.WriteLine vbCrLf & "SKUs to keep:"
SkuLog.WriteLine          "============="
For Each SkuKey in dicKeepSku.Keys
SkuLog.WriteLine " - " & SkuKey
Next 'Key

SkuLog.WriteLine vbCrLf & "Products to keep:"
SkuLog.WriteLine          "================="
For Each p in dicKeepProd.Keys
SkuLog.Write " - " & p & " - "
SkuLog.Write oMsi.ProductInfo(p, "ProductName")
SkuLog.WriteLine " "
Next 'Key

SkuLog.WriteLine vbCrLf & "***************************************************************************************************" & vbCrLf

SkuLog.WriteLine vbCrLf & "SKUs to remove:"
SkuLog.WriteLine          "==============="
For Each SkuKey in dicRemoveSku.Keys
SkuLog.WriteLine " - " & SkuKey
Next 'Key

SkuLog.WriteLine vbCrLf & "Products to remove:"
SkuLog.WriteLine          "==================="
For Each p in oMsi.Products
If InScope(p) Then
If (fRemoveAll OR CheckDelete(p))Then
SkuLog.Write " - " & p & " - "
SkuLog.Write oMsi.ProductInfo(p, "ProductName")
SkuLog.WriteLine " "
End If
End If 'InScope
Next 'Product

SkuLog.Close
Set SkuLog = Nothing

End Sub 'LogSkuResults
'=======================================================================================================

'End all running instances of applications that will be removed
Sub CloseOfficeApps
Dim Processes, Process, prop
Dim fWait
Dim iRet

On Error Resume Next

fWait = False
Log " Doing Action: CloseOfficeApps"

Set Processes = oWmiLocal.ExecQuery("Select * From Win32_Process")
For Each Process in Processes
If dicApps.Exists(LCase(Process.Name)) Then
Log " - End process " & Process.Name
iRet = Process.Terminate()
CheckError "CloseOfficeApps: " & "Process.Name"
Else
For Each prop in Process.Properties_
If prop.Name = "ExecutablePath" Then 
If InStr(UCase(prop.Value), UCase(sOInstallRoot)) > 0 Then
Log = " - End process '" & Process.Name
iRet = Process.Terminate()
CheckError "CloseOfficeApps: " & "Process.Name"
fWait = True
End If 
End If 'ExcecutablePath
Next 'prop
End If
Next 'Process
If fWait Then
wscript.sleep 10000
End If
LogOnly " End Action: CloseOfficeApps"
End Sub 'CloseOfficeApps
'=======================================================================================================

'Ensure Windows Explorer is restarted if needed
Sub RestoreExplorer
Dim Processes, Result, oAT, DateTime, JobID
Dim sCmd

'Non critical routine. Don't fail on error
On Error Resume Next
wscript.sleep 1000
Set Processes = oWmiLocal.ExecQuery("Select * From Win32_Process Where Name='explorer.exe'")
If Processes.Count < 1 Then 
oWShell.Run "explorer.exe"
'To handle this in case of System context, schedule and run as interactive task
If iVersionNT > 502 Then
'Vista and later
oWShell.Run "SCHTASKS /Create /TN OffScrEx /TR explorer /SC ONCE /ST 12:00 /IT",0,True
oWShell.Run "SCHTASKS /Run /TN OffScrEx", 0, True
oWShell.Run "SCHTASKS /Delete /TN OffScrEx /F", 0, False
Else
Set oAT = oWmiLocal.Get("Win32_ScheduledJob")
Set DateTime = CreateObject("WbemScripting.SWbemDateTime")
DateTime.SetVarDate DateAdd("n",1,Now),True
Result = oAT.Create("explorer.exe", DateTime.Value, , , , True, JobID)
End If 'iVersionNT
End If
End Sub 'RestoreExploer
'=======================================================================================================

'Returns the delimiter for a passed in string
Function Delimiter (sVersion)

Dim iCnt, iAsc

Delimiter = " "
For iCnt = 1 To Len(sVersion)
iAsc = Asc(Mid(sVersion, iCnt, 1))
If Not (iASC >= 48 And iASC <= 57) Then 
Delimiter = Mid(sVersion, iCnt, 1)
Exit Function
End If
Next 'iCnt
End Function
'=======================================================================================================

'Check registry access permissions. Failure will terminate the script
Function CheckRegPermissions
Const KEY_QUERY_VALUE       = &H0001
Const KEY_SET_VALUE         = &H0002
Const KEY_CREATE_SUB_KEY    = &H0004
Const DELETE                = &H00010000

Dim sSubKeyName
Dim fReturn

CheckRegPermissions = True
sSubKeyName = "SoftwareMicrosoftWindows"
oReg.CheckAccess HKLM, sSubKeyName, KEY_QUERY_VALUE, fReturn
If Not fReturn Then CheckRegPermissions = False
oReg.CheckAccess HKLM, sSubKeyName, KEY_SET_VALUE, fReturn
If Not fReturn Then CheckRegPermissions = False
oReg.CheckAccess HKLM, sSubKeyName, KEY_CREATE_SUB_KEY, fReturn
If Not fReturn Then CheckRegPermissions = False
oReg.CheckAccess HKLM, sSubKeyName, DELETE, fReturn
If Not fReturn Then CheckRegPermissions = False

End Function 'CheckRegPermissions
'=======================================================================================================

'Check if an Office product is still registered with a SKU that stays on the computer
Function CheckDelete(sProductCode)

'Ensure valid GUID length
If NOT Len(sProductCode) = 38 Then
CheckDelete = False
Exit Function
End If

'If it's a non Office ProductCode exit with false right away
CheckDelete = InScope(sProductCode)
If Not CheckDelete Then Exit Function
If dicKeepProd.Exists(UCase(sProductCode)) Then CheckDelete = False

End Function 'CheckDelete
'=======================================================================================================

'Check if ProductCode is in scope
Function InScope(sProductCode)

Dim fInScope
Dim sProd

fInScope = False
If Len(sProductCode) = 38 Then
sProd = UCase(sProductCode)
Select Case OVERSIONMAJOR
Case "11"
If Right(sProd,PRODLEN)=OFFICEID Then InScope = True
Case "12"
If Right(sProd,PRODLEN)=OFFICEID AND Mid(sProd,4,2) = OVERSIONMAJOR Then fInScope = True
Case "14"
If Right(sProd,PRODLEN)=OFFICEID AND Mid(sProd,4,2) = OVERSIONMAJOR Then fInScope = True
Case "15"
If Right(sProd,PRODLEN)=OFFICEID AND Mid(sProd,4,2) = OVERSIONMAJOR Then 
Select Case Mid(sProd, 11, 4)
Case "007E", "008F", "008C"
' C2R products - keep them
Case Else
fInScope = True
End Select
End If
Case Else
End Select
End If '38

InScope = fInScope
End Function 'InScope
'=======================================================================================================

'Register an orphaned .msi product as installed for MSI
Sub MsiRegisterProduct (sMsiFile)

Dim sDisplayVersion, sCurKey, sDisplayName, sLang, sProductCode, sTmpKey
Dim iCnt

'Create a temporary keys to simulate an installed product
sProductCode = ""
sProductCode = GetMsiProductCode(sMsiFile)
sDisplayVersion = GetMsiProductVersion(sMsiFile)
If sDisplayVersion = "" Then sDisplayVersion = OVERSION & ".0000.0000"
sDisplayName = GetMsiProductName(sMsiFile)
If sDisplayName = "" Then sDisplayName = sProductCode
Select Case OVERSIONMAJOR
Case "9","10","11"
sLang = CInt("&h" & Mid(sProductCode,6,4))
Case "12","14"
sLang = CInt("&h" & Mid(sProductCode,16,4))
Case Else
End Select

For iCnt = 1 To 3
Select Case iCnt
Case 1
sCurKey = REG_ARP & sProductCode
oReg.CreateKey HKLM,sCurKey
Case 2
sCurKey = "SOFTWAREMicrosoftWindowsCurrentVersionInstallerUserDataS-1-5-18Products" & GetCompressedGuid(sProductCode)
oReg.CreateKey HKLM,sCurKey
oReg.CreateKey HKLM,sCurKey & "Features"
oReg.CreateKey HKLM,sCurKey & "InstallProperties"
oReg.CreateKey HKLM,sCurKey & "Patches"
oReg.CreateKey HKLM,sCurKey & "Usage"
sCurKey = sCurKey & "InstallProperties"
oReg.SetStringValue HKLM,sCurKey,"LocalPackage",sMsiFile
Case 3
sCurKey = "InstallerProducts" & GetCompressedGuid(sProductCode)
sTmpKey = sCurKey
oReg.CreateKey HKCR,sCurKey
oReg.SetDWordValue HKCR,sCurKey,"AdvertiseFlags",388
oReg.SetDWordValue HKCR,sCurKey,"Assignment",1
oReg.SetDWordValue HKCR,sCurKey,"AuthorizedLUAApp",0
oReg.SetStringValue HKCR,sCurKey,"Clients",":"
oReg.SetDWordValue HKCR,sCurKey,"DeploymentFlags",3
oReg.SetDWordValue HKCR,sCurKey,"InstanceType",0
oReg.SetDWordValue HKCR,sCurKey,"Language",sLang
oReg.SetStringValue HKCR,sCurKey,"PackageCode",GetMsiPackageCode(sMsiFile)
oReg.SetStringValue HKCR,sCurKey,"ProductName",sDisplayName
oReg.SetDWordValue HKCR,sCurKey,"VersionMinor",0
sCurKey = sTmpKey & "SourceList"
oReg.CreateKey HKCR,sCurKey
oReg.SetExpandedStringValue HKCR,sCurKey,"LastUsedSource",sScrubDir
oReg.SetStringValue HKCR,sCurKey,"PackageName",Mid(sMsiFile,InstrRev(sMsiFile,"")+1)
sCurKey = sTmpKey & "SourceListMedia"
oReg.CreateKey HKCR,sCurKey
oReg.SetStringValue HKCR,sCurKey,"1",OREF & ";1"
oReg.SetStringValue HKCR,sCurKey,"DiskPrompt",sDisplayName
sCurKey = sTmpKey & "SourceListNet"
oReg.CreateKey HKCR,sCurKey
oReg.SetExpandedStringValue HKCR,sCurKey,"1",sScrubDir

Case Else
End Select
If iCnt <3 Then
oReg.SetStringValue HKLM,sCurKey,"Comments",""
oReg.SetStringValue HKLM,sCurKey,"Contact",""
oReg.SetStringValue HKLM,sCurKey,"DisplayName",sDisplayName
oReg.SetStringValue HKLM,sCurKey,"DisplayVersion",sDisplayVersion
oReg.SetDWordValue HKLM,sCurKey,"EstimatedSize",0
oReg.SetStringValue HKLM,sCurKey,"HelpLink",""
oReg.SetStringValue HKLM,sCurKey,"HelpTelephone",""
oReg.SetStringValue HKLM,sCurKey,"InstallDate","20100101"
If f64 Then
oReg.SetStringValue HKLM,sCurKey,"InstallLocation",sProgramFilesX86
Else
oReg.SetStringValue HKLM,sCurKey,"InstallLocation",sProgramFiles
End If
oReg.SetStringValue HKLM,sCurKey,"InstallSource",sScrubDir
oReg.SetDWordValue HKLM,sCurKey,"Language",sLang
oReg.SetExpandedStringValue HKLM,sCurKey,"ModifyPath","MsiExec.exe /X" & sProductCode
oReg.SetDWordValue HKLM,sCurKey,"NoModify",1
oReg.SetStringValue HKLM,sCurKey,"Publisher","Microsoft Corporation"
oReg.SetStringValue HKLM,sCurKey,"Readme",""
oReg.SetStringValue HKLM,sCurKey,"Size",""
oReg.SetDWordValue HKLM,sCurKey,"SystemComponent",0
oReg.SetExpandedStringValue HKLM,sCurKey,"UninstallString","MsiExec.exe /X" & sProductCode
oReg.SetStringValue HKLM,sCurKey,"URLInfoAbout",""
oReg.SetStringValue HKLM,sCurKey,"URLUpdateInfo",""
oReg.SetDWordValue HKLM,sCurKey,"Version",0
oReg.SetDWordValue HKLM,sCurKey,"VersionMajor",OVERSIONMAJOR
oReg.SetDWordValue HKLM,sCurKey,"VersionMinor",0
oReg.SetDWordValue HKLM,sCurKey,"WindowsInstaller",1
End If '< 3
Next 'iCnt

End Sub 'MsiRegisterProduct
'=======================================================================================================

'Obtain the ProductCode (GUID) from a .msi package
'The function will open the .msi database and query the 'Property' table to retrieve the ProductCode
Function GetMsiProductCode(sMsiFile)

Dim MsiDb,Record
Dim qView

On Error Resume Next

GetMsiProductCode = ""
Set Record = Nothing

Set MsiDb = oMsi.OpenDatabase(sMsiFile,MSIOPENDATABASEREADONLY)
Set qView = MsiDb.OpenView("SELECT `Value` FROM Property WHERE `Property` = 'ProductCode'")
qView.Execute
Set Record = qView.Fetch
GetMsiProductCode = Record.StringData(1)
qView.Close

End Function 'GetMsiProductCode
'=======================================================================================================

'Obtain the ProductVersion from a .msi package
'The function will open the .msi database and query the 'Property' table to retrieve the ProductCode
Function GetMsiProductVersion(sMsiFile)

Dim MsiDb,Record
Dim qView

On Error Resume Next

GetMsiProductVersion = ""
Set Record = Nothing

Set MsiDb = oMsi.OpenDatabase(sMsiFile,MSIOPENDATABASEREADONLY)
Set qView = MsiDb.OpenView("SELECT `Value` FROM Property WHERE `Property` = 'ProductVersion'")
qView.Execute
Set Record = qView.Fetch
GetMsiProductVersion = Record.StringData(1)
qView.Close

End Function 'GetMsiProductVersion
'=======================================================================================================

'Obtain the ProductVersion from a .msi package
'The function will open the .msi database and query the 'Property' table to retrieve the ProductCode
Function GetMsiProductName(sMsiFile)

Dim MsiDb,Record
Dim qView

On Error Resume Next

GetMsiProductName = ""
Set Record = Nothing

Set MsiDb = oMsi.OpenDatabase(sMsiFile,MSIOPENDATABASEREADONLY)
Set qView = MsiDb.OpenView("SELECT `Value` FROM Property WHERE `Property` = 'ProductName'")
qView.Execute
Set Record = qView.Fetch
GetMsiProductName = Record.StringData(1)
qView.Close

End Function 'GetMsiProductVersion
'=======================================================================================================

'Obtain the PackageCode (GUID) from a .msi package
'The function will the .msi'S SummaryInformation stream
Function GetMsiPackageCode(sMsiFile)

On Error Resume Next

Const PID_REVNUMBER = 9

GetMsiPackageCode = ""
GetMsiPackageCode = GetCompressedGuid(oMsi.SummaryInformation(sMsiFile,MSIOPENDATABASEREADONLY).Property(PID_REVNUMBER))

End Function 'GetMsiPackageCode
'=======================================================================================================

'Returns a string with a list of ProductCodes from the summary information stream
Function MspTargets (sMspFile)
Const MSIOPENDATABASEMODE_PATCHFILE = 32
Const PID_TEMPLATE                  =  7

Dim Msp
'Non critical routine. Don't fail on error
On Error Resume Next
MspTargets = ""
If oFso.FileExists(sMspFile) Then
Set Msp = Msi.OpenDatabase(WScript.Arguments(0),MSIOPENDATABASEMODE_PATCHFILE)
If Err = 0 Then MspTargets = Msp.SummaryInformation.Property(PID_TEMPLATE)
End If 'oFso.FileExists(sMspFile)
End Function 'MspTargets
'=======================================================================================================

'Return the ProductCode {GUID} from a .MSI package
Function ProductCode(sMsi)
Const MSIUILEVELNONE = 2 'No UI
Dim MsiSession

On Error Resume Next
'Non critical routine. Don't fail on error
If oFso.FileExists(sMsi) Then
oMsi.UILevel = MSIUILEVELNONE
Set MsiSession = oMsi.OpenPackage(sMsi,1)
ProductCode = MsiSession.ProductProperty("ProductCode")
Set MsiSession = Nothing
Else
ProductCode = ""
End If 'oFso.FileExists(sMsi)
End Function 'ProductCode
'=======================================================================================================

Function GetExpandedGuid (sGuid)
Dim i

'Ensure valid length
If NOT Len(sGuid) = 32 Then Exit Function

GetExpandedGuid = "{" & StrReverse(Mid(sGuid,1,8)) & "-" & _
StrReverse(Mid(sGuid,9,4)) & "-" & _
StrReverse(Mid(sGuid,13,4))& "-"
For i = 17 To 20
    If i Mod 2 Then
    GetExpandedGuid = GetExpandedGuid & mid(sGuid,(i + 1),1)
    Else
    GetExpandedGuid = GetExpandedGuid & mid(sGuid,(i - 1),1)
    End If
Next
GetExpandedGuid = GetExpandedGuid & "-"
For i = 21 To 32
    If i Mod 2 Then
    GetExpandedGuid = GetExpandedGuid & mid(sGuid,(i + 1),1)
    Else
    GetExpandedGuid = GetExpandedGuid & mid(sGuid,(i - 1),1)
    End If
Next
GetExpandedGuid = GetExpandedGuid & "}"
End Function
'=======================================================================================================

'Converts a GUID into the compressed format
Function GetCompressedGuid (sGuid)
Dim sCompGUID
Dim i

'Ensure Valid Length
If NOT Len(sGuid) = 38 Then Exit Function

sCompGUID = StrReverse(Mid(sGuid,2,8))  & _
StrReverse(Mid(sGuid,11,4)) & _
StrReverse(Mid(sGuid,16,4)) 
For i = 21 To 24
    If i Mod 2 Then
    sCompGUID = sCompGUID & Mid(sGuid, (i + 1), 1)
    Else
    sCompGUID = sCompGUID & Mid(sGuid, (i - 1), 1)
    End If
Next
For i = 26 To 37
    If i Mod 2 Then
    sCompGUID = sCompGUID & Mid(sGuid, (i - 1), 1)
    Else
    sCompGUID = sCompGUID & Mid(sGuid, (i + 1), 1)
    End If
Next
GetCompressedGuid = sCompGUID
End Function
'=======================================================================================================

'Unsquish GUID
Function GetDecodedGuid(sEncGuid, sGuid)

Dim sDecode, sTable, sHex, iChr
Dim arrTable
Dim i, iAsc, pow85, decChar
Dim lTotal
Dim fFailed

fFailed = False

sTable =    "0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff," & _
"0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff," & _
"0xff,0x00,0xff,0xff,0x01,0x02,0x03,0x04,0x05,0x06,0x07,0x08,0x09,0x0a,0x0b,0xff," & _
"0x0c,0x0d,0x0e,0x0f,0x10,0x11,0x12,0x13,0x14,0x15,0xff,0xff,0xff,0x16,0xff,0x17," & _
"0x18,0x19,0x1a,0x1b,0x1c,0x1d,0x1e,0x1f,0x20,0x21,0x22,0x23,0x24,0x25,0x26,0x27," & _
"0x28,0x29,0x2a,0x2b,0x2c,0x2d,0x2e,0x2f,0x30,0x31,0x32,0x33,0xff,0x34,0x35,0x36," & _
"0x37,0x38,0x39,0x3a,0x3b,0x3c,0x3d,0x3e,0x3f,0x40,0x41,0x42,0x43,0x44,0x45,0x46," & _
"0x47,0x48,0x49,0x4a,0x4b,0x4c,0x4d,0x4e,0x4f,0x50,0x51,0x52,0xff,0x53,0x54,0xff"
arrTable = Split(sTable,",")
lTotal = 0 : pow85 = 1
For i = 0 To 19
fFailed = True
If i Mod 5 = 0 Then
lTotal = 0 : pow85 = 1
End If ' i Mod 5 = 0
iAsc = Asc(Mid(sEncGuid,i+1,1))
sHex = arrTable(iAsc)
If iAsc >=128 Then Exit For
If sHex = "0xff" Then Exit For
iChr = CInt("&h"&Right(sHex,2))
lTotal = lTotal + (iChr * pow85)
If i Mod 5 = 4 Then sDecode = sDecode & DecToHex(lTotal)
pow85 = pow85 * 85
fFailed = False
Next 'i
If NOT fFailed Then sGuid = "{"&Mid(sDecode,1,8)&"-"& _
Mid(sDecode,13,4)&"-"& _
Mid(sDecode,9,4)&"-"& _
Mid(sDecode,23,2) & Mid(sDecode,21,2)&"-"& _
Mid(sDecode,19,2) & Mid(sDecode,17,2) & Mid(sDecode,31,2) & Mid(sDecode,29,2) & Mid(sDecode,27,2) & Mid(sDecode,25,2) &"}"

GetDecodedGuid = NOT fFailed

End Function 'GetDecodedGuid
'=======================================================================================================

'Convert a long decimal to hex
Function DecToHex(lDec)

Dim sHex
Dim iLen
Dim lVal, lExp
Dim arrChr

arrChr = Array("0","1","2","3","4","5","6","7","8","9","A","B","C","D","E","F")
sHex = ""
lVal = lDec
lExp = 16^10
While lExp >= 1
If lVal >= lExp Then
sHex = sHex & arrChr(Int(lVal / lExp))
lVal = lVal - lExp * Int(lVal / lExp)
Else
sHex = sHex & "0"
If sHex = "0" Then sHex = ""
End If
lExp = lExp / 16
Wend

iLen = 8 - Len(sHex)
If iLen > 0 Then sHex = String(iLen,"0") & sHex
DecToHex = sHex
End Function
'=======================================================================================================

'Ensures that only valid metadata entries exist to avoid API failures
Sub EnsureValidWIMetadata (hDefKey,sKey,iValidLength)

Dim arrKeys
Dim SubKey

If Len(sKey) > 1 Then
If Right(sKey,1) = "" Then sKey = Left(sKey,Len(sKey)-1)
End If

If RegEnumKey(hDefKey,sKey,arrKeys) Then
For Each SubKey in arrKeys
If NOT Len(SubKey) = iValidLength Then
RegDeleteKey hDefKey,sKey & "" & SubKey & ""
End If
Next 'SubKey
End If

End Sub 'EnsureValidWIMetadata
'=======================================================================================================

'Create a backup copy of the file in the ScrubDir then delete the file
Sub CopyAndDeleteFile(sFile)
Dim File

'Error handling inlined
On Error Resume Next
If oFso.FileExists(sFile) Then
Set File = oFso.GetFile(sFile)
If Not oFso.FolderExists(sScrubDir & "" & File.ParentFolder.Name) Then oFso.CreateFolder sScrubDir & "" & File.ParentFolder.Name
If Not fDetectOnly Then
LogOnly " - Backing up file: " & sFile
oFso.CopyFile sFile,sScrubDir & "" & File.ParentFolder.Name & "" & File.Name,True : CheckError "CopyAndDeleteFile"
Set File = Nothing
DeleteFile(sFile)
Else
LogOnly " - Simulate CopyAndDelete file: " & sFile
End If
End If 'oFso.FileExists
End Sub 'CopyAndDeleteFile
'=======================================================================================================

'Wrapper to delete a file
Sub DeleteFile(sFile)
Dim File
Dim sFileName, sNewPath

On Error Resume Next

If dicKeepFolder.Exists(LCase(sFile)) Then
If NOT fForce Then
LogOnly " - Disallowing the delete of still required keypath element: " & sFile
Exit Sub
Else
LogOnly " - Enforced delete of still required keypath element: " & sFile
LogOnly "   Remaining applications will need a repair!"
End If
End If
If f64 Then
If dicKeepFolder.Exists(LCase(Wow64Folder(sFile))) Then
If NOT fForce Then
LogOnly " - Disallowing the delete of still required keypath element: " & sFile
Exit Sub
Else
LogOnly " - Enforced delete of still required keypath element: " & sFile
LogOnly "   Remaining applications will need a repair!"
End If
End If
End If

If oFso.FileExists(sFile) Then
LogOnly " - Delete file: " & sFile
If Not fDetectOnly Then oFso.DeleteFile sFile,True
If Err <> 0 Then
CheckError "DeleteFile"
If fForce Then
'Try to move the file and delete from there
Set File = oFso.GetFile(sFile)
sFileName = File.Name
sNewPath = sScrubDir & "ScrubTmp"
Set File = Nothing
If Not oFso.FolderExists(sNewPath) Then oFso.CreateFolder(sNewPath)
'Move the file
LogOnly " - Move file to: " & sNewPath & "" & sFileName
oFso.MoveFile sFile,sNewPath & "" & sFileName
If Err <> 0 Then 
CheckError "DeleteFile (move)"
End If 'Err <> 0
Else
fRebootRequired = True
End If 'fForce
End If 'Err <> 0
End If 'oFso.FileExists
End Sub 'DeleteFile
'=======================================================================================================

'64 bit aware wrapper to return the requested folder 
Function GetFolderPath(sPath)
GetFolderPath = True
If oFso.FolderExists(sPath) Then Exit Function
If f64 AND oFso.FolderExists(Wow64Folder(sPath)) Then
sPath = Wow64Folder(sPath)
Exit Function
End If
GetFolderPath = False
End Function 'GetFolderPath
'=======================================================================================================

'Enumerates subfolder names of a folder and returns True if subfolders exist
Function EnumFolderNames (sFolder, arrSubFolders)
Dim Folder, Subfolder
Dim sSubFolders

If oFso.FolderExists(sFolder) Then
Set Folder = oFso.GetFolder(sFolder)
For Each Subfolder in Folder.Subfolders
sSubFolders = sSubFolders & Subfolder.Name & ","
Next 'Subfolder
End If
If f64 AND oFso.FolderExists(Wow64Folder(sFolder)) Then
Set Folder = oFso.GetFolder(Wow64Folder(sFolder))
For Each Subfolder in Folder.Subfolders
sSubFolders = sSubFolders & Subfolder.Name & ","
Next 'Subfolder
End If
If Len(sSubFolders)>0 Then arrSubFolders = RemoveDuplicates(Split(Left(sSubFolders,Len(sSubFolders)-1),","))
EnumFolderNames = Len(sSubFolders)>0
End Function 'EnumFolderNames
'=======================================================================================================

'Enumerates subfolders of a folder and returns True if subfolders exist
Function EnumFolders (sFolder, arrSubFolders)
Dim Folder, Subfolder
Dim sSubFolders

If oFso.FolderExists(sFolder) Then
Set Folder = oFso.GetFolder(sFolder)
For Each Subfolder in Folder.Subfolders
sSubFolders = sSubFolders & Subfolder.Path & ","
Next 'Subfolder
End If
If f64 AND oFso.FolderExists(Wow64Folder(sFolder)) Then
Set Folder = oFso.GetFolder(Wow64Folder(sFolder))
For Each Subfolder in Folder.Subfolders
sSubFolders = sSubFolders & Subfolder.Path & ","
Next 'Subfolder
End If
If Len(sSubFolders)>0 Then arrSubFolders = RemoveDuplicates(Split(Left(sSubFolders,Len(sSubFolders)-1),","))
EnumFolders = Len(sSubFolders)>0
End Function 'EnumFolders
'=======================================================================================================

Sub GetMseFolderStructure (Folder)
Dim SubFolder

For Each SubFolder in Folder.SubFolders
ReDim Preserve arrMseFolders(UBound(arrMseFolders)+1)
arrMseFolders(UBound(arrMseFolders)) = SubFolder.Path
GetMseFolderStructure SubFolder
Next 'SubFolder
End Sub 'GetMseFolderStructure
'=======================================================================================================

'Wrapper to delete a folder 
Sub DeleteFolder(sFolder)
Dim Folder
Dim sDelFolder, sFolderName, sNewPath

'Ensure trailing ""
sFolder = sFolder & ""
While InStr(sFolder,"\")>0
sFolder = Replace(sFolder,"\","")
Wend

If dicKeepFolder.Exists(LCase(sFolder)) Then
If NOT fForce Then
LogOnly " - Disallowing the delete of still required keypath element: " & sFolder
Exit Sub
Else
LogOnly " - Enforced delete of still required keypath element: " & sFolder
LogOnly "   Remaining applications will need a repair!"
End If
End If
If f64 Then
If dicKeepFolder.Exists(LCase(Wow64Folder(sFolder))) Then
If NOT fForce Then
LogOnly " - Disallowing the delete of still required keypath element: " & sFolder
Exit Sub
Else
LogOnly " - Enforced delete of still required keypath element: " & sFolder
LogOnly "   Remaining applications will need a repair!"
End If
End If
End If

'Strip trailing ""
If Len(sFolder) > 1 Then
sFolder = Left(sFolder,Len(sFolder)-1)
End If

On Error Resume Next
If oFso.FolderExists(sFolder) Then 
sDelFolder = sFolder
ElseIf f64 AND oFso.FolderExists(Wow64Folder(sFolder)) Then 
sDelFolder = Wow64Folder(sFolder)
Else
Exit Sub
End If
If Not fDetectOnly Then 
LogOnly " - Delete folder: " & sDelFolder
oFso.DeleteFolder sDelFolder,True
Else
LogOnly " - Simulate delete folder: " & sDelFolder
End If
If Err <> 0 Then
CheckError "DeleteFolder"
'Try to move the folder and delete from there
Set Folder = oFso.GetFolder(sDelFolder)
sFolderName = Folder.Name
sNewPath = sScrubDir & "ScrubTmp"
Set Folder = Nothing
'Ensure we stay within the same drive
If Not oFso.FolderExists(sNewPath) Then oFso.CreateFolder(sNewPath)
'Move the folder
LogOnly " - Moving folder to: " & sNewPath & "" & sFolderName
oFso.MoveFolder sFolder,sNewPath & "" & sFolderName
If Err <> 0 Then
CheckError "DeleteFolder (move)"
End If 'Err <> 0
End If 'Err <> 0
End Sub 'DeleteFolder
'=======================================================================================================

'Delete empty folder structures
Sub DeleteEmptyFolders
Dim Folder
Dim sFolder

' cosmetic' task don't fail on error
On Error Resume Next
If Not IsArray(arrDeleteFolders) Then Exit Sub
Log vbCrLf & "Empty Folder Cleanup"
For Each sFolder in arrDeleteFolders
If oFso.FolderExists(sFolder) Then
Set Folder = oFso.GetFolder(sFolder)
If CBool(Folder.Attributes AND 1024) Then
'exclude protected folder
Else
If (Folder.Subfolders.Count = 0) AND (Folder.Files.Count = 0) Then 
Set Folder = Nothing
SmartDeleteFolder sFolder
End If
End If
End If
Next 'sFolder
CheckError "DeleteEmptyFolders"
On Error Goto 0
End Sub 'DeleteEmptyFolders
'=======================================================================================================

'Wrapper to delete a folder and remove the empty parent folder structure
Sub SmartDeleteFolder(sFolder)
If oFso.FolderExists(sFolder) Then 
If Not fDetectOnly Then
LogOnly "  Request SmartDelete for folder: " & sFolder
SmartDeleteFolderEx sFolder
Else
LogOnly "  Simulate request SmartDelete for folder: " & sFolder
End If
End If
If f64 AND oFso.FolderExists(Wow64Folder(sFolder)) Then 
If Not fDetectOnly Then 
LogOnly "Request SmartDelete for folder: " & Wow64Folder(sFolder)
SmartDeleteFolderEx Wow64Folder(sFolder)
Else
LogOnly "Simulate request SmartDelete for folder: " & Wow64Folder(sFolder)
End If
End If
End Sub 'SmartDeleteFolder
'=======================================================================================================

'Executes the folder delete operation
Sub SmartDeleteFolderEx(sFolder)
Dim Folder

On Error Resume Next
DeleteFolder sFolder : CheckError "SmartDeleteFolderEx"
On Error Goto 0
Set Folder = oFso.GetFolder(oFso.GetParentFolderName(sFolder))
If (Folder.Subfolders.Count = 0) AND (Folder.Files.Count = 0) Then SmartDeleteFolderEx(Folder.Path)
End Sub 'SmartDeleteFolderEx
'=======================================================================================================

'Adds the folder structure to the 'KeepFolder' dictionary
Sub AddKeepFolder(sPath)

Dim Folder

'Ensure trailing ""
sPath = LCase(sPath) & ""
While InStr(sPath,"\")>0
sPath = Replace(sPath,"\","")
Wend

If NOT dicKeepFolder.Exists (sPath) Then
dicKeepFolder.Add sPath,sPath
Else
Exit Sub
End If
sPath = LCase(oFso.GetParentFolderName(sPath)) & ""
If oFso.FolderExists(sPath) Then AddKeepFolder(sPath)
End Sub
'=======================================================================================================

'Handles additional folder-path operations on 64 bit environments
Function Wow64Folder(sFolder)
If LCase(Left(sFolder,Len(sWinDir & "System32"))) = LCase(sWinDir & "System32") Then 
Wow64Folder = sWinDir & "syswow64" & Right(sFolder,Len(sFolder)-Len(sSys32Dir))
ElseIf LCase(Left(sFolder,Len(sProgramFiles))) = LCase(sProgramFiles) Then 
Wow64Folder = sProgramFilesX86 & Right(sFolder,Len(sFolder)-Len(sProgramFiles))
Else
Wow64Folder = "?" 'Return invalid string to ensure the folder cannot exist
End If
End Function 'Wow64Folder
'=======================================================================================================

Function HiveString(hDefKey)
On Error Resume Next
Select Case hDefKey
Case HKCR : HiveString = "HKEY_CLASSES_ROOT"
Case HKCU : HiveString = "HKEY_CURRENT_USER"
Case HKLM : HiveString = "HKEY_LOCAL_MACHINE"
Case HKU  : HiveString = "HKEY_USERS"
Case Else : HiveString = hDefKey
End Select
End Function
'=======================================================================================================

Function RegKeyExists(hDefKey,sSubKeyName)
Dim arrKeys
RegKeyExists = False
If oReg.EnumKey(hDefKey,sSubKeyName,arrKeys) = 0 Then RegKeyExists = True
End Function
'=======================================================================================================

Function RegValExists(hDefKey,sSubKeyName,sName)
Dim arrValueTypes, arrValueNames
Dim i

RegValExists = False
If Not RegKeyExists(hDefKey,sSubKeyName) Then Exit Function
If oReg.EnumValues(hDefKey,sSubKeyName,arrValueNames,arrValueTypes) = 0 AND IsArray(arrValueNames) Then
For i = 0 To UBound(arrValueNames) 
If LCase(arrValueNames(i)) = Trim(LCase(sName)) Then RegValExists = True
Next 
End If 'oReg.EnumValues
End Function
'=======================================================================================================

'Read the value of a given registry entry
Function RegReadValue(hDefKey, sSubKeyName, sName, sValue, sType)
Dim RetVal
Dim Item
Dim arrValues

Select Case UCase(sType)
Case "1","REG_SZ"
RetVal = oReg.GetStringValue(hDefKey,sSubKeyName,sName,sValue)
If Not RetVal = 0 AND f64 Then RetVal = oReg.GetStringValue(hDefKey,Wow64Key(hDefKey, sSubKeyName),sName,sValue)

Case "2","REG_EXPAND_SZ"
RetVal = oReg.GetExpandedStringValue(hDefKey,sSubKeyName,sName,sValue)
If Not RetVal = 0 AND f64 Then RetVal = oReg.GetExpandedStringValue(hDefKey,Wow64Key(hDefKey, sSubKeyName),sName,sValue)

Case "7","REG_MULTI_SZ"
RetVal = oReg.GetMultiStringValue(hDefKey,sSubKeyName,sName,arrValues)
If Not RetVal = 0 AND f64 Then RetVal = oReg.GetMultiStringValue(hDefKey,Wow64Key(hDefKey, sSubKeyName),sName,arrValues)
If RetVal = 0 Then sValue = Join(arrValues,chr(34))

Case "4","REG_DWORD"
RetVal = oReg.GetDWORDValue(hDefKey,sSubKeyName,sName,sValue)
If Not RetVal = 0 AND f64 Then 
RetVal = oReg.GetDWORDValue(hDefKey,Wow64Key(hDefKey, sSubKeyName),sName,sValue)
End If

Case "3","REG_BINARY"
RetVal = oReg.GetBinaryValue(hDefKey,sSubKeyName,sName,sValue)
If Not RetVal = 0 AND f64 Then RetVal = oReg.GetBinaryValue(hDefKey,Wow64Key(hDefKey, sSubKeyName),sName,sValue)

Case "11","REG_QWORD"
RetVal = oReg.GetQWORDValue(hDefKey,sSubKeyName,sName,sValue)
If Not RetVal = 0 AND f64 Then RetVal = oReg.GetQWORDValue(hDefKey,Wow64Key(hDefKey, sSubKeyName),sName,sValue)

Case Else
RetVal = -1
End Select 'sValue

RegReadValue = (RetVal = 0)
End Function 'RegReadValue
'=======================================================================================================

'Enumerate a registry key to return all values
Function RegEnumValues(hDefKey,sSubKeyName,arrNames, arrTypes)
Dim RetVal, RetVal64
Dim arrNames32, arrNames64, arrTypes32, arrTypes64

If f64 Then
RetVal = oReg.EnumValues(hDefKey,sSubKeyName,arrNames32,arrTypes32)
RetVal64 = oReg.EnumValues(hDefKey,Wow64Key(hDefKey, sSubKeyName),arrNames64,arrTypes64)
If (RetVal = 0) AND (Not RetVal64 = 0) AND IsArray(arrNames32) AND IsArray(arrTypes32) Then 
arrNames = arrNames32
arrTypes = arrTypes32
End If
If (Not RetVal = 0) AND (RetVal64 = 0) AND IsArray(arrNames64) AND IsArray(arrTypes64) Then 
arrNames = arrNames64
arrTypes = arrTypes64
End If
If (RetVal = 0) AND (RetVal64 = 0) AND IsArray(arrNames32) AND IsArray(arrNames64) AND IsArray(arrTypes32) AND IsArray(arrTypes64) Then 
arrNames = RemoveDuplicates(Split((Join(arrNames32,"") & "" & Join(arrNames64,"")),""))
arrTypes = RemoveDuplicates(Split((Join(arrTypes32,"") & "" & Join(arrTypes64,"")),""))
End If
Else
RetVal = oReg.EnumValues(hDefKey,sSubKeyName,arrNames,arrTypes)
End If 'f64
RegEnumValues = ((RetVal = 0) OR (RetVal64 = 0)) AND IsArray(arrNames) AND IsArray(arrTypes)
End Function 'RegEnumValues
'=======================================================================================================

'Enumerate a registry key to return all subkeys
Function RegEnumKey(hDefKey,sSubKeyName,arrKeys)
Dim RetVal, RetVal64
Dim arrKeys32, arrKeys64

If f64 Then
RetVal = oReg.EnumKey(hDefKey,sSubKeyName,arrKeys32)
RetVal64 = oReg.EnumKey(hDefKey,Wow64Key(hDefKey, sSubKeyName),arrKeys64)
If (RetVal = 0) AND (Not RetVal64 = 0) AND IsArray(arrKeys32) Then arrKeys = arrKeys32
If (Not RetVal = 0) AND (RetVal64 = 0) AND IsArray(arrKeys64) Then arrKeys = arrKeys64
If (RetVal = 0) AND (RetVal64 = 0) Then 
If IsArray(arrKeys32) AND IsArray (arrKeys64) Then 
arrKeys = RemoveDuplicates(Split((Join(arrKeys32,"") & "" & Join(arrKeys64,"")),""))
ElseIf IsArray(arrKeys64) Then
arrKeys = arrKeys64
Else
arrKeys = arrKeys32
End If
End If
Else
RetVal = oReg.EnumKey(hDefKey,sSubKeyName,arrKeys)
End If 'f64
RegEnumKey = ((RetVal = 0) OR (RetVal64 = 0)) AND IsArray(arrKeys)
End Function 'RegEnumKey
'=======================================================================================================

'Wrapper around oReg.DeleteValue to handle 64 bit
Sub RegDeleteValue(hDefKey, sSubKeyName, sName, fRegMultiSZ)
Dim sWow64Key, sValue
Dim iRetVal

If dicKeepReg.Exists(LCase(sSubKeyName & sName)) Then
If NOT fForce Then
LogOnly " - Disallowing the delete of still required keypath element: " & HiveString(hDefKey) & "" & sSubKeyName & sName
Exit Sub
Else
LogOnly " - Enforced delete of still required keypath element. Remaining applications will need a repair!"
End If
End If
If f64 Then
If dicKeepReg.Exists(LCase(Wow64Key(hDefKey, sSubKeyName) & sName)) Then
If NOT fForce Then
LogOnly " - Disallowing the delete of still required keypath element: " & HiveString(hDefKey) & "" & sSubKeyName & sName
Exit Sub
Else
LogOnly " - Enforced delete of still required keypath element. Remaining applications will need a repair!"
End If
End If
End If

If RegValExists(hDefKey,sSubKeyName,sName) Then
On Error Resume Next
If RegReadValue(hDefKey,sSubKeyName,sName,sValue,"REG_MULTI_SZ") Then
LogOnly " - Disallowing unsafe delete of REG_MULTI_SZ: " & HiveString(hDefKey) & "" & sSubKeyName & sName
Exit Sub
End If
If Not fDetectOnly Then 
LogOnly " - Delete registry value: " & HiveString(hDefKey) & "" & sSubKeyName & " -> " & sName
iRetVal = 0
iRetVal = oReg.DeleteValue(hDefKey, sSubKeyName, sName)
CheckError "RegDeleteValue"
If NOT (iRetVal=0) Then LogOnly "     Delete failed. Return value: "&iRetVal
Else
LogOnly " - Simulate delete registry value: " & HiveString(hDefKey) & "" & sSubKeyName & " -> " & sName
End If
On Error Goto 0
End If 'RegValExists
If f64 Then 
sWow64Key = Wow64Key(hDefKey, sSubKeyName)
If RegValExists(hDefKey,sWow64Key,sName) Then
On Error Resume Next
If RegReadValue(hDefKey,sSubKeyName,sName,sValue,"REG_MULTI_SZ") Then
LogOnly " - Disallowing unsafe delete of REG_MULTI_SZ: " & HiveString(hDefKey) & "" & sSubKeyName & sName
Exit Sub
End If
If Not fDetectOnly Then 
LogOnly " - Delete registry value: " & HiveString(hDefKey) & "" & sWow64Key & " -> " & sName
iRetVal = 0
iRetVal = oReg.DeleteValue(hDefKey, sWow64Key, sName)
CheckError "RegDeleteValue"
If NOT (iRetVal=0) Then LogOnly "     Delete failed. Return value: "&iRetVal
Else
LogOnly " - Simulate delete registry value: " & HiveString(hDefKey) & "" & sWow64Key & " -> " & sName
End If
On Error Goto 0
End If 'RegKeyExists
End If
End Sub 'RegDeleteValue
'=======================================================================================================

'Wrappper around RegDeleteKeyEx to handle 64bit scenrios
Sub RegDeleteKey(hDefKey, sSubKeyName)
Dim sWow64Key

'Ensure trailing ""
sSubKeyName = sSubKeyName & ""
While InStr(sSubKeyName,"\")>0
sSubKeyName = Replace(sSubKeyName,"\","")
Wend

If dicKeepReg.Exists(LCase(sSubKeyName)) Then
If NOT fForce Then
LogOnly " - Disallowing the delete of still required keypath element: " & HiveString(hDefKey) & "" & sSubKeyName
Exit Sub
Else
LogOnly " - Enforced delete of still required keypath element. Remaining applications will need a repair!"
End If
End If
If f64 Then
If dicKeepReg.Exists(LCase(Wow64Key(hDefKey, sSubKeyName))) Then
If NOT fForce Then
LogOnly " - Disallowing the delete of still required keypath element: " & HiveString(hDefKey) & "" & sSubKeyName
Exit Sub
Else
LogOnly " - Enforced delete of still required keypath element. Remaining applications will need a repair!"
End If
End If
End If

If Len(sSubKeyName) > 1 Then
'Strip of trailing ""
sSubKeyName = Left(sSubKeyName,Len(sSubKeyName)-1)
End If

If RegKeyExists(hDefKey, sSubKeyName) Then
If Not fDetectOnly Then
LogOnly " - Delete registry key: " & HiveString(hDefKey) & "" & sSubKeyName
On Error Resume Next
RegDeleteKeyEx hDefKey, sSubKeyName
On Error Goto 0
Else
LogOnly " - Simulate delete registry key: " & HiveString(hDefKey) & "" & sSubKeyName
End If
End If 'RegKeyExists
If f64 Then 
sWow64Key = Wow64Key(hDefKey, sSubKeyName)
If RegKeyExists(hDefKey,sWow64Key) Then
If Not fDetectOnly Then
LogOnly " - Delete registry key: " & HiveString(hDefKey) & "" & sWow64Key
On Error Resume Next
RegDeleteKeyEx hDefKey, sWow64Key
On Error Goto 0
Else
LogOnly " - Simulate delete registry key: " & HiveString(hDefKey) & "" & sWow64Key
End If
End If 'RegKeyExists
End If
End Sub 'RegDeleteKey
'=======================================================================================================

'Recursively delete a registry structure
Sub RegDeleteKeyEx(hDefKey, sSubKeyName) 
Dim arrSubkeys
Dim sSubkey
Dim iRetVal

On Error Resume Next
oReg.EnumKey hDefKey, sSubKeyName, arrSubkeys
If IsArray(arrSubkeys) Then 
For Each sSubkey In arrSubkeys 
RegDeleteKeyEx hDefKey, sSubKeyName & "" & sSubkey 
Next 
End If 
If Not fDetectOnly Then 
iRetVal = 0
iRetVal = oReg.DeleteKey(hDefKey,sSubKeyName)
If NOT (iRetVal=0) Then LogOnly "     Delete failed. Return value: "&iRetVal
End If
End Sub 'RegDeleteKeyEx
'=======================================================================================================

'Return the alternate regkey location on 64bit environment
Function Wow64Key(hDefKey, sSubKeyName)
Dim iPos

Select Case hDefKey
Case HKCU
If Left(sSubKeyName,17) = "SoftwareClasses" Then
Wow64Key = Left(sSubKeyName,17) & "Wow6432Node" & Right(sSubKeyName,Len(sSubKeyName)-17)
Else
iPos = InStr(sSubKeyName,"")
Wow64Key = Left(sSubKeyName,iPos) & "Wow6432Node" & Right(sSubKeyName,Len(sSubKeyName)-iPos)
End If

Case HKLM
If Left(sSubKeyName,17) = "SoftwareClasses" Then
Wow64Key = Left(sSubKeyName,17) & "Wow6432Node" & Right(sSubKeyName,Len(sSubKeyName)-17)
Else
iPos = InStr(sSubKeyName,"")
Wow64Key = Left(sSubKeyName,iPos) & "Wow6432Node" & Right(sSubKeyName,Len(sSubKeyName)-iPos)
End If

Case Else
Wow64Key = "Wow6432Node" & sSubKeyName

End Select 'hDefKey
End Function 'Wow64Key
'=======================================================================================================

'Remove duplicate entries from a one dimensional array
Function RemoveDuplicates(Array)
Dim Item
Dim oDic

Set oDic = CreateObject("Scripting.Dictionary")
For Each Item in Array
If Not oDic.Exists(Item) Then oDic.Add Item,Item
Next 'Item
RemoveDuplicates = oDic.Keys
End Function 'RemoveDuplicates
'=======================================================================================================

'End running instances of setup
Sub EndCurrentInstalls ()
Dim Processes, Process
Dim iRet

Set Processes = oWmiLocal.ExecQuery("Select * From Win32_Process Where Name like '%setup%' OR Name like '%install%'")
For Each Process in Processes
Log " - End process " & Process.Name
iRet = Process.Terminate()
CheckError "EndCurrentInstalls: " & "Process.Name"
Next 'Process
StopService "msiserver"
End Sub 'EndCurrentInstalls
'=======================================================================================================

'Uses WMI to stop a service
Function StopService(sService)
Dim Services, Service
Dim sQuery
Dim iRet

On Error Resume Next

iRet = 0
sQuery = "Select * From Win32_Service Where Name='" & sService & "'"
Set Services = oWmiLocal.Execquery(sQuery)
'Stop the service
For Each Service in Services
If UCase(Service.State) = "STARTED" Then iRet = Service.StopService
If UCase(Service.State) = "RUNNING" Then iRet = Service.StopService

Next 'Service
StopService = (iRet = 0)
End Function 'StopService
'=======================================================================================================

'Delete a service
Sub DeleteService(sService)
Dim Services, Service, Processes, Process
Dim sQuery, sStates
Dim iRet

On Error Resume Next

sStates = "STARTED;RUNNING"
sQuery = "Select * From Win32_Service Where Name='" & sService & "'"
Set Services = oWmiLocal.Execquery(sQuery)

'Stop and delete the service
For Each Service in Services
Log " Found service " & sService & " in state " & Service.State
If InStr(sStates,UCase(Service.State))>0 Then iRet = Service.StopService()
'Ensure no more instances of the service are running
Set Processes = oWmiLocal.ExecQuery("Select * From Win32_Process Where Name='" & sService & ".exe'")
For Each Process in Processes
iRet = Process.Terminate()
Next 'Process
If Not fDetectOnly Then 
Log " - Deleting Service -> " & sService
iRet = Service.Delete()
Else
Log " - Simulate deleting Service -> " & sService
End If
Next 'Service
Set Services = Nothing
Err.Clear

End Sub 'DeleteService
'=======================================================================================================

'Translation for setup.exe error codes
Function SetupRetVal(RetVal)
Select Case RetVal
Case 0 : SetupRetVal = "Success"
Case 30001,1 : SetupRetVal = "AbstractMethod"
Case 30002,2 : SetupRetVal = "ApiProhibited"
Case 30003,3  : SetupRetVal = "AlreadyImpersonatingAUser"
Case 30004,4 : SetupRetVal = "AlreadyInitialized"
Case 30005,5 : SetupRetVal = "ArgumentNullException"
Case 30006,6 : SetupRetVal = "AssertionFailed"
Case 30007,7 : SetupRetVal = "CABFileAddFailed"
Case 30008,8 : SetupRetVal = "CommandFailed"
Case 30009,9 : SetupRetVal = "ConcatenationFailed"
Case 30010,10 : SetupRetVal = "CopyFailed"
Case 30011,11 : SetupRetVal = "CreateEventFailed"
Case 30012,12 : SetupRetVal = "CustomizationPatchNotFound"
Case 30013,13 : SetupRetVal = "CustomizationPatchNotApplicable"
Case 30014,14 : SetupRetVal = "DuplicateDefinition"
Case 30015,15 : SetupRetVal = "ErrorCodeOnly - Passthrough for Win32 error"
Case 30016,16 : SetupRetVal = "ExceptionNotThrown"
Case 30017,17 : SetupRetVal = "FailedToImpersonateUser"
Case 30018,18 : SetupRetVal = "FailedToInitializeFlexDataSource"
Case 30019,19 : SetupRetVal = "FailedToStartClassFactories"
Case 30020,20 : SetupRetVal = "FileNotFound"
Case 30021,21 : SetupRetVal = "FileNotOpen"
Case 30022,22 : SetupRetVal = "FlexDialogAlreadyInitialized"
Case 30023,23 : SetupRetVal = "HResultOnly - Passthrough for HRESULT errors"
Case 30024,24 : SetupRetVal = "HWNDNotFound"
Case 30025,25 : SetupRetVal = "IncompatibleCacheAction"
Case 30026,26 : SetupRetVal = "IncompleteProductAddOns"
Case 30027,27 : SetupRetVal = "InstalledProductStateCorrupt"
Case 30028,28 : SetupRetVal = "InsufficientBuffer"
Case 30029,29 : SetupRetVal = "InvalidArgument"
Case 30030,30 : SetupRetVal = "InvalidCDKey"
Case 30031,31 : SetupRetVal = "InvalidColumnType"
Case 30032,31 : SetupRetVal = "InvalidConfigAddLanguage"
Case 30033,33 : SetupRetVal = "InvalidData"
Case 30034,34 : SetupRetVal = "InvalidDirectory"
Case 30035,35 : SetupRetVal = "InvalidFormat"
Case 30036,36 : SetupRetVal = "InvalidInitialization"
Case 30037,37 : SetupRetVal = "InvalidMethod"
Case 30038,38 : SetupRetVal = "InvalidOperation"
Case 30039,39 : SetupRetVal = "InvalidParameter"
Case 30040,40 : SetupRetVal = "InvalidProductFromARP"
Case 30041,41 : SetupRetVal = "InvalidProductInConfigXml"
Case 30042,42 : SetupRetVal = "InvalidReference"
Case 30043,43 : SetupRetVal = "InvalidRegistryValueType"
Case 30044,44 : SetupRetVal = "InvalidXMLProperty"
Case 30045,45 : SetupRetVal = "InvalidMetadataFile"
Case 30046,46 : SetupRetVal = "LogNotInitialized"
Case 30047,47 : SetupRetVal = "LogAlreadyInitialized"
Case 30048,48 : SetupRetVal = "MissingXMLNode"
Case 30049,49 : SetupRetVal = "MsiTableNotFound"
Case 30050,50 : SetupRetVal = "MsiAPICallFailure"
Case 30051,51 : SetupRetVal = "NodeNotOfTypeElement"
Case 30052,52 : SetupRetVal = "NoMoreGraceBoots"
Case 30053,53 : SetupRetVal = "NoProductsFound"
Case 30054,54 : SetupRetVal = "NoSupportedCulture"
Case 30055,55 : SetupRetVal = "NotYetImplemented"
Case 30056,56 : SetupRetVal = "NotAvailableCulture"
Case 30057,57 : SetupRetVal = "NotCustomizationPatch"
Case 30058,58 : SetupRetVal = "NullReference"
Case 30059,59 : SetupRetVal = "OCTPatchForbidden"
Case 30060,60 : SetupRetVal = "OCTWrongMSIDll"
Case 30061,61 : SetupRetVal = "OutOfBoundsIndex"
Case 30062,62 : SetupRetVal = "OutOfDiskSpace"
Case 30063,63 : SetupRetVal = "OutOfMemory"
Case 30064,64 : SetupRetVal = "OutOfRange"
Case 30065,65 : SetupRetVal = "PatchApplicationFailure"
Case 30066,66 : SetupRetVal = "PreReqCheckFailure"
Case 30067,67 : SetupRetVal = "ProcessAlreadyStarted"
Case 30068,68 : SetupRetVal = "ProcessNotStarted"
Case 30069,69 : SetupRetVal = "ProcessNotFinished"
Case 30070,70 : SetupRetVal = "ProductAlreadyDefined"
Case 30071,71 : SetupRetVal = "ResourceAlreadyTracked"
Case 30072,72 : SetupRetVal = "ResourceNotFound"
Case 30073,73 : SetupRetVal = "ResourceNotTracked"
Case 30074,74 : SetupRetVal = "SQLAlreadyConnected"
Case 30075,75 : SetupRetVal = "SQLFailedToAllocateHandle"
Case 30076,76 : SetupRetVal = "SQLFailedToConnect"
Case 30077,77 : SetupRetVal = "SQLFailedToExecuteStatement"
Case 30078,78 : SetupRetVal = "SQLFailedToRetrieveData"
Case 30079,79 : SetupRetVal = "SQLFailedToSetAttribute"
Case 30080,80 : SetupRetVal = "StorageNotCreated"
Case 30081,81 : SetupRetVal = "StreamNameTooLong"
Case 30082,82 : SetupRetVal = "SystemError"
Case 30083,83 : SetupRetVal = "ThreadAlreadyStarted"
Case 30084,84 : SetupRetVal = "ThreadNotStarted"
Case 30085,85 : SetupRetVal = "ThreadNotFinished"
Case 30086,86 : SetupRetVal = "TooManyProducts"
Case 30087,87 : SetupRetVal = "UnexpectedXMLNodeType"
Case 30088,88 : SetupRetVal = "UnexpectedError"
Case 30089,89 : SetupRetVal = "Unitialized"
Case 30090,90 : SetupRetVal = "UserCancel"
Case 30091,91 : SetupRetVal = "ExternalCommandFailed"
Case 30092,92 : SetupRetVal = "SPDatabaseOverSize"
Case 30093,93 : SetupRetVal = "IntegerTruncation"
'msiexec return values
Case 1259 : SetupRetVal = "APPHELP_BLOCK"
Case 1601 : SetupRetVal = "INSTALL_SERVICE_FAILURE"
Case 1602 : SetupRetVal = "INSTALL_USEREXIT"
Case 1603 : SetupRetVal = "INSTALL_FAILURE"
Case 1604 : SetupRetVal = "INSTALL_SUSPEND"
Case 1605 : SetupRetVal = "UNKNOWN_PRODUCT"
Case 1606 : SetupRetVal = "UNKNOWN_FEATURE"
Case 1607 : SetupRetVal = "UNKNOWN_COMPONENT"
Case 1608 : SetupRetVal = "UNKNOWN_PROPERTY"
Case 1609 : SetupRetVal = "INVALID_HANDLE_STATE"
Case 1610 : SetupRetVal = "BAD_CONFIGURATION"
Case 1611 : SetupRetVal = "INDEX_ABSENT"
Case 1612 : SetupRetVal = "INSTALL_SOURCE_ABSENT"
Case 1613 : SetupRetVal = "INSTALL_PACKAGE_VERSION"
Case 1614 : SetupRetVal = "PRODUCT_UNINSTALLED"
Case 1615 : SetupRetVal = "BAD_QUERY_SYNTAX"
Case 1616 : SetupRetVal = "INVALID_FIELD"
Case 1618 : SetupRetVal = "INSTALL_ALREADY_RUNNING"
Case 1619 : SetupRetVal = "INSTALL_PACKAGE_OPEN_FAILED"
Case 1620 : SetupRetVal = "INSTALL_PACKAGE_INVALID"
Case 1621 : SetupRetVal = "INSTALL_UI_FAILURE"
Case 1622 : SetupRetVal = "INSTALL_LOG_FAILURE"
Case 1623 : SetupRetVal = "INSTALL_LANGUAGE_UNSUPPORTED"
Case 1624 : SetupRetVal = "INSTALL_TRANSFORM_FAILURE"
Case 1625 : SetupRetVal = "INSTALL_PACKAGE_REJECTED"
Case 1626 : SetupRetVal = "FUNCTION_NOT_CALLED"
Case 1627 : SetupRetVal = "FUNCTION_FAILED"
Case 1628 : SetupRetVal = "INVALID_TABLE"
Case 1629 : SetupRetVal = "DATATYPE_MISMATCH"
Case 1630 : SetupRetVal = "UNSUPPORTED_TYPE"
Case 1631 : SetupRetVal = "CREATE_FAILED"
Case 1632 : SetupRetVal = "INSTALL_TEMP_UNWRITABLE"
Case 1633 : SetupRetVal = "INSTALL_PLATFORM_UNSUPPORTED"
Case 1634 : SetupRetVal = "INSTALL_NOTUSED"
Case 1635 : SetupRetVal = "PATCH_PACKAGE_OPEN_FAILED"
Case 1636 : SetupRetVal = "PATCH_PACKAGE_INVALID"
Case 1637 : SetupRetVal = "PATCH_PACKAGE_UNSUPPORTED"
Case 1638 : SetupRetVal = "PRODUCT_VERSION"
Case 1639 : SetupRetVal = "INVALID_COMMAND_LINE"
Case 1640 : SetupRetVal = "INSTALL_REMOTE_DISALLOWED"
Case 1641 : SetupRetVal = "SUCCESS_REBOOT_INITIATED"
Case 1642 : SetupRetVal = "PATCH_TARGET_NOT_FOUND"
Case 1643 : SetupRetVal = "PATCH_PACKAGE_REJECTED"
Case 1644 : SetupRetVal = "INSTALL_TRANSFORM_REJECTED"
Case 1645 : SetupRetVal = "INSTALL_REMOTE_PROHIBITED"
Case 1646 : SetupRetVal = "PATCH_REMOVAL_UNSUPPORTED"
Case 1647 : SetupRetVal = "UNKNOWN_PATCH"
Case 1648 : SetupRetVal = "PATCH_NO_SEQUENCE"
Case 1649 : SetupRetVal = "PATCH_REMOVAL_DISALLOWED"
Case 1650 : SetupRetVal = "INVALID_PATCH_XML"
Case 3010 : SetupRetVal = "SUCCESS_REBOOT_REQUIRED"
Case Else : SetupRetVal = "Unknown Return Value"
End Select
End Function 'SetupRetVal
'=======================================================================================================

Function GetProductID(sProdID)
Dim sReturn

Select Case sProdId

Case "000F" : sReturn = "MONDO"
Case "0010" : sReturn = "WEBFLDRS"
Case "0011" : sReturn = "PROPLUS"
Case "0012" : sReturn = "STANDARD"
Case "0013" : sReturn = "BASIC"
Case "0014" : sReturn = "PRO"
Case "0015" : sReturn = "ACCESS"
Case "0016" : sReturn = "EXCEL"
Case "0017" : sReturn = "SharePointDesigner"
Case "0018" : sReturn = "PowerPoint"
Case "0019" : sReturn = "Publisher"
Case "001A" : sReturn = "Outlook"
Case "001B" : sReturn = "Word"
Case "001C" : sReturn = "AccessRuntime"
Case "001F" : sReturn = "Proof"
Case "0020" : sReturn = "O2007CNV"
Case "0021" : sReturn = "VisualWebDeveloper"
Case "0026" : sReturn = "ExpressionWeb"
Case "0029" : sReturn = "Excel"
Case "002A" : sReturn = "Office64"
Case "002B" : sReturn = "Word"
Case "002C" : sReturn = "Proofing"
Case "002E" : sReturn = "Ultimate"
Case "002F" : sReturn = "HomeAndStudent"
Case "0028" : sReturn = "IME"
Case "0030" : sReturn = "Enterprise"
Case "0031" : sReturn = "ProfessionalHybrid"
Case "0033" : sReturn = "Personal"
Case "0035" : sReturn = "ProfessionalHybrid"
Case "0037" : sReturn = "PowerPoint"
Case "003A" : sReturn = "PrjStd"
Case "003B" : sReturn = "PrjPro"
Case "003D" : sReturn = "SINGLEIMAGE"
Case "0043" : sReturn = "OFFICE32"
Case "0044" : sReturn = "InfoPath"
Case "0045" : sReturn = "XWEB"
Case "0048" : sReturn = "OLC"
Case "0049" : sReturn = "ACADEMIC"
Case "004A" : sReturn = "OWC11"
Case "0051" : sReturn = "VISPRO"
Case "0052" : sReturn = "VisView"
Case "0053" : sReturn = "VisStd"
Case "0054" : sReturn = "VisMUI"
Case "0055" : sReturn = "VisMUI"
Case "0057" : sReturn = "VISIO"
Case "0061" : sReturn = "CLICK2RUN"
Case "0062" : sReturn = "CLICK2RUN"
Case "0066" : sReturn = "CLICK2RUN"
Case "006C" : sReturn = "CLICK2RUN"
Case "006D" : sReturn = "CLICK2RUN"
Case "006E" : sReturn = "Shared"
Case "006F" : sReturn = "OFFICE"
Case "0070" : sReturn = "OOBE"
Case "0074" : sReturn = "STARTER"
Case "007A" : sReturn = "OLC" 'Outlook Connector
Case "007C" : sReturn = "OSCFB" 'Outlook Social Connector for FaceBook
Case "007D" : sReturn = "OSCWL" 'Outlook Social Connector for Windows Live Messenger
Case "007F" : sReturn = "OLC" 'Outlook Social Connector
Case "008A" : sReturn = "RecentDocs"
Case "008B" : sReturn = "SmallBusinessBasics"
Case "00A1" : sReturn = "ONENOTE"
Case "00A3" : sReturn = "OneNoteHomeStudent"
Case "00A7" : sReturn = "CPAO"
Case "00A9" : sReturn = "InterConnect"
Case "00AF" : sReturn = "PPtView"
Case "00B0" : sReturn = "ExPdf"
Case "00B1" : sReturn = "ExXps"
Case "00B2" : sReturn = "ExPdfXps"
Case "00B4" : sReturn = "PrjMUI"
Case "00B5" : sReturn = "PrjtMUI"
Case "00B9" : sReturn = "AER"
Case "00BA" : sReturn = "Groove"
Case "00CA" : sReturn = "SmallBusiness"
Case "00E0" : sReturn = "Outlook"
Case "00D1" : sReturn = "ACE"
Case "0100" : sReturn = "OfficeMUI"
Case "0101" : sReturn = "OfficeXMUI"
Case "0103" : sReturn = "PTK"
Case "0114" : sReturn = "GrooveSetupMetadata"
Case "0115" : sReturn = "SharedSetupMetadata"
Case "0116" : sReturn = "SharedSetupMetadata"
Case "0117" : sReturn = "AccessSetupMetadata"
Case "011A" : sReturn = "SendASmile"
Case "011D" : sReturn = "ProPlusSubscription"
Case "011F" : sReturn = "OLConnect"
Case "0126" : sReturn = "WWLIBCXM"

Case "1014" : sReturn = "STS"
Case "1015" : sReturn = "WSSMUI"
Case "1032" : sReturn = "PJSVRAPP"
Case "104B" : sReturn = "SPS"
Case "104E" : sReturn = "SPSMUI"
Case "107F" : sReturn = "OSrv"
Case "1080" : sReturn = "OSrv"
Case "1088" : sReturn = "lpsrvwfe"
Case "10D7" : sReturn = "IFS"
Case "10D8" : sReturn = "IFSMUI"
Case "10EB" : sReturn = "DLCAPP"
Case "10F5" : sReturn = "XLSRVAPP"
Case "10F6" : sReturn = "XlSrvWFE"
Case "10F7" : sReturn = "DLC"
Case "10F8" : sReturn = "SlSrvMui"
Case "10FB" : sReturn = "OSrchWFE"
Case "10FC" : sReturn = "OSRCHAPP"
Case "10FD" : sReturn = "OSrchMUI"
Case "1103" : sReturn = "DLC"
Case "1104" : sReturn = "LHPSRV"
Case "1105" : sReturn = "PIA"
Case "1106" : sReturn = "GRVMGMTSRV"
Case "1109" : sReturn = "GSERVERRELAY"
Case "110D" : sReturn = "OSERVER"
Case "110F" : sReturn = "PSERVER"
Case "1110" : sReturn = "WSS"
Case "1121" : sReturn = "SPSSDK"
Case "1122" : sReturn = "SPSDev"
Case "1163" : sReturn = "SCC" 'SharePoint Client Components
Case Else : sReturn = sProdID

End Select 'sProdId
GetProductID = sReturn
End Function 'GetProductID
'=======================================================================================================

Sub Log (sLog)
wscript.echo sLog
LogStream.WriteLine sLog
End Sub 'Log
'=======================================================================================================

Sub LogOnly (sLog)
LogStream.WriteLine sLog
End Sub 'Log
'=======================================================================================================

Sub CheckError(sModule)
If Err <> 0 Then 
LogOnly "   " & Now & " - " & sModule & " - Source: " & Err.Source & "; Err# (Hex): " & Hex( Err ) & _
"; Err# (Dec): " & Err & "; Description : " & Err.Description
End If 'Err = 0
Err.Clear
End Sub
'=======================================================================================================

'Command line parser
Sub ParseCmdLine

Dim iCnt, iArgCnt
Dim arrArguments
Dim sArg0

iArgCnt = Wscript.Arguments.Count
If iArgCnt > 0 Then
If wscript.Arguments(0) = "UAC" Then
If wscript.arguments.count = 1 Then iArgCnt = 0
End If
End If
If iArgCnt = 0 Then
Select Case UCase(wscript.ScriptName)
Case Else
'Create the log
CreateLog
Log "No argument specified. Preparing user prompt" & vbCrLf
FindInstalledOProducts
If dicInstalledSku.Count > 0 Then sDefault = Join(RemoveDuplicates(dicInstalledSku.Items),",") Else sDefault = "CLIENTALL"
sDefault = InputBox("Enter a list of " & ONAME & " products to remove" & vbCrLf & vbCrLf & _
"Examples:" & vbCrLf & _
"CLIENTALL" & vbTab & "-> all Client products" & vbCrLf & _
"SERVER" & vbTab & "-> all Server products" & vbCrLf & _
"ALL" & vbTab & vbTab & "-> all Server & Client products" & vbCrLf & _
"ProPlus,PrjPro" & vbTab & "-> ProPlus and Project" & vbCrLf &_
"?" & vbTab & vbTab & "-> display Help", _
SCRIPTFILE & " - " & ONAME & " remover", _
sDefault)

If IsEmpty(sDefault) Then 'User cancelled
Log "User cancelled. CleanUp & Exit."
'Undo temporary entries created in ARP
TmpKeyCleanUp
wscript.quit 1602
End If 'IsEmpty(sDefault)
Log "Answer from prompt: " & sDefault & vbCrLf
sDefault = Trim(UCase(Trim(Replace(sDefault,Chr(34),""))))
arrArguments = Split(Trim(sDefault)," ")
If UBound(arrArguments) = -1 Then ReDim arrArguments(0)
End Select
Else
ReDim arrArguments(iArgCnt-1)
For iCnt = 0 To (iArgCnt-1)
arrArguments(iCnt) = UCase(Wscript.Arguments(iCnt))
Next 'iCnt
End If 'iArgCnt = 0

'Handle the SKU list
sArg0 = Replace(arrArguments(0),"/","")
If Left(sArg0,1) = "-" Then sArg0 = Mid(sArg0,2)

Select Case UCase(sArg0)

Case "?"
ShowSyntax

Case "ALL"
fRemoveAll = True
fRemoveOse = False

Case "CLIENTSUITES"
fRemoveCSuites = True
fRemoveOse = False

Case "CLIENTSTANDALONE"
fRemoveCSingle = True
fRemoveOse = False

Case "CLIENTALL"
fRemoveCSuites = True
fRemoveCSingle = True
fRemoveOse = False

Case "SERVER"
fRemoveSrv = True
fRemoveOse = False

Case "ALL,OSE"
fRemoveAll = True
fRemoveOse = True

Case Else
fRemoveAll = False
fRemoveOse = False
sSkuRemoveList = sArg0

End Select

For iCnt = 0 To UBound(arrArguments)

Select Case arrArguments(iCnt)

Case "?","/?","-?"
ShowSyntax

Case "/B","/BYPASS"
If UBound(arrArguments)>iCnt Then
If InStr(arrArguments(iCnt+1),"1")>0 Then fBypass_Stage1 = True
If InStr(arrArguments(iCnt+1),"2")>0 Then fBypass_Stage2 = True
If InStr(arrArguments(iCnt+1),"3")>0 Then fBypass_Stage3 = True
If InStr(arrArguments(iCnt+1),"4")>0 Then fBypass_Stage4 = True
End If

Case "/D","/DELETEUSERSETTINGS"
fKeepUser = False

Case "/FR","/FASTREMOVE"
fBypass_Stage1 = True
fSkipSD = True

Case "/F","/FORCE"
fForce = True

Case "/K","/KEEPUSERSETTINGS"
fKeepUser = True

Case "/L","/LOG"
fLogInitialized = False
If UBound(arrArguments)>iCnt Then
If oFso.FolderExists(arrArguments(iCnt+1)) Then 
sLogDir = arrArguments(iCnt+1)
Else
On Error Resume Next
oFso.CreateFolder(arrArguments(iCnt+1))
If Err <> 0 Then sLogDir = sScrubDir Else sLogDir = arrArguments(iCnt+1)
End If
End If

Case "/N","/NOCANCEL"
fNoCancel = True

Case "/NE","/NOELEVATE"
fNoElevate = True

Case "/O","/OSE"
fRemoveOse = True

Case "/P","/PREVIEW","/DETECTONLY"
fDetectOnly = True

Case "/Q","/QUIET"
fQuiet = True

Case "/QB"
fQuiet = True
fBasic = True

Case "/QND"
fBypass_Stage1 = True
fBypass_Stage2 = True
fBypass_Stage3 = True
fRemoveOse = True
fRemoveOspp = True
fRemoveAll = True
fSkipSD = True
fForce = True

Case "/S","/SKIPSD","/SKIPSHORTCUTDETECTION"
fSkipSD = True

Case "/R","/RECONCILE"
fTryReconcile = True

Case Else

End Select
Next 'iCnt
If Not fLogInitialized Then CreateLog

End Sub 'ParseCmdLine
'=======================================================================================================

Sub CreateLog
Dim DateTime
Dim sLogName

On Error Resume Next
'Create the log file
Set DateTime = CreateObject("WbemScripting.SWbemDateTime")
DateTime.SetVarDate Now,True
sLogName = sLogDir & "" & oWShell.ExpandEnvironmentStrings("%COMPUTERNAME%")
sLogName = sLogName &  "_" & Left(DateTime.Value,14)
sLogName = sLogName & "_ScrubLog.txt"
Err.Clear
Set LogStream = oFso.CreateTextFile(sLogName,True,True)
If Err <> 0 Then 
Err.Clear
sLogDir = sScrubDir
sLogName = sLogDir & "" & oWShell.ExpandEnvironmentStrings("%COMPUTERNAME%")
sLogName = sLogName &  "_" & Left(DateTime.Value,14)
sLogName = sLogName & "_ScrubLog.txt"
Set LogStream = oFso.CreateTextFile(sLogName,True,True)
End If

Log "Microsoft Customer Support Services - " & ONAME & " Removal Utility" & vbCrLf & vbCrLf & _
"OffScrub Version: " & SCRIPTVERSION & vbCrLf & _
"64 bit OS: " & f64
LogOnly     "OS Details: " & sOSinfo & vbCrLf
Log         "Start removal: " & Now & vbCrLf
fLogInitialized = True
End Sub 'CreateLog
'=======================================================================================================

Sub RelaunchAsCScript
Dim Argument
Dim sCmdLine

sCmdLine = "cmd.exe /k " & WScript.Path & "cscript.exe //NOLOGO " & Chr(34) & WScript.scriptFullName & Chr(34)
If Wscript.Arguments.Count > 0 Then
For Each Argument in Wscript.Arguments
sCmdLine = sCmdLine  &  " " & chr(34) & Argument & chr(34)
Next 'Argument
End If
oWShell.Run sCmdLine,1,False
Wscript.Quit
End Sub 'RelaunchAsCScript
'=======================================================================================================

Sub RelaunchElevated
Dim Argument
Dim sCmdLine
Dim oShell

Set oShell = CreateObject("Shell.Application")

sCmdLine = Chr(34) & WScript.scriptFullName & Chr(34)
If Wscript.Arguments.Count > 0 Then
For Each Argument in Wscript.Arguments
Select Case UCase(Argument)
Case "/Q","/QUIET"
'Don't try to relaunch in quiet mode
Exit Sub
Case "UAC"
'Already tried elevated relaunch
Exit Sub
Case Else
sCmdLine = sCmdLine  &  " " & chr(34) & Argument & chr(34)
End Select
Next 'Argument
End If
oShell.ShellExecute "cscript.exe", sCmdLine & " /NoElevate UAC", "", "runas", 1
Wscript.Quit
End Sub 'RelaunchElevated
'=======================================================================================================

'Show the expected syntax for the script usage
Sub ShowSyntax
TmpKeyCleanUp
Wscript.Echo sErr & vbCrLf & _
SCRIPTFILE & " V " & SCRIPTVERSION & vbCrLf & _
"Copyright (c) Microsoft Corporation. All Rights Reserved" & vbCrLf & vbCrLf & _
SCRIPTFILE & " helps to remove " & ONAME & " Server & Client products" & vbCrLf & _
"when a regular uninstall is no longer possible" & vbCrLf & vbCrLf & _
"Usage:" & vbTab & SCRIPTFILE & " [List of config ProductIDs] [Options]" & vbCrLf & vbCrLf & _
vbTab & "/?                               ' Displays this help"& vbCrLf &_
vbTab & "/Force                           ' Enforces file removal. May cause data loss!" & vbCrLf &_
vbTab & "/SkipShortcutDetection           ' Does not search the local hard drives for shortcuts" & vbCrLf & _
vbTab & "/Log [LogfolderPath]             ' Custom folder for log files" & vbCrLf & _
vbTab & "/NoCancel                        ' Setup.exe and Msiexec.exe have no Cancel button" & vbCrLf &_
vbTab & "/OSE                             ' Forces removal of the Office Source Engine service" & vbCrLf &_
vbTab & "/Quiet                           ' Setup.exe and Msiexec.exe run quiet with no UI" & vbCrLf &_
vbTab & "/Preview                         ' Run this script to preview what would get removed"& vbCrLf & vbCrLf & _
"Examples:"& vbCrLf & _
vbTab & SCRIPTFILE & " CLIENTALL         ' Remove all " & ONAME & " Client products" & vbCrLf &_
vbTab & SCRIPTFILE & " SERVER            ' Remove all " & ONAME & " Server products" & vbCrLf &_
vbTab & SCRIPTFILE & " ALL               ' Remove all " & ONAME & " Server & Client products" & vbCrLf &_
vbTab & SCRIPTFILE & " ProPlus,PrjPro    ' Remove ProPlus and Project" & vbCrLf
Wscript.Quit
End Sub 'ShowSyntax
'=======================================================================================================

The 0xc004d307 is a Windows activation error. It appears that Windows activation entries are corrupted, or you’re not using the genuine copy of Microsoft Windows. We highly recommend our readers to use only legitimate copy and refrain from using pirated, illegal builds. This article shall be helpful to clear up the mess.

Download the Diagnostic

There are certain situations when missing entries in your registry and registry corruption causes this problem. Try running a registry scan to identify if there are any such issues.

1. Click the button below to download and install the Diagnostic
2. Perform a Registry scan and fix any problems detected.
3. Restart your computer.

Estimated Download Time: 10 Seconds

---

Change Product Key

Buy a new license key for your genuine copy from Microsoft. Use the licensing tool to reactivate Windows with a new license key.

For Windows 8.1/ 8:

1. Press Windows Key + X; select Control Panel.
2. Click System and Security | System.
3. Scroll down the next screen. Click “View details in Windows Activation” link under “Windows Activation” category.
4. It opens up a new page. Click “Activate with a new key” button.
5. Follow the on-screen instructions and then restart your PC.

For Windows 7:

1. Click Start; select Control Panel.
2. Go to System and Security | System.
3. In the new dialog that opens, scroll down and click “Change product key” link.
4. Follow the on-screen instructions and then restart the machine.

For Windows Vista:

1. Click Start, point to All Programs | Accessories.
2. Right-click Command Prompt; select Run as administrator.
3. In the new dialog that opens, execute following commands:

• slmgr.vbs -ipk <Your New Product Key>
• slmgr.vbs -ato

1. Restart your machine.

Reset Licensing Status

Using the SLMGR REARM command reset the licensing status of your device. Remember, CMD must be running as administrator with required system privileges. If you’re not logged in as administrator, switch user and login to the Administrator user account.

For Windows 8.1/ 8:

1. Press Windows Key + X; select Command Prompt (Admin).
2. In the new window that opens, type following command:

• For Windows 32 bit: SLMGR –REARM
• For Windows 64 bit: SLMGR /REARM

1. You have a confirmation prompt on your screen. Go ahead and click OK.
2. Exit Command Prompt and restart your machine.

For Windows 7/ Vista:

1. Click Start; type “CMD” in Search Box.
2. Right click the Keyword from Search Results; select Run as administrator option.
3. Refer Steps # 2-4 under Windows 8.1/ 8 user’s section.

Enable SkipRearm

Make sure you skip the Rearm feature by configuring the Registry correctly.

For Windows 8.1/ 8/ 7/ Vista:

1. Press Windows Key + R.
2. Type “RegEdit” and click OK.
3. Locate the following subkey:

• HKEY_LOCAL_MACHINESOFTWAREMicrosoftWindows NTCurrentVersionSoftwareProtectionPlatform

1. Double click “SkipRearm” and replace its value with “1”.
2. Click OK; exit out of the screen.
3. Reboot your machine for the changes to take effects.

Сброс тестового периода для терминального сервера Windows

Описание проблемы

Основанные на Windows терминальные сервера (сервера удаленных рабочих столов, и т. д.) требуют приобретения дополнительных лицензий, в противном случае терминальный сервер будет работать с пробном режиме — без каких-либо ограничений по функционалу, но только первые 180 дней. После того, как пройдут 180 дней, подключится к такому серверу пользователям не получится, поскольку он будет ругаться на отсутствие лицензий.

Сброс пробного периода

Однако, можно без проблем сбросить пробный период терминального сервера, достаточно выполнить несколько манипуляций в реестре Windows. Для этого, запускаем редактор реестра, и переходим в следующий раздел реестра:

В данном разделе реестра необходимо удалить значение реестра с названием начинающимся на L$RTMTIMEBOMB. , однако, скорее всего ничего не выйдет, поскольку по умолчанию у пользователей компьютера нет прав на внесение изменений в данном разделе. Для исправления данного недоразумения, необходимо открыть разрешения данного раздела, и сменить его владельца на Администраторы.

Делается это следующим образом:

1. На нужном разделе реестра нужно нажать правой кнопкой мыши, и в появившемся меню выбрать пункт «Разрешения».
   
2. Откроется список разрешений. В нем нужно нажать на кнопку «Дополнительно».
   
3. Откроются дополнительные параметры, где в самом верху будет написан владелец, а рядом будет кнопка «Изменить». Нажимаем на неё.
   
4. Откроется окошко, где нужно будет ввести имя группы администраторов — например «Administrators». Для корректировки названия в понятный системе формат следует нажать на кнопку «Проверить имена».
   
   Если все будет правильно, система подчеркнет название группы, после чего остается только выйти из всех ранее открытых окон, нажимая кнопки «ОК» (для применения новых разрешений).

После этого, остается только удалить значение реестра с названием L$RTMTIMEBOMB. , после чего перезагрузить сервер. Если все было сделано правильно, то пробный период будет активирован по новой, и пользователи смогут работать на данном сервере как раньше.

Windows Server 2016 Evaluation Edition: сброс триала, upgrade до Standart/Datacenter

Версия для оценки Windows Server 2016 Evaluation Edition доступна для скачивания с официального сайта Microsoft. Версия имеет полный функционал и нормально работает в течении триального периода (180 дней).Беда заключается в том, что по истечении триального периода сервер пишет в логи:

Процесс C:Windowssystem32wlmswlms.exe ( ) инициировал действие «Завершить работу» для компьютера от имени пользователя NT AUTHORITYСИСТЕМА по причине: Другое (Запланированное)
Код причины: 0x80000000
Тип выключения: Завершить работу
Комментарий: Истек срок действия лицензии для этой установки Windows. Компьютер завершает работу.

Такая ситуация имеет два варианта решения: Вариант 1 (не правильный) — сбросить триальный период. Вариант 2 (правильный) — обновить до нормальной версии и активировать через KMS-сервер или с помощью MAK/Retail ключа.

Вариант 1. Сброс триала.

Запускаем Powershell и вводим команду:

Дожидаемся сообщения «Command completed successfully» и перезагружаем сервер.

Вариант 2. Upgrade до Standard/Datacenter.

Проверяем что стоит Evaluation Edition.

Должно быть: Current Edition ServerStandardEval.

Смотрим список доступных версий

Выбираем нужную версию и выполняем апгдейд с помощью общедоступного KMS-ключа.

Для версии Standard:

Для версии Datacenter:

Далее можно активировать операционку через KMS-сервер либо MAK/Retail ключом.

Хочу Знать

Версия для оценки Windows Server 2016 Evaluation Edition доступна для скачивания с официального сайта Microsoft. Версия имеет полный функционал и нормально работает в течении триального периода (180 дней).Беда заключается в том, что по истечении триального периода сервер пишет в логи:

Процесс C:Windowssystem32wlmswlms.exe ( ) инициировал действие «Завершить работу» для компьютера от имени пользователя NT AUTHORITYСИСТЕМА по причине: Другое (Запланированное)
Код причины: 0x80000000
Тип выключения: Завершить работу
Комментарий: Истек срок действия лицензии для этой установки Windows. Компьютер завершает работу.

Такая ситуация имеет два варианта решения: Вариант 1 (не правильный) — сбросить триальный период. Вариант 2 (правильный) — обновить до нормальной версии и активировать через KMS-сервер или с помощью MAK/Retail ключа.

Вариант 1. Сброс триала.

Запускаем Powershell и вводим команду:

Дожидаемся сообщения «Command completed successfully» и перезагружаем сервер.

Вариант 2. Upgrade до Standard/Datacenter.

Проверяем что стоит Evaluation Edition.

Должно быть: Current Edition ServerStandardEval.

Смотрим список доступных версий

Выбираем нужную версию и выполняем апгдейд с помощью общедоступного KMS-ключа.

Для версии Standard:

Для версии Datacenter:

Далее можно активировать операционку через KMS-сервер либо MAK/Retail ключом.

Для преобразования Windows Server 2019 EVAL в полноценную версию нужно использовать GVLK (KMS) ключи для Windows Server 2019. В остальном процедура аналогичная.

Конвертировать Windows Server 2019 Evaluation в Windows Server 2019 Standard:

dism /online /set-edition:ServerStandard /productkey: N69G4-B89J2-4G8F4-WWYCC-J464C /accepteula

Конвертировать Windows Server 2019 Evaluation в Windows Server 2019 Datacenter:

dism /online /set-edition:ServerDatacenter /productkey:WMDGN-G9PQG-XVVXX-R3X43-63DFG /accepteula

Как изменить, удалить или продлить лицензию Windows

Активация Windows — достаточно простая и понятная процедура (ну хотя бы более менее), чем то, что мы собираемся рассмотреть далее в этой статье. Как быть, если вы хотите сделать с лицензией что-то более продвинутое и сложное, например, такие вещи как, как удалить/изменить ключ продукта, выполнить онлайн активацию или продлить время активации. Это не так просто как простая активация, которая выполняется стандартными средствами ОС с удобным графическим интерфейсом, но и не так сложно. В этой статье я дам вам информацию, как и с помощью чего это можно сделать.

Существует инструмент командной строки, называемый Slmgr.vbs, входящий в состав Windows и предоставляющий возможности, недоступные в стандартном интерфейсе активации, который находиться в окне «Обновление и безопасность» до которого можно дойти, открыв меню Пуск и выбрав Параметры.

Во-первых: откройте командную строку с правами администратора

Для использование Slmgr.vbs это необходимо. В Windows 10 или 8 щелкните правой кнопкой мыши по кнопке Пуск (или сочетание клавиш Win + X) и выберите «Командная строка (администратор)». В Windows 7 найдите командную строку в меню Пуск, в списке Все программы > Служебные. Нажмите на нее правой кнопкой и выберите «Запустить от имени администратора».

Просмотр информации об активации/лицензии

Для отображения базовой информации о лицензии и активационной информации, выполните команду ниже, которая скажет вам, какая у вас версия Windows, часть ключа продукта, чтобы вы могли идентифицировать и покажет вам, активирована ли система.

Чтобы получить более подробную информацию о лицензии, включая ID активации, ID установки, и другие детальные сведения введите следующую команду:

Просмотр даты истечения срока действия лицензии

Чтобы узнать срок текущей активации системы, используйте команду ниже. Так как розничные лицензии, скажем, для домашних компьютеров активация идет на бессрочной основе, что никогда не истечет, команда будет полезна для коммерческих организаций KMS и серверов. Тем не менее вы можете проверить срок годности вашей лицензии, и убедиться что она постоянная.

Как удалить ключ продукта

С помощью Slmgr.vbs вы также можете удалить ключ продукта текущей системы Windows. После выполнения команды ниже, перезагрузите компьютер и ваша операционная система не будет иметь ключа продукта, что означает, Windows станет неактивным — без лицензии.

Это позволяет вам перенести лицензию на другой компьютер, если это необходимо. К примеру, если вы хотите подарить старый компьютер другу, а лицензию хотите оставить себе. Однако, как известно, активация Windows будет «привязана» к оборудованию компьютера, на котором она установлена, поэтому просто так сделать перенос не получится, но все же это возможно, но сейчас не об этом (это будет в следующих статьях).

Чтобы удалить лицензионный ключ, введите в командную строку следующую команду:

Однако команда не удаляет активацию полностью. Windows также хранит ключ продукта в реестре, потому как это иногда необходимо при настройках компьютера, а также для предотвращения кражи ключа вредоносными программами, которое могут получить доступ к реестру. Кроме этого будущий владелец компьютера (если он более менее разбирается в компьютерах) может легко вытащить ключ из реестра, так что вы также должны обязательно удалить его из реестра следующей командой:

Как установить или изменить ключ продукта

С помошью slmgr.vbs вы можете ввести новый ключ продукта. Если система Windows уже активирована, используя нижеприведенную команду вы можете заменить старый ключ на новый действующий (вместо #####-#####-#####-#####-##### введите новый ключ). После этого рекомендуется выполнить перезагрузку компьютера.

Также это можно сделать в экране настроек активации в параметрах компьютера, но следующая команда позволяет сделать это из командной строки:

Сброс таймера активации windows server 2016

а я тебе очём в личке писал!? а ты походу не дочитал до-конца.

Запустите командную строку (cmd) от имени Администратора, введите команду:
slmgr.vbs –rearm
или
slmgr /rearm
Перезагрузитесь.
Вы получите еще 30 дней. Общий срок 120 дней, сброс можно делать только 3 раза.
slmgr /xpr выводит дату и время окончания льготного периода
slmgr /dli количество минут (дней) оставшихся до окончания льготного периода

1) Создать командный файл delwpa.bat в корне диска C:

reg load HKLMMY_SYSTEM «%

dp0WindowsSystem32configsystem»
reg delete HKLMMY_SYSTEMWPA /f
reg unload HKLMMY_SYSTEM

2) Перезагрузить компьютер и нажать F8, чтобы войти в Дополнительные варианты загрузки.

3) Выбрать восстановление компьютера, выбрать язык ввода, ввести свой Логин и открыть окно командной строки.

4) Перейти на диск C:.
Выполнить:
delwpa.bat
Консоль должна отобразить сообщение, что команды были выполнены успешно. Закрыть окно консоли и перезагрузить компьютер.

5) Войти в Windows, игнорировать сообщение «Этот продукт не является подлинным», открыть командную строку от имени администратора и выполнить:
slmgr /ipk XXXXX-XXXXX-XXXXX-XXXXX-XXXXX
Где XXXXX-XXXXX-XXXXX-XXXXX-XXXXX, ключ вашего издания по умолчанию в зависимости от используемой версии Windows 7:
Ultimate — D4F6K-QK3RD-TMVMJ-BBMRX-3MBMV
Professional — HYF8J-CVRMY-CM74G-RPHKF-PW487
Home Premium — RHPQ2-RMFJH-74XYM-BH4JX-XM76F
Home Basic — YGFVB-QTFXQ-3H233-PTWTJ-YRYRV
Starter — 7Q28W-FT9PC-CMMYT-WHMY2-89M6G
Затем перезагрузить компьютер.

6) После перезагрузки запустить в командной строке от имени администратора:
slmgr /dlv
Должны получить окно с данными.
Состояние Лицензии: первоначальный льготный период
Оставшееся время: 30 дней
Оставшееся число возвращений к исходному состоянию активации Windows: 4

Windows позволит вам сделать сброс 4 раза, после этого, следуя руководству,
можно снова восстановить количество реармов.

Ещё один возможный способ.

Цитата: Я так с реармами колдовал. После чистой установки системы менял в реестре по адресу
HKEY_LOCAL_MACHINESOFTWAREMicrosoftWindows NTCurrentVersionSoftwareProtectionPlatform значение ключа
SkipRearm с 0 на 1.
Использовал все реармы. После того как реармов не стало, при очередном сбросе, система мне сказала что
пора переставлять ОС. Естественно я с ней не согласился и в реестре по адресу
HKEY_LOCAL_MACHINESOFTWAREMicrosoftWindows NTCurrentVersionSoftwareProtectionPlatform изменил значение
ключа SkipRearm с 1 на 0 т.е все вернул обратно. Это дало мне еще один реарм, но после него система снова
предложила переустановиться, но я сменил 0 на 1 и снова был реарм. В общем после окончания 4-х «встроенных»
реармов для продления перед каждым реармом надо менять значение в реестре. Смысл уловили?

---

---

---

---

---

---

---

---

---

---

---

---

---

---

---

---

---

---

---

---

Иногда в силу различных причин у Windows слетает активация. Лицензионный статус такой системы становится  «Non-genuine». Причины могут быть различные: установка нескольких новых устройств, иногда просто виртуалльных, установка некоторых программ, драйверов, завершение пробного периода. В этом случае Windows делает обои рабочего стола черными и показывает пугающую надпись типа «Ваша копия Windows не является подлинной»,  «Возможно вы стали жертвой подделки…» и тому подобное. В таком случае можно начать заново  пробный период Initial Grace Period. Такая процедура называется rearm. Выполняется она с помощью команды slmgr.vbs /rearm отданой из командной строки в превилегированном режиме (с правами администратора). Сбросить пробный период можно всего три раза, после каждого специалный счетчик уменьшается на еденицу. В конечном итоге может возникнуть ситуация когда rearm count равен нулю, а лицензионный статус все еще «Non-genuine» или ошибка какая-нибудь. В таком состоянии её нельзя подключить к KMS серверу, сменить ключ активации  и т.п.

В этом случае решением проблемы может быть удаление куста реестра отвечающего за лицензирование. Операционная система воссоздаст его заново при загрузке в началном состоянии Initial Grace Period. Существующий ключ при этом будет утерян, но это не беда.

Проблема в том, что это куст реестра защищен от изменения/удаления и сделать это можно только из режима восстановления Windows, когда реестр отключен.

Чтобы сбросить счетчик rearm count сделайте следующее:

Создайте в корне системного диска bat файл reset-rearm.bat следующего содержания:

reg load HKLMMY_SYSTEM "%~dp0WindowsSystem32configsystem"
reg delete HKLMMY_SYSTEMWPA /f
reg unload HKLMMY_SYSTEM

Перезагрузите компьютер и нажмите клавишу F8.


Выбирете "Устранение неполадок копьютера", далее - раскладку клавиатуры, введите пароль локального администратора и вы попадёте в экран командной строки. Текущим путём будет "X:Windowssystem32".
Перейдите в корень системного диска (для Windows 7 это будет диск D) командой "D:", можете проверить наличие файла reset-rearm.bat в корне командой dir.
Запустите файл reset-rearm.bat.
Перезагрузитесь в обычном режиме.

Windows  сообщит вам, что ключ активации не обнаружен.
Для того чтобы ввести ключ заново откройте командную строку в режиме администратора и выполните команду
slmgr.vbs /ipk XXXXX-XXXXX-XXXXX-XXXXX-XXXXX, где вместо иксов введите ваш ключ активации или открытый KMS ключ для соответсвующей операционной системы: 
Windows 7 Professional   FJ82H-XT6CR-J8D7P-XQJJ2-GPDD4
Windows 7 Enterprise   33PXH-7Y6KF-2VJC9-XBBR8-HVTHH
Windows Server 2008 R2 Standard   YC6KT-GKW9T-YTKYR-T4X34-R7VHC
Windows Server 2008 R2 Enterprise   489J6-VHDMP-X63PK-3K798-CPX3Y
Windows Server 2008 R2 Datacenter   4YFP-3QFB3-KQT8W-PMXWJ-7M648

После этого лицензионный статус вашей ОС станет "Initial grace period" с количеством сброса счетчика равным 4.

Данная статья основана на блоге Дэниела Митчела  http://www.daniel-mitchell.com/blog/reset-windows-7-rearm-count/

Некоторые полезные ссылки:

https://technet.microsoft.com/en-us/library/ff793403.aspx

http://www.microsoft.com/resources/documentation/windows/xp/all/proddocs/en-us/percent.mspx?mfr=true