Skip to content

Instantly share code, notes, and snippets.

@gioxx

gioxx/OffScrubc2r.vbs

Created July 18, 2016 12:46
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save gioxx/4eaeb0672286989f00d041ba2450f6f6 to your computer and use it in GitHub Desktop.
Save gioxx/4eaeb0672286989f00d041ba2450f6f6 to your computer and use it in GitHub Desktop.
Download ZIP
OffScrubC2R.vbs Ufficiale Microsoft (Script to remove Office Click To Run (C2R) products when a regular uninstall is no longer possible). Scope: Office 2013, 2016 and O365 C2R products.
Raw
OffScrubc2r.vbs
'*******************************************************************************
' Name: OffScrubC2R.vbs
' Author: Microsoft Customer Support Services
' Copyright (c) 2014 - 2015 Microsoft Corporation
' Script to remove Office Click To Run (C2R) products
' when a regular uninstall is no longer possible
'
' Scope: Office 2013, 2016 and O365 C2R products
'*******************************************************************************
Option Explicit
'-------------------------------------------------------------------------------
'
' Declaration of constants
'-------------------------------------------------------------------------------
Const SCRIPTVERSION = "2.00"
Const SCRIPTFILE = "OffScrubC2R.vbs"
Const SCRIPTNAME = "OffScrubC2R"
Const RETVALFILE = "ScrubRetValFile.txt"
Const ONAME = "Office C2R / O365"
Const HKCR = &H80000000
Const HKCU = &H80000001
Const HKLM = &H80000002
Const HKU = &H80000003
Const PRODLEN = 13
Const SQUISHED = 20
Const COMPRESSED = 32
Const REG_ARP = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\"
Const VB_YES = 6
Const VB_NO = 7
Const ERROR_SUCCESS = 0 'Bit #1. 0 indicates Success. Script completed successfully
Const ERROR_FAIL = 1 'Bit #1. Failure bit. Indicates an overall script failure.
'RESERVED bit! Returned when process is killed from task manager
Const ERROR_REBOOT_REQUIRED = 2 'Bit #2. Reboot bit. If set a reboot is required
Const ERROR_USERCANCEL = 4 'Bit #3. User Cancel bit. Controlled cancel from script UI
Const ERROR_STAGE1 = 8 'Bit #4. Informational. Msiexec based install was not possible
Const ERROR_STAGE2 = 16 'Bit #5. Critical. Not all of the intended cleanup operations could be applied
Const ERROR_INCOMPLETE = 32 'Bit #6. Pending file renames (del on reboot) - OR - Removal needs to run again after a system reboot.
Const ERROR_DCAF_FAILURE = 64 'Bit #7. Critical. Da capo al fine (second attempt) still failed.
Const ERROR_ELEVATION_USERDECLINED = 128 'Bit #8. Critical script error. User declined to allow mandatory script elevation
Const ERROR_ELEVATION = 256 'Bit #9. Critical script error. The attempt to elevate the process did not succeed
Const ERROR_SCRIPTINIT = 512 'Bit #10. Critical script error. Initialization failed
Const ERROR_RELAUNCH = 1024'Bit #11. Critical script error. This is a temporary value and must not be the final return code
Const ERROR_UNKNOWN = 2048'Bit #12 Critical script error. Script did not complete in a well defined state
Const ERROR_ALL = 4095'Full BitMask
Const ERROR_USER_ABORT = &HC000013A 'RESERVED. Dec -1073741510. Critical error. Returned when user aborts with <Ctrl>+<Break> or closes the cmd window
Const ERROR_SUCCESS_CONFIG_COMPLETE = 1728
Const ERROR_SUCCESS_REBOOT_REQUIRED = 3010
'-------------------------------------------------------------------------------
'
' Declaration of variables
'-------------------------------------------------------------------------------
Dim oFso, oMsi, oReg, oWShell, oWmiLocal, oShellApp
Dim ComputerItem, Key, Item, LogStream, TmpKey
Dim arrVersion
Dim dictionaryKeepLis, dicApps, dictionaryKeepFolder, dicDelRegKey, dictionaryKeepReg
Dim dicInstalledSku, dicRemoveSku, dictionaryKeepSku, dicC2RSuite, dicDelInUse
Dim dicDelFolder
Dim sAppData, sScrubDir, sProgramFiles, sProgramFilesX86, sCommonProgramFiles
Dim sAllusersProfile, sOSVersion, sWinDir, sWICacheDir, sCommonProgramFilesX86
Dim sProgramData, sPackageFolder, sLocalAppData, sOInstallRoot, sSkuRemoveList
Dim sOSinfo, sDefault, sTemp, sTmp, sCmd, sLogDir, sPrompt, sProfilesDirectory
Dim sRetVal, sScriptDir, sPackageGuid, sValue, sActiveConfiguration
Dim iVersionNT, iError, iProcCloseCnt
Dim f64, fLogInitialized, fNoCancel, fRemoveOse, fDetectOnly, fQuiet, fForce
Dim fC2R, fRemoveAll, fRebootRequired, fRerun, fSetRunOnce, fTestRerun
Dim fIsElevated, fNoElevate, fUserConsent, fCScript
'-------------------------------------------------------------------------------
' Main
'
' Main section of script
'-------------------------------------------------------------------------------
' initialize required settings and objects
' ----------------------------------------
Initialize
' call the command line parser
'-----------------------------
ParseCmdLine
'-----------------------------
' Stage # 0 - Basic detection |
'-----------------------------
LogH "Stage # 0 " & chr(34) & "Basic detection" & chr(34)
' ensure integrity of WI metadata which could fail used APIs otherwise
'---------------------------------------------------------------------
Log "Ensure Windows Installer metadata integrity " & " (" & Time & ")"
EnsureValidWIMetadata HKCU,"Software\Classes\Installer\Products", COMPRESSED
EnsureValidWIMetadata HKCR,"Installer\Products", COMPRESSED
EnsureValidWIMetadata HKLM,"SOFTWARE\Microsoft\Windows\CurrentVersion\Installer\UserData\S-1-5-18\Products", COMPRESSED
EnsureValidWIMetadata HKLM,"SOFTWARE\Microsoft\Windows\CurrentVersion\Installer\UserData\S-1-5-18\Components", COMPRESSED
EnsureValidWIMetadata HKCR,"Installer\Components", COMPRESSED
' build a list with installed/registered Office products
'-------------------------------------------------------
FindInstalledOProducts
If dicC2RSuite.Count > 0 Then
Log "Registered ARP product(s) found:"
For Each Key In dicC2RSuite.Keys
Log " - " & Key & " - " & dicC2RSuite.Item(Key)
Next 'Key
' For Each Item in dicC2RSuite.Items
' Log " - " & Item
' Next 'Item
Else
Log "No registered product(s) found"
End If
' locate the C2R %PackageFolder% and the PackageGuid
'---------------------------------------------------
sPackageFolder = ""
If RegReadValue(HKLM, "SOFTWARE\Microsoft\Office\15.0\ClickToRun", "PackageFolder", sValue, "REG_SZ") Then
sPackageFolder = sValue
ElseIf RegReadValue(HKLM, "SOFTWARE\Microsoft\Office\16.0\ClickToRun", "PackageFolder", sPackageFolder, "REG_SZ") Then
sPackageFolder = sValue
ElseIf RegReadValue(HKLM, "SOFTWARE\Microsoft\Office\ClickToRun", "PackageFolder", sPackageFolder, "REG_SZ") Then
sPackageFolder = sValue
End If
' if sPackageFolder is invalid set it to the c2r registry reference string
If NOT Len(sPackageFolder) > 0 OR IsNull(sPackageFolder) Then
If oFso.FolderExists(oWShell.ExpandEnvironmentStrings("%programfiles%") & "\Microsoft Office 15") Then
sPackageFolder = oWShell.ExpandEnvironmentStrings("%programfiles%") & "\Microsoft Office 15"
ElseIf oFso.FolderExists(oWShell.ExpandEnvironmentStrings("%programfiles%") & "\Microsoft Office 16") Then
sPackageFolder = oWShell.ExpandEnvironmentStrings("%programfiles%") & "\Microsoft Office 16"
ElseIf oFso.FolderExists(oWShell.ExpandEnvironmentStrings("%programfiles%") & "\Microsoft Office\PackageManifests") Then
sPackageFolder = oWShell.ExpandEnvironmentStrings("%programfiles%") & "\Microsoft Office"
ElseIf oFso.FolderExists(oWShell.ExpandEnvironmentStrings("%programfiles(x86)%") & "\Microsoft Office\PackageManifests") Then
sPackageFolder = oWShell.ExpandEnvironmentStrings("%programfiles(x86)%") & "\Microsoft Office"
End If
End If
sPackageGuid = ""
If RegReadValue(HKLM, "SOFTWARE\Microsoft\Office\15.0\ClickToRun", "PackageGUID", sValue, "REG_SZ") Then
sPackageGuid = sValue
ElseIf RegReadValue(HKLM, "SOFTWARE\Microsoft\Office\16.0\ClickToRun", "PackageGUID", sValue, "REG_SZ") Then
sPackageGuid = sValue
ElseIf RegReadValue(HKLM, "SOFTWARE\Microsoft\Office\ClickToRun", "PackageGUID", sValue, "REG_SZ") Then
sPackageGuid = sValue
End If
' Init complete. Reset the return value
'--------------------------------------
ClearError ERROR_SCRIPTINIT
'-----------------------
' Stage # 1 - Uninstall |
'-----------------------
LogH "Stage # 1 " & chr(34) & "Uninstall" & chr(34)
' clean O15 SPP
'--------------
LogH1 "Clean OSPP"
CleanOSPP
' end all running Office applications
'------------------------------------
LogH1 "End running processes"
CloseOfficeApps
' remove scheduled tasks which might interfere with uninstall
'------------------------------------------------------------
DelSchtasks
' unpin shortcuts
'----------------
' need to unpin as long as the shortcuts are still valid!
LogH1 "Unpinning shortcuts"
CleanShortcuts sAllusersProfile, True, True
CleanShortcuts sProfilesDirectory, True, True
' uninstall
'----------
LogH1 "Removing " & ONAME
Uninstall
'---------------------
' Stage # 2 - CleanUp |
'---------------------
LogH "Stage # 2 " & chr(34) & "CleanUp" & chr(34)
' Cleanup registry data
'----------------------
RegWipe
' Cleanup files
'--------------
FileWipe
' for test purposes only!
If fTestRerun Then
LogH2 "Enforcing 'Rerun' mode for test purposes"
fRebootRequired = True
SetError ERROR_REBOOT_REQUIRED
Rerun
End If
ExitScript
Sub ExitScript
'------------------
' Stage # 3 - Exit |
'------------------
' Update cached error and quit
'-----------------------------
If NOT CBool(iError AND (ERROR_FAIL + ERROR_INCOMPLETE)) Then RegDeleteValue HKCU, "SOFTWARE\Microsoft\Office\15.0\CleanC2R", "Rerun", False
SetRetVal iError
' log result
If CBool(iError AND ERROR_INCOMPLETE) Then
LogH2 "Removal result: " & iError & " - INCOMPLETE. Uninstall requires a system reboot to complete."
Else
sTmp = " - SUCCESS"
If CBool(iError AND ERROR_USERCANCEL) Then sTmp = " - USER CANCELED"
If CBool(iError AND ERROR_FAIL) Then sTmp = " - FAIL"
LogH2 "Removal result: " & iError & sTmp
End If
If CBool(iError AND ERROR_FAIL) Then
If CBool(iError AND ERROR_REBOOT_REQUIRED) Then Log " - Reboot required"
If CBool(iError AND ERROR_USERCANCEL) Then Log " - User cancel"
If CBool(iError AND ERROR_STAGE1) Then Log " - Msiexec failed"
If CBool(iError AND ERROR_STAGE2) Then Log " - Cleanup failed"
If CBool(iError AND ERROR_INCOMPLETE) Then Log " - Removal incomplete. Rerun after reboot needed"
If CBool(iError AND ERROR_DCAF_FAILURE) Then Log " - Second attempt cleanup still incomplete"
If CBool(iError AND ERROR_ELEVATION_USERDECLINED) Then Log " - User declined elevation"
If CBool(iError AND ERROR_ELEVATION) Then Log " - Elevation failed"
If CBool(iError AND ERROR_SCRIPTINIT) Then Log " - Initialization error"
If CBool(iError AND ERROR_RELAUNCH) Then Log " - Unhandled error during relaunch attempt"
If CBool(iError AND ERROR_UNKNOWN) Then Log " - Unknown error"
' ERROR_USER_ABORT is only valid for the temporary cached error file
'If CBool(iError AND ERROR_USER_ABORT) Then Log " - Process terminated by user"
End If
LogH2 "Removal end."
' Reboot handling
If fRebootRequired Then
sPrompt = "In order to complete uninstall, a system reboot is necessary. Would you like to reboot now?"
If NOT fQuiet Then
If MsgBox(sPrompt, vbYesNo, SCRIPTNAME & " - Reboot Required") = VB_YES Then
Dim colOS, oOS
Dim oWmiReboot
Set oWmiReboot = GetObject("winmgmts:{impersonationLevel=impersonate,(Shutdown)}!\\.\root\cimv2")
Set colOS = oWmiReboot.ExecQuery ("Select * from Win32_OperatingSystem")
For Each oOS in colOS
oOS.Reboot()
Next
End If
End If
End If
wscript.quit iError
End Sub 'ExitScript
'-------------------------------------------------------------------------------
' End Main
'
' End of Main section
'-------------------------------------------------------------------------------
'-------------------------------------------------------------------------------
' Initialize
'
' Configure defaults and initialize all required objects
'-------------------------------------------------------------------------------
Sub Initialize ()
Dim iCnt
' set defaults
'-------------
iError = ERROR_SUCCESS
iProcCloseCnt = 0
sLogDir = ""
sPackageFolder = ""
f64 = False
fCScript = False
fLogInitialized = False
fNoCancel = False
fRemoveOse = False
fDetectOnly = False
fQuiet = True
fForce = False
fC2R = True
fRebootRequired = False
fRerun = False
fTestRerun = False
fIsElevated = False
fNoElevate = False
fSetRunOnce = False
fUserConsent = False
' create required objects
'------------------------
Set oWmiLocal = GetObject("winmgmts:\\.\root\cimv2")
Set oWShell = CreateObject("Wscript.Shell")
Set oShellApp = CreateObject("Shell.Application")
Set oFso = CreateObject("Scripting.FileSystemObject")
Set oMsi = CreateObject("WindowsInstaller.Installer")
Set oReg = GetObject("winmgmts:\\.\root\default:StdRegProv")
' get environment path values
'----------------------------
sAppData = oWShell.ExpandEnvironmentStrings("%appdata%")
sLocalAppData = oWShell.ExpandEnvironmentStrings("%localappdata%")
sTemp = oWShell.ExpandEnvironmentStrings("%temp%")
sAllUsersProfile = oWShell.ExpandEnvironmentStrings("%allusersprofile%")
RegReadValue HKLM, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\ProfileList", "ProfilesDirectory", sProfilesDirectory, "REG_EXPAND_SZ"
If NOT oFso.FolderExists(sProfilesDirectory) Then
sProfilesDirectory = oFso.GetParentFolderName(oWShell.ExpandEnvironmentStrings("%userprofile%"))
End If
sProgramFiles = oWShell.ExpandEnvironmentStrings("%programfiles%")
'sProgramFilesX86 = deferred. Depends on operating system architecture check
sCommonProgramFiles = oWShell.ExpandEnvironmentStrings("%commonprogramfiles%")
'sCommonProgramFilesX86 = deferred. Depends on operating system architecture check
sProgramData = oWSHell.ExpandEnvironmentStrings("%programdata%")
sWinDir = oWShell.ExpandEnvironmentStrings("%windir%")
'sPackageFolder = deferred
sWICacheDir = sWinDir & "\" & "Installer"
sScrubDir = sTemp & "\" & SCRIPTNAME
sScriptDir = wscript.ScriptFullName
sScriptDir = Left(sScriptDir, InStrRev(sScriptDir, "\"))
' ensure 64 bit host if needed
If InStr(LCase(wscript.path), "syswow64") > 0 Then RelaunchAs64Host
' create the temp folder
'-----------------------
If Not oFso.FolderExists(sScrubDir) Then oFso.CreateFolder sScrubDir
' set the default logging directory
'----------------------------------
sLogDir = sScrubDir
' detect bitness of the operating system
'----------------------------------------
Set ComputerItem = oWmiLocal.ExecQuery("Select * from Win32_ComputerSystem")
For Each Item In ComputerItem
f64 = Instr(Left(Item.SystemType, 3), "64") > 0
Next
If f64 Then sProgramFilesX86 = oWShell.ExpandEnvironmentStrings("%programfiles(x86)%")
If f64 Then sCommonProgramFilesX86 = oWShell.ExpandEnvironmentStrings("%CommonProgramFiles(x86)%")
' update error flag
'------------------
SetError ERROR_SCRIPTINIT
' get Win32_OperatingSystem details
'----------------------------------
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
' get VersionNT number
'---------------------
arrVersion = Split(sOsVersion, Delimiter(sOsVersion))
iVersionNt = CInt(arrVersion(0)) * 100 + CInt(arrVersion(1))
' ensure sufficient registry permisions
'--------------------------------------
fIsElevated = CheckRegPermissions
If NOT fIsElevated AND NOT fNoElevate Then
' try to relaunch elevated
RelaunchElevated
' can't relaunch. Exit out
SetError ERROR_ELEVATION
If UCase(Mid(Wscript.FullName, Len(Wscript.Path) + 2, 1)) = "C" Then
If Not fLogInitialized Then CreateLog
Log "Error: Insufficient registry access permissions - exiting"
End If
SetRetVal iError
wscript.quit iError
End If
' clear error flags
'------------------
ClearError ERROR_ELEVATION
ClearError ERROR_SCRIPTINIT
' ensure CScript as engine
'------------------------
fCScript = UCase(Mid(Wscript.FullName, Len(Wscript.Path) + 2, 1)) = "C"
If NOT fCScript AND NOT fQuiet Then RelaunchAsCScript
' set retval for file based logic
'--------------------------------
' value needs to be kept on 'user abort'
SetRetVal ERROR_USER_ABORT
' create dictionary objects
'--------------------------
Set dicInstalledSku = CreateObject("Scripting.Dictionary")
Set dicRemoveSku = CreateObject("Scripting.Dictionary")
Set dictionaryKeepSku = CreateObject("Scripting.Dictionary")
Set dictionaryKeepLis = CreateObject("Scripting.Dictionary")
Set dictionaryKeepFolder = CreateObject("Scripting.Dictionary")
Set dicApps = CreateObject("Scripting.Dictionary")
Set dicDelRegKey = CreateObject("Scripting.Dictionary")
Set dictionaryKeepReg = CreateObject("Scripting.Dictionary")
Set dicC2RSuite = CreateObject("Scripting.Dictionary")
Set dicDelInUse = CreateObject("Scripting.Dictionary")
Set dicDelFolder = CreateObject("Scripting.Dictionary")
' add initial known .exe files that need to be closed
'----------------------------------------------------
dicApps.Add "appvshnotify.exe", "appvshnotify.exe"
dicApps.Add "integratedoffice.exe", "integratedoffice.exe"
dicApps.Add "integrator.exe", "integrator.exe"
dicApps.Add "firstrun.exe", "firstrun.exe"
dicApps.Add "setup.exe", "setup.exe"
dicApps.Add "communicator.exe", "communicator.exe"
dicApps.Add "msosync.exe", "msosync.exe"
dicApps.Add "OneNoteM.exe", "OneNoteM.exe"
dicApps.Add "iexplore.exe", "iexplore.exe"
dicApps.Add "mavinject32.exe", "mavinject32.exe"
dicApps.Add "werfault.exe", "werfault.exe"
dicApps.Add "perfboost.exe", "perfboost.exe"
dicApps.Add "roamingoffice.exe", "roamingoffice.exe"
' SP1 additions / changes
dicApps.Add "officeclicktorun.exe", "officeclicktorun.exe"
dicApps.Add "officeondemand.exe", "officeondemand.exe"
dicApps.Add "OfficeC2RClient.exe", "OfficeC2RClient.exe"
End Sub 'Initialize
'-------------------------------------------------------------------------------
' ParseCmdLine
'
' 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
FindInstalledOProducts
sDefault = "ALL"
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
' hardcode to full removal
sArg0 = "ALL"
Select Case UCase(sArg0)
Case "?"
ShowSyntax
Case "ALL"
fRemoveAll = True
fRemoveOse = False
Case "C2R"
fC2R = True
fRemoveAll = False
fRemoveOse = False
Case Else
fRemoveAll = False
fRemoveOse = False
sSkuRemoveList = sArg0
End Select
For iCnt = 0 To UBound(arrArguments)
Select Case arrArguments(iCnt)
Case "?", "/?", "-?"
ShowSyntax
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 "/Q", "/QUIET"
fQuiet = True
' for test purposes only!
Case "/TR", "/TESTRERUN"
fTestRerun = True
Case Else
End Select
Next 'iCnt
If Not fLogInitialized Then CreateLog
End Sub 'ParseCmdLine
'-------------------------------------------------------------------------------
' ShowSyntax
'
' Show the expected syntax for the script usage
'-------------------------------------------------------------------------------
Sub ShowSyntax
Wscript.Echo sErr & vbCrLf & _
SCRIPTFILE & " V " & SCRIPTVERSION & vbCrLf & _
"Copyright (c) Microsoft Corporation. All Rights Reserved" & vbCrLf & vbCrLf & _
SCRIPTFILE & " - Remove " & ONAME & vbCrLf & _
"when a regular uninstall is no longer possible" & vbCrLf & vbCrLf & _
"Usage:" & vbTab & SCRIPTFILE & vbCrLf & vbCrLf & _
vbTab & "/? ' Displays this help"& vbCrLf
Wscript.Quit
End Sub 'ShowSyntax
'-------------------------------------------------------------------------------
' FindInstalledOProducts
'
' Office configuration products are listed with their configuration product
' name in the "Uninstall" key.
'-------------------------------------------------------------------------------
Sub FindInstalledOProducts
Dim ArpItem, prod, cult
Dim sCurKey, sValue, sConfigName, sCulture, sDisplayVersion, sProd
Dim sUninstallString
Dim iLeft, iRight
Dim arrKeys, arrProducts, arrCultures
Dim fSystemComponent0, fDisplayVersion, fUninstallString
Const REG_ARP = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\"
Const REG_O15RPROPERTYBAG = "SOFTWARE\Microsoft\Office\15.0\ClickToRun\propertyBag\"
Const REG_O15C2RCONFIGURATION = "SOFTWARE\Microsoft\Office\15.0\ClickToRun\Configuration\"
Const REG_O15C2RPRODUCTIDS = "SOFTWARE\Microsoft\Office\15.0\ClickToRun\ProductReleaseIDs\Active\"
Const REG_O16C2RCONFIGURATION = "SOFTWARE\Microsoft\Office\16.0\ClickToRun\Configuration\"
Const REG_O16C2RPRODUCTIDS = "SOFTWARE\Microsoft\Office\16.0\ClickToRun\ProductReleaseIDs\Active\"
Const REG_C2RCONFIGURATION = "SOFTWARE\Microsoft\Office\ClickToRun\Configuration\"
Const REG_C2RPRODUCTIDS = "SOFTWARE\Microsoft\Office\ClickToRun\ProductReleaseIDs\"
If dicInstalledSku.Count > 0 Then Exit Sub 'Already done from command line parser
fDisplayVersion = False
' identify C2R products
LogOnly vbCrLf & "Detecting installed products "
LogOnly "Check for O15 C2R products"
' Check O15 Configuration key
If RegReadValue(HKLM, REG_O15C2RCONFIGURATION, "ProductReleaseIds", sValue, "REG_SZ") Then
arrProducts = Split(sValue, ",")
fDisplayVersion = RegReadValue(HKLM, REG_O15C2RPRODUCTIDS & "culture", "x-none", sDisplayVersion, "REG_SZ")
If NOT Err = 0 Then
Err.Clear
Else
' get version from active with fallback on configuration
For Each prod in arrProducts
LogOnly "Found O15 C2R product in Configuration: " & prod
' update product dictionary
If NOT dicInstalledSku.Exists(LCase(prod)) Then
LogOnly "adding new product to dictionary: " & LCase(prod)
dicInstalledSku.Add LCase(prod), sDisplayVersion
End If
Next 'prod
End If
End If
' Check O15 PropertyBag key
If RegReadValue(HKLM, REG_O15RPROPERTYBAG, "productreleaseid", sValue, "REG_SZ") Then
arrProducts = Split(sValue, ",")
fDisplayVersion = RegReadValue(HKLM, REG_O15C2RPRODUCTIDS & "culture", "x-none", sDisplayVersion, "REG_SZ")
If NOT Err = 0 Then
Err.Clear
Else
For Each prod in arrProducts
LogOnly "Found O15 C2R product in PropertyBag: " & prod
' update product dictionary
If NOT dicInstalledSku.Exists(LCase(prod)) Then
LogOnly "adding new product to dictionary: " & LCase(prod)
dicInstalledSku.Add LCase(prod), sDisplayVersion
End If
Next 'prod
End If
End If
'O16 section
LogOnly "Check for Office C2R products (>=QR8)"
' Check Office Configuration key
If RegReadValue(HKLM, REG_C2RPRODUCTIDS, "ActiveConfiguration", sActiveConfiguration, "REG_SZ") Then
' Get DisplayVersion
'Try QR8 logic first
fDisplayVersion = RegReadValue(HKLM, REG_C2RPRODUCTIDS & sActiveConfiguration & "\culture", "x-none", sDisplayVersion, "REG_SZ")
If RegEnumKey(HKLM, REG_C2RPRODUCTIDS & sActiveConfiguration & "\culture", arrCultures) Then
For Each cult In arrCultures
If InStr(LCase(cult), "x-none") > 0 Then
fDisplayVersion = RegReadValue(HKLM, REG_C2RPRODUCTIDS & sActiveConfiguration & "\culture\" & cult, "Version", sDisplayVersion, "REG_SZ")
End If
Next 'cult
End If
' Update product dic
If RegEnumKey(HKLM, REG_C2RPRODUCTIDS & sActiveConfiguration, arrProducts) Then
For Each prod In arrProducts
sProd = LCase(prod)
If InStr(sProd, ".") > 0 Then sProd = Left(sProd, InStr(sProd, ".") - 1)
Select Case LCase(sProd)
Case "culture", "stream"
Case Else
LogOnly "Found Office C2R product in Configuration: " & prod
' update product dictionary
If NOT dicInstalledSku.Exists(sProd) Then
LogOnly "adding new product to dictionary: " & sProd
dicInstalledSku.Add sProd, sDisplayVersion
End If
End Select
Next 'prod
End If 'arrProducts
End If 'ActiveConfiguration
LogOnly "Check for Office C2R products (QR7)"
' Check Office Configuration key
If RegReadValue(HKLM, REG_C2RCONFIGURATION, "ProductReleaseIds", sValue, "REG_SZ") Then
arrProducts = Split(sValue, ",")
If Not fDisplayVersion Then fDisplayVersion = RegReadValue(HKLM, REG_C2RPRODUCTIDS & "Active\culture", "x-none", sDisplayVersion, "REG_SZ")
If NOT Err = 0 Then
Err.Clear
Else
For Each prod in arrProducts
LogOnly "Found Office C2R product in Configuration: " & prod
' update version tracking
If NOT dicInstalledSku.Exists(LCase(prod)) Then
LogOnly "adding new product to dictionary: " & LCase(prod)
dicInstalledSku.Add LCase(prod), sDisplayVersion
End If
Next 'prod
End If
End If
LogOnly "Check for O16 C2R products (QR6)"
' Check O16 Configuration key
If RegReadValue(HKLM, REG_O16C2RCONFIGURATION, "ProductReleaseIds", sValue, "REG_SZ") Then
arrProducts = Split(sValue, ",")
If Not fDisplayVersion Then fDisplayVersion = RegReadValue(HKLM, REG_O16C2RPRODUCTIDS & "culture", "x-none", sDisplayVersion, "REG_SZ")
If NOT Err = 0 Then
Err.Clear
Else
For Each prod in arrProducts
LogOnly "Found O16 (QR6) C2R product in Configuration: " & prod
' update product dictionary
If NOT dicInstalledSku.Exists(LCase(prod)) Then
LogOnly "adding new product to dictionary: " & prod
dicInstalledSku.Add LCase(prod), sDisplayVersion
End If
Next 'prod
End If
End If
LogOnly "Check ARP for Office C2R products"
' ARP
RegEnumKey HKLM, REG_ARP, arrKeys
If IsArray(arrKeys) Then
For Each ArpItem in arrKeys
' filter on Office C2R products
sCurKey = REG_ARP & ArpItem & "\"
fUninstallString = RegReadValue(HKLM, sCurKey, "UninstallString", sValue, "REG_SZ")
If (fUninstallString And( (InStr(UCase(sValue), UCase("Microsoft Office 1")) > 0) Or (InStr(UCase(sValue), UCase("OfficeClickToRun.exe")) > 0) )) Then
'get Version
fDisplayVersion = RegReadValue(HKLM, sCurKey, "DisplayVersion", sDisplayVersion, "REG_SZ")
'extract the productreleaseid
sValue = Trim(sValue)
prod = Trim(Mid(sValue, InStrRev(sValue, " ")))
prod = Replace(prod, "productstoremove=", "")
If InStr(prod, "_") > 0 Then
prod = Left(prod, InStr(prod, "_") - 1)
End If
If InStr(prod, ".1") > 0 Then
prod = Left(prod, InStr(prod, ".1") - 1)
End If
LogOnly "Found C2R product in ARP: " & prod
If NOT dicInstalledSku.Exists(LCase(prod)) Then
LogOnly "adding new product to dictionary: " & prod
dicInstalledSku.Add LCase(prod), sDisplayVersion
End If
' categorize the SKU as C2R
If NOT dicC2RSuite.Exists(ArpItem) Then dicC2RSuite.Add ArpItem, prod & " - " & sDisplayVersion
Else
'Legacy logic keep for compat reasons
sValue = ""
sDisplayVersion = ""
fSystemComponent0 = NOT (RegReadValue(HKLM, sCurKey, "SystemComponent", sValue, "REG_DWORD") AND (sValue = "1"))
fDisplayVersion = RegReadValue(HKLM, sCurKey, "DisplayVersion", sValue, "REG_SZ")
If fDisplayVersion Then
sDisplayVersion = sValue
If Len(sValue) > 1 Then
On Error Resume Next
fDisplayVersion = (CInt(Left(sValue, 2)) > 14)
If Not Err <> 0 Then Err.Clear
Else
fDisplayVersion = False
End If
End If
fUninstallString = RegReadValue(HKLM, sCurKey, "UninstallString", sUninstallString, "REG_SZ")
' filter on C2R configuration SKU
If (fUninstallString And( (InStr(UCase(sUninstallString), UCase("Microsoft Office 1")) > 0) Or (InStr(UCase(sUninstallString), UCase("OfficeClickToRun.exe")) > 0) )) Then
' Extract the ProductReleaseID
If InStr(sUninstallString, "productstoremove=") > 0 Then
sConfigName = Trim(Mid(sValue, InStrRev(sUninstallString, " ")))
sConfigName = Replace(sConfigName, "productstoremove=", "")
If InStr(prod, "_") > 0 Then
sConfigName = Left(sConfigName, InStr(sConfigName, "_") - 1)
End If
Else
iLeft = InStr(ArpItem, " - ") + 2
iRight = InStr(iLeft, ArpItem, " - ") - 1
If iRight > 0 Then
sConfigName = Trim(Mid(ArpItem, iLeft, (iRight - iLeft)))
sCulture = Mid(ArpItem, iRight + 3)
Else
sConfigName = Trim(Left(ArpItem, iLeft - 3))
sCulture = Mid(ArpItem, iLeft)
End If
sConfigName = Replace(sConfigName, "Microsoft", "")
sConfigName = Replace(sConfigName, "Office", "")
sConfigName = Replace(sConfigName, "Professional", "Pro")
sConfigName = Replace(sConfigName, "Standard", "Std")
sConfigName = Replace(sConfigName, "(Technical Preview)", "")
sConfigName = Replace(sConfigName, "15", "")
sConfigName = Replace(sConfigName, "16", "")
sConfigName = Replace(sConfigName, "2013", "")
sConfigName = Replace(sConfigName, "2016", "")
sConfigName = Replace(sConfigName, " ", "")
sConfigName = Replace(sConfigName, "Project", "Prj")
sConfigName = Replace(sConfigName, "Visio", "Vis")
End If
If NOT dicInstalledSku.Exists(LCase(sConfigName)) Then
LogOnly "adding new product to dictionary (ARP Legacy): " & sConfigName
dicInstalledSku.Add LCase(sConfigName), sDisplayVersion
End If
' categorize the SKU as C2R
If NOT dicC2RSuite.Exists(ArpItem) Then dicC2RSuite.Add ArpItem, sConfigName & " - " & sDisplayVersion
ElseIf (fSystemComponent0 AND fDisplayVersion AND (InStr(UCase(ArpItem), UCase("OFFICE15.")) > 0 Or InStr(UCase(ArpItem), UCase("OFFICE16.")) > 0)) Then
' classic .msi install SKU
iLeft = InStr(ArpItem, ".") + 1
iRight = InStr(iLeft, ArpItem, "-") - 1
sConfigName = Mid(ArpItem, iLeft)
sCulture = ""
If NOT dictionaryKeepSku.Exists(ArpItem) Then dictionaryKeepSku.Add ArpItem, sConfigName & " - " & sDisplayVersion
End If
' Other products
If InScope(ArpItem) Then
Select Case Mid(ArpItem,11,4)
' 007E = Licensing
' 008C = Extensibility Components
Case "007E", "008F", "008C"
sConfigName = "Habanero"
RegReadValue HKLM, sCurKey, "DisplayName", sConfigName, "REG_SZ"
If NOT dicInstalledSku.Exists(LCase(ArpItem)) Then
LogOnly "adding new product to dictionary (ARP Legacy other): " & ArpItem
dicInstalledSku.Add LCase(ArpItem), sDisplayVersion
End If
If NOT dicC2RSuite.Exists(ArpItem) Then dicC2RSuite.Add ArpItem, sConfigName & " - " & sDisplayVersion
Case "24E1", "237A"
sConfigName = "MSOIDLOGIN"
If NOT dicInstalledSku.Exists(LCase(ArpItem)) Then
LogOnly "adding new product to dictionary (ARP Legacy other): " & ArpItem
dicInstalledSku.Add LCase(ArpItem), sDisplayVersion
End If
If NOT dicC2RSuite.Exists(ArpItem) Then dicC2RSuite.Add ArpItem, sConfigName & " - " & sDisplayVersion
Case Else
' not in scope for c2r removal!
If NOT dictionaryKeepSku.Exists(ArpItem) Then dictionaryKeepSku.Add ArpItem, ArpItem
End Select
End If 'InScope
' End legacy logic
End If
Next 'ArpItem
End If
End Sub 'FindInstalledOProducts
'-------------------------------------------------------------------------------
' EnsureValidWIMetadata
'
' Ensures that only valid metadata entries exist to avoid API failures.
' Invalid entries will be removed
'-------------------------------------------------------------------------------
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
'-------------------------------------------------------------------------------
' CleanOSPP
'
' Clean out licenses from the Office Software Protection Platform
'-------------------------------------------------------------------------------
Sub CleanOSPP
Dim oProductInstances, pi
Dim sCleanOSPP, sCmd, sRetVal
CONST OfficeAppId = "0ff1ce15-a989-479d-af46-f275c6370663" 'Office 2013
sCleanOSPP = "x64\CleanOSPP.exe"
If Not f64 Then sCleanOSPP = "x86\CleanOSPP.exe"
If oFso.FileExists(sScriptDir & sCleanOSPP) Then
sCmd = sScriptDir & sCleanOSPP
Log " Running: " & sCmd
On Error Resume Next
sRetVal = oWShell.Run(sCmd, 0, True)
Log " Return value: " & sRetVal
On Error Goto 0
Exit Sub
End If
On Error Resume Next
If NOT (dicC2RSuite.Count > 0 OR dictionaryKeepSku.Count > 0) Then
Log "Skipping CleanOSPP"
Exit Sub
End If
' Initialize the software protection platform object with a filter on Office 2013 products
If iVersionNT > 601 Then
Set oProductInstances = oWmiLocal.ExecQuery("SELECT ID, ApplicationId, PartialProductKey, Name, ProductKeyID FROM SoftwareLicensingProduct WHERE ApplicationId = '" & OfficeAppId & "' " & "AND PartialProductKey <> NULL")
Else
Set oProductInstances = oWmiLocal.ExecQuery("SELECT ID, ApplicationId, PartialProductKey, Name, ProductKeyID FROM OfficeSoftwareProtectionProduct WHERE ApplicationId = '" & OfficeAppId & "' " & "AND PartialProductKey <> NULL")
End If
' Remove all licenses
For Each pi in oProductInstances
If NOT IsNull(pi) Then
pi.UninstallProductKey( pi.ProductKeyID)
End If
Next 'pi
End Sub 'CleanOSPP
'-------------------------------------------------------------------------------
' DelSchtasks
'
' Delete know scheduled tasks.
'-------------------------------------------------------------------------------
Sub DelSchtasks ()
Dim sCmd
If CBool(iError AND ERROR_USERCANCEL) Then Exit Sub
LogH2 "Removing scheduled tasks"
LogOnly "FF_INTEGRATEDstreamSchedule"
oWShell.Run "SCHTASKS /Delete /TN FF_INTEGRATEDstreamSchedule /F", 0, False
wscript.sleep 500
LogOnly "FF_INTEGRATEDUPDATEDETECTION"
oWShell.Run "SCHTASKS /Delete /TN FF_INTEGRATEDUPDATEDETECTION /F", 0, False
wscript.sleep 500
LogOnly "C2RAppVLoggingStart"
oWShell.Run "SCHTASKS /Delete /TN C2RAppVLoggingStart /F", 0, False
wscript.sleep 500
LogOnly "Office 15 Subscription Heartbeat"
sCmd = "SCHTASKS /Delete /TN " & Chr(34) & "Office 15 Subscription Heartbeat" & Chr(34) & " /F"
oWShell.Run sCmd, 0, False
wscript.sleep 500
LogOnly "Microsoft Office 15 Sync Maintenance"
sCmd = "SCHTASKS /Delete /TN " & Chr(34) & "Microsoft Office 15 Sync Maintenance for {d068b555-9700-40b8-992c-f866287b06c1}" & Chr(34) & " /F"
oWShell.Run sCmd, 0, False
wscript.sleep 500
LogOnly "OfficeInventoryAgentFallBack"
sCmd = "SCHTASKS /Delete /TN " & Chr(34) & "\Microsoft\Office\OfficeInventoryAgentFallBack" & Chr(34) & " /F"
oWShell.Run sCmd, 0, False
wscript.sleep 500
LogOnly "OfficeTelemetryAgentFallBack"
sCmd = "SCHTASKS /Delete /TN " & Chr(34) & "\Microsoft\Office\OfficeTelemetryAgentFallBack" & Chr(34) & " /F"
oWShell.Run sCmd, 0, False
wscript.sleep 500
LogOnly "OfficeInventoryAgentLogOn"
sCmd = "SCHTASKS /Delete /TN " & Chr(34) & "\Microsoft\Office\OfficeInventoryAgentLogOn" & Chr(34) & " /F"
oWShell.Run sCmd, 0, False
LogOnly "OfficeTelemetryAgentLogOn"
sCmd = "SCHTASKS /Delete /TN " & Chr(34) & "\Microsoft\Office\OfficeTelemetryAgentLogOn" & Chr(34) & " /F"
oWShell.Run sCmd, 0, False
LogOnly "Office Background Streaming"
sCmd = "SCHTASKS /Delete /TN " & Chr(34) & "Office Background Streaming" & Chr(34) & " /F"
oWShell.Run sCmd, 0, False
wscript.sleep 500
LogOnly "Office Automatic Updates"
sCmd = "SCHTASKS /Delete /TN " & Chr(34) & "\Microsoft\Office\Office Automatic Updates" & Chr(34) & " /F"
oWShell.Run sCmd, 0, False
wscript.sleep 500
LogOnly "Office ClickToRun Service Monitor"
sCmd = "SCHTASKS /Delete /TN " & Chr(34) & "\Microsoft\Office\Office ClickToRun Service Monitor" & Chr(34) & " /F"
oWShell.Run sCmd, 0, False
wscript.sleep 500
LogOnly "Office Subscription Maintenance"
sCmd = "SCHTASKS /Delete /TN " & Chr(34) & "Office Subscription Maintenance" & Chr(34) & " /F"
oWShell.Run sCmd, 0, False
wscript.sleep 500
End Sub
'-------------------------------------------------------------------------------
' CloseOfficeApps
'
' End all running instances of applications that will be removed.
'-------------------------------------------------------------------------------
Sub CloseOfficeApps
Dim Processes, Process, app, prop
Dim sAppName, sOut, sUserWarn
Dim fWait
Dim iRet
On Error Resume Next
fWait = False
iProcCloseCnt = iProcCloseCnt + 1
If fRerun Then Exit Sub
If NOT fUserConsent Then
' detect processes to allow a user warning
sUserWarn = "Please save all open documents and close all Office, IE and Windows Explorer applications before proceeding." & vbCrLf & _
"When you click OK this removal process will terminate all running Office, IE and Windows Explorer processes and applications." & vbCrLf & vbCrLf & _
"Click ‘Cancel’ to to end this removal now."
For Each app in dicApps.Keys
sAppName = Replace(app, ".", "%.")
Set Processes = oWmiLocal.ExecQuery("Select * From Win32_Process Where Name like '" & sAppName & "'")
For Each Process in Processes
If NOT InStr(sUserWarn, Process.Name) > 0 Then sUserWarn = sUserWarn & vbCrLf & " - " & Process.Name
Next 'Process
Next 'app
Set Processes = oWmiLocal.ExecQuery("Select * From Win32_Process")
For Each Process in Processes
For Each prop in Process.Properties_
If prop.Name = "ExecutablePath" Then
If IsC2R(prop.Value) Then sUserWarn = sUserWarn & vbCrLf & " - " & Process.Name
End If 'ExcecutablePath
Next 'prop
Next 'Process
If (InStr(sUserWarn, " - ") > 0 AND NOT fQuiet) Then
iRet = MsgBox(sUserWarn, 49, "Save your unsaved work now!")
If iRet = 2 Then
SetError ERROR_USERCANCEL
ExitScript
Else
fUserConsent = True
End If
End If
End If 'fUserConsent
' end known processes first
For Each app in dicApps.Keys
sAppName = Replace(app, ".", "%.")
Set Processes = oWmiLocal.ExecQuery("Select * From Win32_Process Where Name like '" & sAppName & "'")
For Each Process in Processes
sOut = "End process '" & Process.Name
iRet = Process.Terminate()
CheckError "CloseOfficeApps: " & "Process.Name"
Log sOut & "' returned: " & iRet
fWait = True
Next 'Process
Next 'app
' end running applications
Set Processes = oWmiLocal.ExecQuery("Select * From Win32_Process")
For Each Process in Processes
For Each prop in Process.Properties_
If prop.Name = "ExecutablePath" Then
If IsC2R(prop.Value) Then
sOut = "End process '" & Process.Name
iRet = Process.Terminate()
CheckError "CloseOfficeApps: " & "Process.Name"
Log sOut & "' returned: " & iRet
fWait = True
End If
End If 'ExcecutablePath
Next 'prop
Next 'Process
If fWait Then wscript.sleep 5000
End Sub 'CloseOfficeApps
'-------------------------------------------------------------------------------
' Uninstall
'
' Identify and invoke default uninstall command for a regular uninstall.
'-------------------------------------------------------------------------------
Sub Uninstall
Dim OseService, srvc
Dim hDefKey, sSubKeyName, sValue, Name, arrNames, arrTypes
Dim sku, prod, sUninstallCmd, sReturn, sMsiProp, sCmd
Dim sPkgFld, sPkgGuid
Dim i
If CBool(iError AND ERROR_USERCANCEL) Then Exit Sub
' check if OSE service is *installed, *not disabled, *running under System context.
LogH2 "Checking state of OSE service"
Set OseService = oWmiLocal.Execquery("Select * From Win32_Service Where Name like 'ose%'")
For Each srvc in OseService
If (srvc.StartMode = "Disabled") AND (Not srvc.ChangeStartMode("Manual") = 0) Then _
Log "Conflict detected: OSE service is disabled"
If (Not srvc.StartName = "LocalSystem") AND (srvc.Change( , , , , , , "LocalSystem", "")) Then _
Log "Conflict detected: OSE service not running as LocalSystem"
Next 'srvc
If NOT dicC2RSuite.Count > 0 Then
Log "No uninstallable C2R items registered in Uninstall"
End If
' remove the published component registration for C2R packages
LogH2 "Removing published component registration for C2R packages"
' delete the manifest files
For i = 1 To 4
Select Case i
Case 1
RegReadValue HKLM, "SOFTWARE\Microsoft\Office\15.0\ClickToRun", "PackageFolder", sPkgFld, "REG_SZ"
RegReadValue HKLM, "SOFTWARE\Microsoft\Office\15.0\ClickToRun", "PackageGUID", sPkgGuid, "REG_SZ"
Case 2
RegReadValue HKLM, "SOFTWARE\Microsoft\Office\16.0\ClickToRun", "PackageFolder", sPkgFld, "REG_SZ"
RegReadValue HKLM, "SOFTWARE\Microsoft\Office\16.0\ClickToRun", "PackageGUID", sPkgGuid, "REG_SZ"
Case 3
RegReadValue HKLM, "SOFTWARE\Microsoft\Office\ClickToRun", "PackageFolder", sPkgFld, "REG_SZ"
RegReadValue HKLM, "SOFTWARE\Microsoft\Office\ClickToRun", "PackageGUID", sPkgGuid, "REG_SZ"
Case 4
sPkgFld = sPackageFolder
sPkgGuid = sPackageGuid
End Select
If oFso.FolderExists(sValue & "\root\Integration") Then
sCmd = "cmd.exe /c del " & chr(34) & sPkgFld & "\root\Integration\C2RManifest*.xml" & chr(34)
Log " Running: " & sCmd
sReturn = oWShell.Run (sCmd, 0, True)
Log " Return value: " & sReturn
If oFso.FileExists(sPkgFld & "\root\Integration\integrator.exe") Then
sCmd = chr(34) & sPkgFld & "\root\Integration\integrator.exe" & chr(34) & " /U /Extension PackageRoot=" & chr(34) & sPkgFld & "\root" & chr(34) & " PackageGUID=" & sPkgGuid
Log " Running: " & sCmd
sReturn = oWShell.Run (sCmd, 0, True)
Log " Return value: " & sReturn
sCmd = chr(34) & sPkgFld & "\root\Integration\integrator.exe" & chr(34) & " /U"
Log " Running: " & sCmd
sReturn = oWShell.Run (sCmd, 0, True)
Log " Return value: " & sReturn
End If
If oFso.FileExists(sProgramData & "\Microsoft\ClickToRun\{" & sPkgGuid & "}\integrator.exe") Then
sCmd = chr(34) & sProgramData & "\Microsoft\ClickToRun\{" & sPkgGuid & "}\integrator.exe" & chr(34) & " /U /Extension PackageRoot=" & chr(34) & sPkgFld & "\root" & chr(34) & " PackageGUID=" & sPkgGuid
Log " Running: " & sCmd
sReturn = oWShell.Run (sCmd, 0, True)
Log " Return value: " & sReturn
End If
End If
Next 'i
' delete potential blocking registry keys for msiexec based tasks
LogH2 "Removing C2R and App-V registry data"
For Each sku in dicC2RSuite.Keys
' remove the ARP entry
RegDeleteKey HKLM, REG_ARP & sku
Next 'sku
RegDeleteKey HKCU, "SOFTWARE\Microsoft\Office\15.0\ClickToRun"
RegDeleteKey HKLM, "SOFTWARE\Microsoft\Office\15.0\ClickToRun"
RegDeleteKey HKCU, "SOFTWARE\Microsoft\Office\16.0\ClickToRun"
RegDeleteKey HKLM, "SOFTWARE\Microsoft\Office\16.0\ClickToRun"
RegDeleteKey HKCU, "SOFTWARE\Microsoft\Office\ClickToRun"
RegDeleteKey HKLM, "SOFTWARE\Microsoft\Office\ClickToRun"
' AppV keys
hDefKey = HKCU
sSubKeyName = "SOFTWARE\Microsoft\AppV\ISV"
Do
If RegEnumValues(hDefKey, sSubKeyName, arrNames, arrTypes) Then
For Each Name in arrNames
If IsC2R(Name) Then RegDeleteValue hDefKey, sSubKeyName, Name, False
Next 'Name
End If 'RegEnumValues
If hDefKey = HKLM Then Exit Do
hDefKey = HKLM
Loop
' msiexec based uninstall
sMsiProp = " REBOOT=ReallySuppress NOREMOVESPAWN=True"
LogH2 "Detect Msi based products"
For Each prod in oMsi.Products
If CheckDelete(prod) Then
Log "Calling msiexec.exe to remove " & prod
sUninstallCmd = "msiexec.exe /x" & prod & sMsiProp
If fQuiet Then
sUninstallCmd = sUninstallCmd & " /q"
Else
sUninstallCmd = sUninstallCmd & " /qb-!"
End If
sUninstallCmd = sUninstallCmd & " /l*v " & chr(34) & sLogDir & "\Uninstall_" & prod & ".log" & chr(34)
CloseOfficeApps
LogOnly "Calling msiexec with '" & sUninstallCmd & "'"
sReturn = oWShell.Run(sUninstallCmd, 0, True)
Log "msiexec returned: " & SetupRetVal(sReturn) & " (" & sReturn & ")" & vbCrLf
fRebootRequired = fRebootRequired OR (sReturn = "3010")
If fRebootRequired Then SetError ERROR_REBOOT_REQUIRED
Select Case CInt(sReturn)
Case ERROR_SUCCESS,ERROR_SUCCESS_CONFIG_COMPLETE,ERROR_SUCCESS_REBOOT_REQUIRED
'success no action required
Case Else
SetError ERROR_STAGE1
End Select
Else
LogOnly "Skipping out of scope product: " & prod
End If 'CheckDelete
Next 'Product
oWShell.Run "cmd.exe /c net stop msiserver", 0, False
End Sub 'Uninstall
'-------------------------------------------------------------------------------
' RegWipe
'
' Removal of left behind registry data
'-------------------------------------------------------------------------------
Sub Regwipe
Dim hDefKey, item, name, value, RetVal
Dim sGuid, sSubKeyName, sValue, sCmd
Dim i, iLoopCnt
Dim arrKeys, arrNames, arrTypes, arrTestNames, arrTestTypes
Dim arrMultiSzValues, arrMultiSzNewValues
Dim fDelReg
If CBool(iError AND ERROR_USERCANCEL) Then Exit Sub
LogH1 "Registry CleanUp"
CloseOfficeApps
' Note: ARP entries have already been cleared in uninstall stage
' HKCU Registration
RegDeleteKey HKCU, "Software\Microsoft\Office\15.0\Registration"
RegDeleteKey HKCU, "Software\Microsoft\Office\16.0\Registration"
RegDeleteKey HKCU, "Software\Microsoft\Office\Registration"
' C2R specifics
' AppV key "SOFTWARE\Microsoft\AppV" has already been cleared in uninstall stage
' Virtual InstallRoot
RegDeleteKey HKLM, "SOFTWARE\Microsoft\Office\15.0\Common\InstallRoot\Virtual"
RegDeleteKey HKLM, "SOFTWARE\Microsoft\Office\16.0\Common\InstallRoot\Virtual"
RegDeleteKey HKLM, "SOFTWARE\Microsoft\Office\Common\InstallRoot\Virtual"
' Mapi reg
If NOT dictionaryKeepSku.Count > 0 Then RegDeleteKey HKLM, "SOFTWARE\Classes\CLSID\{2027FC3B-CF9D-4ec7-A823-38BA308625CC}"
' C2R keys
RegDeleteKey HKCU, "SOFTWARE\Microsoft\Office\15.0\ClickToRun"
RegDeleteKey HKLM, "SOFTWARE\Microsoft\Office\15.0\ClickToRun"
RegDeleteKey HKLM, "SOFTWARE\Microsoft\Office\15.0\ClickToRunStore"
RegDeleteKey HKCU, "SOFTWARE\Microsoft\Office\16.0\ClickToRun"
RegDeleteKey HKLM, "SOFTWARE\Microsoft\Office\16.0\ClickToRun"
RegDeleteKey HKLM, "SOFTWARE\Microsoft\Office\16.0\ClickToRunStore"
RegDeleteKey HKCU, "SOFTWARE\Microsoft\Office\ClickToRun"
RegDeleteKey HKLM, "SOFTWARE\Microsoft\Office\ClickToRun"
RegDeleteKey HKLM, "SOFTWARE\Microsoft\Office\ClickToRunStore"
' Office key in HKLM
If Not dictionaryKeepSku.Count > 0 Then
'double calls to ensure Wow6432 gets cleared out as well
RegDeleteKey HKLM, "Software\Microsoft\Office\15.0"
RegDeleteKey HKLM, "Software\Microsoft\Office\15.0"
RegDeleteKey HKLM, "Software\Microsoft\Office\16.0"
RegDeleteKey HKLM, "Software\Microsoft\Office\16.0"
End If
ClearOfficeHKLM "SOFTWARE\Microsoft\Office"
' Run key
sSubKeyName = "SOFTWARE\Microsoft\Windows\CurrentVersion\Run"
If RegEnumValues (HKLM, sSubKeyName, arrNames, arrTypes) Then
For Each name in arrNames
If RegReadValue(HKLM, sSubKeyName, name, sValue, "REG_SZ") Then
If IsC2R(sValue) Then RegDeleteValue HKLM, sSubKeyName, name, False
End If
Next 'item
End If
RegDeleteValue HKLM, "SOFTWARE\Microsoft\Windows\CurrentVersion\Run", "Lync15", False
RegDeleteValue HKLM, "SOFTWARE\Microsoft\Windows\CurrentVersion\Run", "Lync16", False
If NOT dictionaryKeepSku.Count > 0 Then
' Protocol Handlers
RegDeleteKey HKLM, "SOFTWARE\Classes\Protocols\Handler\osf"
' Groove ShellIconOverlayIdentifiers
RegDeleteKey HKLM, "SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\ShellIconOverlayIdentifiers\Microsoft SPFS Icon Overlay 1 (ErrorConflict)"
RegDeleteKey HKLM, "SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\ShellIconOverlayIdentifiers\Microsoft SPFS Icon Overlay 2 (SyncInProgress)"
RegDeleteKey HKLM, "SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\ShellIconOverlayIdentifiers\Microsoft SPFS Icon Overlay 3 (InSync)"
RegDeleteKey HKLM, "SOFTWARE\Wow6432Node\Microsoft\Windows\CurrentVersion\Explorer\ShellIconOverlayIdentifiers\Microsoft SPFS Icon Overlay 1 (ErrorConflict)"
RegDeleteKey HKLM, "SOFTWARE\Wow6432Node\Microsoft\Windows\CurrentVersion\Explorer\ShellIconOverlayIdentifiers\Microsoft SPFS Icon Overlay 2 (SyncInProgress)"
RegDeleteKey HKLM, "SOFTWARE\Wow6432Node\Microsoft\Windows\CurrentVersion\Explorer\ShellIconOverlayIdentifiers\Microsoft SPFS Icon Overlay 3 (InSync)"
' Shell extensions
RegDeleteValue HKLM, "SOFTWARE\Microsoft\Windows\CurrentVersion\Shell Extensions\Approved\", "{B28AA736-876B-46DA-B3A8-84C5E30BA492}", False
RegDeleteValue HKLM, "SOFTWARE\Microsoft\Windows\CurrentVersion\Shell Extensions\Approved\", "{8B02D659-EBBB-43D7-9BBA-52CF22C5B025}", False
RegDeleteValue HKLM, "SOFTWARE\Microsoft\Windows\CurrentVersion\Shell Extensions\Approved\", "{0875DCB6-C686-4243-9432-ADCCF0B9F2D7}", False
RegDeleteValue HKLM, "SOFTWARE\Microsoft\Windows\CurrentVersion\Shell Extensions\Approved\", "{42042206-2D85-11D3-8CFF-005004838597}", False
RegDeleteValue HKLM, "SOFTWARE\Microsoft\Windows\CurrentVersion\Shell Extensions\Approved\", "{993BE281-6695-4BA5-8A2A-7AACBFAAB69E}", False
RegDeleteValue HKLM, "SOFTWARE\Microsoft\Windows\CurrentVersion\Shell Extensions\Approved\", "{C41662BB-1FA0-4CE0-8DC5-9B7F8279FF97}", False
RegDeleteValue HKLM, "SOFTWARE\Microsoft\Windows\CurrentVersion\Shell Extensions\Approved\", "{506F4668-F13E-4AA1-BB04-B43203AB3CC0}", False
RegDeleteValue HKLM, "SOFTWARE\Microsoft\Windows\CurrentVersion\Shell Extensions\Approved\", "{D66DC78C-4F61-447F-942B-3FB6980118CF}", False
RegDeleteValue HKLM, "SOFTWARE\Microsoft\Windows\CurrentVersion\Shell Extensions\Approved\", "{46137B78-0EC3-426D-8B89-FF7C3A458B5E}", False
' BHO
RegDeleteKey HKLM, "SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Browser Helper Objects\{31D09BA0-12F5-4CCE-BE8A-2923E76605DA}"
RegDeleteKey HKLM, "SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Browser Helper Objects\{B4F3A835-0E21-4959-BA22-42B3008E02FF}"
RegDeleteKey HKLM, "SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Browser Helper Objects\{D0498E0A-45B7-42AE-A9AA-ABA463DBD3BF}"
RegDeleteKey HKLM, "SOFTWARE\Wow6432Node\Microsoft\Windows\CurrentVersion\Explorer\Browser Helper Objects\{31D09BA0-12F5-4CCE-BE8A-2923E76605DA}"
RegDeleteKey HKLM, "SOFTWARE\Wow6432Node\Microsoft\Windows\CurrentVersion\Explorer\Browser Helper Objects\{B4F3A835-0E21-4959-BA22-42B3008E02FF}"
RegDeleteKey HKLM, "SOFTWARE\Wow6432Node\Microsoft\Windows\CurrentVersion\Explorer\Browser Helper Objects\{D0498E0A-45B7-42AE-A9AA-ABA463DBD3BF}"
' OneNote Namespace Extension for Desktop
RegDeleteKey HKLM, "SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Desktop\NameSpace\{0875DCB6-C686-4243-9432-ADCCF0B9F2D7}"
' Web Sites
RegDeleteKey HKLM, "SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Desktop\Namespace\{B28AA736-876B-46DA-B3A8-84C5E30BA492}"
RegDeleteKey HKLM, "SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\NetworkNeighborhood\Namespace\{46137B78-0EC3-426D-8B89-FF7C3A458B5E}"
' VolumeCaches
RegDeleteKey HKLM, "SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\VolumeCaches\Microsoft Office Temp Files"
End If 'NOT dictionaryKeepSku.Count > 0
' ARP
' Note: configuration entries have already been removed
' as part of the 'Uninstall' stage
If RegEnumKey(HKLM, REG_ARP, arrKeys) Then
For Each item in arrKeys
If Len(item) > 37 Then
sGuid = UCase(Left(item, 38))
If CheckDelete(sGuid) Then RegDeleteKey HKLM, REG_ARP & item & "\"
End If 'Len(Item)>37
Next 'Item
End If
' UpgradeCodes, WI config, WI global config
LogH2 "Scanning Windows Installer metadata for removeable UpgradeCodes"
For iLoopCnt = 1 to 5
Select Case iLoopCnt
Case 1
sSubKeyName = "SOFTWARE\Microsoft\Windows\CurrentVersion\Installer\UpgradeCodes\"
hDefKey = HKLM
Case 2
sSubKeyName = "Installer\UpgradeCodes\"
hDefKey = HKCR
Case 3
sSubKeyName = "SOFTWARE\Microsoft\Windows\CurrentVersion\Installer\UserData\S-1-5-18\Products\"
hDefKey = HKLM
Case 4
sSubKeyName = "Installer\Features\"
hDefKey = HKCR
Case 5
sSubKeyName = "Installer\Products\"
hDefKey = HKCR
End Select
If RegEnumKey(hDefKey, sSubKeyName, arrKeys) Then
For Each item in arrKeys
' ensure 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 CheckDelete(sGuid) Then
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
If NOT RegEnumValues(hDefKey, sSubKeyName & item, arrNames, arrTypes) Then RegDeleteKey hDefKey, sSubKeyName & item & "\"
Else 'iLoopCnt >= 3
RegDeleteKey hDefKey, sSubKeyName & item & "\"
End If 'iLoopCnt < 3
End If 'InScope
End If 'Len(Item)=32
Next 'Item
End If 'RegEnumKey
Next 'iLoopCnt
' Components in Global
LogH2 "Scanning Windows Installer Global Components metadata"
sSubKeyName = "SOFTWARE\Microsoft\Windows\CurrentVersion\Installer\UserData\S-1-5-18\Components\"
hDefKey = HKLM
If RegEnumKey(hDefKey, sSubKeyName, arrKeys) Then
For Each item in arrKeys
' ensure the expected length for a compressed GUID
If Len(Item) = 32 Then
If RegEnumValues(hDefKey, sSubKeyName & item, arrNames, arrTypes) Then
For Each name in arrNames
If Len(Name) = 32 Then
sGuid = GetExpandedGuid(Name)
If CheckDelete(sGuid) Then
RegDeleteValue hDefKey, sSubKeyName & item & "\", name, False
' if all entries were removed - delete the key
If NOT RegEnumValues(hDefKey, sSubKeyName & item, arrTestNames, arrTestTypes) Then RegDeleteKey hDefKey, sSubKeyName & item & "\"
End If
End If '32
Next 'Name
End If 'RegEnumValues
End If '32
Next 'Item
End If 'RegEnumKey
' Published Components
LogH2 "Scanning Windows Installer Published Components metadata"
sSubKeyName = "Installer\Components\"
hDefKey = HKCR
If RegEnumKey(hDefKey, sSubKeyName, arrKeys) Then
For Each item in arrKeys
' ensure the expected length for a compressed GUID
If Len(Item) = 32 Then
If RegEnumValues(hDefKey, sSubKeyName & item, arrNames, arrTypes) Then
For Each name in arrNames
If RegReadValue (hDefKey, sSubKeyName & item, name, sValue, "REG_MULTI_SZ") Then
arrMultiSzValues = Split(sValue, chr(13))
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 UBound(arrMultiSzValues) = i Then oReg.SetMultiStringValue hDefKey, sSubKeyName & item, name,arrMultiSzNewValues
Else
If fDelReg Then
RegDeleteValue hDefKey, sSubKeyName & item & "\", name, True
' if all entries were removed - delete the key
If NOT RegEnumValues(hDefKey, sSubKeyName & item, arrTestNames, arrTestTypes) Then RegDeleteKey hDefKey, sSubKeyName & item & "\"
End If 'DelReg
End If
End If 'IsArray
End If
Next 'Name
End If 'RegEnumValues
End If '32
Next 'Item
End If 'RegEnumKey
End Sub 'Regwipe
'-------------------------------------------------------------------------------
' FileWipe
'
' Removal of left behind services, files and shortcuts
'-------------------------------------------------------------------------------
Sub FileWipe
Dim scRoot
Dim fDelFolders
If CBool(iError AND ERROR_USERCANCEL) Then Exit Sub
LogH1 "File Cleanup"
fDelFolders = False
CloseOfficeApps
DelSchtasks
' remove the OfficeSvc service
LogH2 "Deleting OfficeSvc service"
DeleteService "OfficeSvc"
' SP1 addition / change
' remove the ClickToRunSvc service
LogH2 "Deleting ClickToRunSvc service"
DeleteService "ClickToRunSvc"
' adding additional processes for termination
dicApps.Add "explorer.exe", "explorer.exe"
dicApps.Add "msiexec.exe", "msiexec.exe"
dicApps.Add "ose.exe", "ose.exe"
If fC2R Then
' delete C2R package files
LogH2 "Deleting C2R package files"
If oFso.FolderExists(sProgramFiles & "\Microsoft Office 15") _
Or oFso.FolderExists(sProgramFiles & "\Microsoft Office 16") _
Or oFso.FolderExists(oWShell.ExpandEnvironmentStrings("%programfiles%") & "\Microsoft Office\PackageManifests") _
Or oFso.FolderExists(oWShell.ExpandEnvironmentStrings("%programfiles(x86)%") & "\Microsoft Office\PackageManifests") Then
fDelFolders = True
Log " Attention: Now closing Explorer.exe for file delete operations"
Log " Explorer will automatically restart."
wscript.sleep 2000
CloseOfficeApps
End If
' delete Office folders
LogH2 "Deleting Office folders"
DeleteFolder sProgramFiles & "\Microsoft Office 15"
DeleteFolder sProgramFiles & "\Microsoft Office 16"
If f64 Then
DeleteFolder sCommonProgramFilesX86 & "\Microsoft Office 15"
DeleteFolder sCommonProgramFilesX86 & "\Microsoft Office 16"
End If
If fDelFolders Then
DeleteFolder sProgramFiles & "\Microsoft Office\PackageManifests"
DeleteFolder sProgramFiles & "\Microsoft Office\PackageSunrisePolicies"
DeleteFolder sProgramFiles & "\Microsoft Office\root"
DeleteFile sProgramFiles & "\Microsoft Office\AppXManifest.xml"
DeleteFile sProgramFiles & "\Microsoft Office\FileSystemMetadata.xml"
If Not dictionaryKeepSku.Count > 0 Then
DeleteFolder sProgramFiles & "\Microsoft Office\Office16"
DeleteFolder sProgramFiles & "\Microsoft Office\Office15"
End If
If f64 Then
DeleteFolder sProgramFilesX86 & "\Microsoft Office\PackageManifests"
DeleteFolder sProgramFilesX86 & "\Microsoft Office\PackageSunrisePolicies"
DeleteFolder sProgramFilesX86 & "\Microsoft Office\root"
DeleteFile sProgramFilesX86 & "\Microsoft Office\AppXManifest.xml"
DeleteFile sProgramFilesX86 & "\Microsoft Office\FileSystemMetadata.xml"
If Not dictionaryKeepSku.Count > 0 Then
DeleteFolder sProgramFilesX86 & "\Microsoft Office\Office16"
DeleteFolder sProgramFilesX86 & "\Microsoft Office\Office15"
End If
End If
End If
DeleteFolder sProgramData & "\Microsoft\ClickToRun"
DeleteFolder sCommonProgramFiles & "\microsoft shared\ClickToRun"
DeleteFolder sProgramData & "\Microsoft\office\FFPackageLocker"
DeleteFolder sProgramData & "\Microsoft\office\ClickToRunPackageLocker"
If oFso.FileExists(sProgramData & "\Microsoft\office\FFPackageLocker") Then DeleteFile sProgramData & "\Microsoft\office\FFPackageLocker"
If oFso.FileExists(sProgramData & "\Microsoft\office\FFStatePBLocker") Then DeleteFile sProgramData & "\Microsoft\office\FFStatePBLocker"
If NOT dictionaryKeepSku.Count > 0 Then DeleteFolder sProgramData & "\Microsoft\office\Heartbeat"
DeleteFolder oWShell.ExpandEnvironmentStrings("%userprofile%") & "\Microsoft Office"
DeleteFolder oWShell.ExpandEnvironmentStrings("%userprofile%") & "\Microsoft Office 15"
DeleteFolder oWShell.ExpandEnvironmentStrings("%userprofile%") & "\Microsoft Office 16"
End If
' restore explorer.exe if needed
RestoreExplorer
' delete shortcuts
LogH2 "Search and delete shortcuts"
CleanShortcuts sAllUsersProfile, True, False
CleanShortcuts sProfilesDirectory, True, False
' delete empty folder structures
If dicDelFolder.Count > 0 Then
LogH2 "Removing empty folders"
DeleteEmptyFolders
End If
' add the collected files in use for delete on reboot
If dicDelInUse.Count > 0 Then ScheduleDeleteEx
LogH2 "File Cleanup complete"
End Sub ' FileWipe
'-------------------------------------------------------------------------------
' 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
fDeleteSC = False
LogOnly " check file: " & file.Path
set sc = oWShell.CreateShortcut(file.Path)
If Err <> 0 Then
CheckError "CleanShortcutsSC: " & vbTab & sFolder
Else
'Compare if the shortcut target is in the list of executables that will be removed
'LogOnly " - SC.TargetPath: " & sc.TargetPath
If Len(sc.TargetPath) > 0 Then
If InStr(sc.TargetPath,"{") > 0 Then
'Handle Windows Installer shortcuts
If Len(sc.TargetPath) >= InStr(sc.TargetPath,"{") + 37 Then
If CheckDelete(Mid(sc.TargetPath, InStr(sc.TargetPath,"{"), 38)) Then fDeleteSC = True
End If
Else
'Handle regular shortcuts
If IsC2R(sc.TargetPath) Then fDeleteSC = True
If NOT oFso.FileExists(sc.TargetPath) Then
' Shortcut target does not exist
If IsC2R(sc.TargetPath) Then
LogOnly "removing Office shortcut with non-existent target: " & file.Path & " - " & sc.TargetPath
fDeleteSC = True
Else
'LogOnly " - keep orphaned SC as target is not in scope: " & sc.TargetPath
End If
Else
'LogOnly " - keep SC as shortcut target does still exist: " & sc.TargetPath
End If
End If
End If
End If
If fDeleteSC Then
If NOT dicDelFolder.Exists(sFolder) Then dicDelFolder.Add sFolder, sFolder
If fUnPin Then UnPin file
If fDelete Then
UnPin file
DeleteFile file.Path
End If
fDeleteSC = False
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 > 600 Then verb.DoIt
End Select
Next
On Error Goto 0
End Sub
'-------------------------------------------------------------------------------
' ClearOfficeHKLM
'
' Recursively search and clear the HKLM Office key from references in scope
'-------------------------------------------------------------------------------
Sub ClearOfficeHKLM (sSubKeyName)
Dim key, name
Dim sValue
Dim arrKeys, arrNames, arrTypes
Dim arrTestNames, arrTestTypes, arrTestKeys
' recursion
If RegEnumKey(HKLM, sSubKeyName, arrKeys) Then
For Each key in arrKeys
ClearOfficeHKLM sSubKeyName & "\" & key
Next 'key
End If
' identify & clear removable entries
If RegEnumValues(HKLM, sSubKeyName, arrNames, arrTypes) Then
For Each name in arrNames
If RegReadValue(HKLM, sSubKeyName, name, sValue, "REG_SZ") Then
If IsC2R(sValue) Then RegDeleteValue HKLM, sSubKeyName, name, False
End If
Next 'item
End If
' clear out empty keys
If (NOT RegEnumValues(HKLM, sSubKeyName, arrNames, arrTypes)) AND _
(NOT RegEnumKey(HKLM, sSubKeyName, arrKeys)) AND _
(NOT dictionaryKeepSku.Count > 0) Then _
RegDeleteKey HKLM, sSubKeyName
End Sub
'-------------------------------------------------------------------------------
'
' Helper Functions
'
'-------------------------------------------------------------------------------
'-------------------------------------------------------------------------------
' IsC2R
'
' Check if the passed in string is related to C2R
' Returns TRUE if in C2R scope
'-------------------------------------------------------------------------------
Function IsC2R (sValue)
Const OREF = "\ROOT\OFFICE1"
Const OREFROOT = "Microsoft Office\Root\"
Const OREGREFC2R15 = "Microsoft Office 15"
Const OREGREFC2R16 = "Microsoft Office 16"
Const OCOMMON = "\microsoft shared\ClickToRun"
Const OMANIFEST = "\Microsoft Office\PackageManifests"
Const OSUNRISE = "\Microsoft Office\PackageSunrisePolicies"
Dim fReturn
fReturn = False
If InStr(LCase(sValue), LCase(OREF)) > 0 _
Or InStr(LCase(sValue), LCase(OREFROOT)) > 0 _
Or InStr(LCase(sValue), LCase(OCOMMON)) > 0 _
Or InStr(LCase(sValue), LCase(OMANIFEST)) > 0 _
Or InStr(LCase(sValue), LCase(OSUNRISE)) > 0 _
Or InStr(LCase(sValue), LCase(OREGREFC2R15)) > 0 _
Or InStr(LCase(sValue), LCase(OREGREFC2R16)) > 0 Then fReturn = True
IsC2R = fReturn
End Function
'-------------------------------------------------------------------------------
' CheckRegPermissions
'
' Test the permissions on some key registry locations to determine if
' sufficient permissions are given.
'-------------------------------------------------------------------------------
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 = "Software\Microsoft\Windows\"
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
'-------------------------------------------------------------------------------
' GetMyProcessId
'
' Returns the process id of the own process
'-------------------------------------------------------------------------------
Function GetMyProcessId()
Dim iParentProcessId
iParentProcessId = 0
' try to obtain from creating a new cscript instance
On Error Resume Next
iParentProcessId = GetObject("winmgmts:root\cimv2").Get("Win32_Process.Handle='" & oWShell.Exec("cscript.exe").ProcessId & "'").ParentProcessId
On Error Goto 0
If iParentProcessId > 0 Then
' succeeded to obtain the process id
GetMyProcessId = iParentProcessId
Exit Function
End If
' failed to obtain the id from the creation of a new instance
' get it from enum of Win32_Process
Dim Process, Processes
Err.Clear
Set Processes = oWmiLocal.ExecQuery("Select * From Win32_Process WHERE Name='cscript.exe' AND CommandLine like '%" & SCRIPTNAME & "%'")
For Each Process in Processes
iParentProcessId = Process.ProcessId
Exit For
Next
GetMyProcessId = iParentProcessId
End Function 'GetMyProcessId
'-------------------------------------------------------------------------------
' Delimiter
'
' 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
'-------------------------------------------------------------------------------
' GetExpandedGuid
'
' Returns the expanded string from a compressed GUID
'-------------------------------------------------------------------------------
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 'GetExpandedGuid
'-------------------------------------------------------------------------------
' GetCompressedGuid
'
' Returns the compressed string for a GUID
'-------------------------------------------------------------------------------
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
'-------------------------------------------------------------------------------
' GetDecodedGuid
'
' Returns the GUID from a squished format
'-------------------------------------------------------------------------------
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
'-------------------------------------------------------------------------------
' DecToHex
'
' 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
'-------------------------------------------------------------------------------
' RelaunchAs64Host
'
' Relaunch self with 64 bit CScript host
'-------------------------------------------------------------------------------
Sub RelaunchAs64Host
Dim Argument, sCmd
sCmd = Replace(LCase(wscript.Path), "syswow64", "sysnative") & "\cscript.exe " & Chr(34) & WScript.scriptFullName & Chr(34)
If Wscript.Arguments.Count > 0 Then
For Each Argument in Wscript.Arguments
sCmd = sCmd & " " & chr(34) & Argument & chr(34)
Next 'Argument
End If
Wscript.Quit CLng(oWShell.Run(sCmd, 1, True))
End Sub 'RelaunchAs64Host
'-------------------------------------------------------------------------------
' RelaunchElevated
'
' Relaunch the script with elevated permissions
'-------------------------------------------------------------------------------
Sub RelaunchElevated
Dim Argument, Process, Processes
Dim iParentProcessId, iSpawnedProcessId
Dim sCmdLine, sRetValFile, sValue
Dim oShell
SetError ERROR_RELAUNCH
' Shell object for relaunch
Set oShell = CreateObject("Shell.Application")
' build command line for relaunch
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
SetError ERROR_ELEVATION_FAILED
Case "UAC"
'Already tried elevated relaunch
SetError ERROR_ELEVATION_FAILED
Exit Sub
Case Else
sCmdLine = sCmdLine & " " & chr(34) & Argument & chr(34)
End Select
Next 'Argument
End If
' prep work to get the return value from the elevated process
iParentProcessId = GetMyProcessId
' ' make user aware of elevation attempt after reboot
' If RegReadValue(HKCU, "SOFTWARE\Microsoft\Office\15.0\CleanC2R", "Rerun", sValue, "REG_DWORD") Then
' oWShell.Popup "System reboot complete. OffScrub will now prompt for elevation!", 10, SCRIPTNAME & " - NOTE!"
' End If
' launch the elevated instance
oShell.ShellExecute "cscript.exe", sCmdLine & " /NoElevate UAC", "", "runas", 1
' get the process id of the spawned instance
WScript.Sleep 500
Set Processes = oWmiLocal.ExecQuery("Select * From Win32_Process WHERE ParentProcessId='" & iParentProcessId & "'")
If Processes.Count > 0 Then
For Each Process in Processes
iSpawnedProcessId = Process.ProcessId
Exit For
Next 'Process
' monitor the tasklist to detect the end of the spawned process
While oWmiLocal.ExecQuery("Select * From Win32_Process WHERE ProcessId='" & iSpawnedProcessId & "'").Count > 0
WScript.Sleep 3000
Wend
' get the return value from the file
Wscript.Quit GetRetValFromFile
End If
' elevation failed (user declined)
SetError ERROR_ELEVATION_USERDECLINED
End Sub 'RelaunchElevated
'-------------------------------------------------------------------------------
' RelaunchAsCScript
'
' Relaunch self with Cscript as host
'-------------------------------------------------------------------------------
Sub RelaunchAsCScript
Dim Argument
Dim sCmdLine
SetError ERROR_RELAUNCH
sCmdLine = "cmd.exe /c " & 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
Wscript.Quit CLng(oWShell.Run(sCmdLine, 1, True))
End Sub 'RelaunchAsCScript
'-------------------------------------------------------------------------------
' SetError
'
' Set error bit(s)
'-------------------------------------------------------------------------------
Sub SetError(ErrorBit)
iError = iError OR ErrorBit
Select Case ErrorBit
Case ERROR_DCAF_FAILURE, ERROR_STAGE2, ERROR_ELEVATION_USERDECLINED, ERROR_ELEVATION, ERROR_SCRIPTINIT
iError = iError OR ERROR_FAIL
End Select
End Sub
'-------------------------------------------------------------------------------
' ClearError
'
' Unset error bit(s)
'-------------------------------------------------------------------------------
Sub ClearError(ErrorBit)
iError = iError AND (ERROR_ALL - ErrorBit)
Select Case ErrorBit
Case ERROR_ELEVATION_USERDECLINED, ERROR_ELEVATION, ERROR_SCRIPTINIT
iError = iError AND (ERROR_ALL - ERROR_FAIL)
End Select
End Sub
'-------------------------------------------------------------------------------
' SetRetVal
'
' Write return value to file
'-------------------------------------------------------------------------------
Sub SetRetVal(iError)
Dim RetValFileStream
'don't fail script execution if writing the return value to file fails
On Error Resume Next
Set RetValFileStream = oFso.createTextFile(sScrubDir & "\" & RETVALFILE, True, True)
RetValFileStream.Write iError
RetValFileStream.Close
On Error Goto 0
End Sub 'SetRetVal
'-------------------------------------------------------------------------------
' GetRetValFromFile
'
' Read return value from file.
' Used to ensure return value can get obtained from an elevated process
'-------------------------------------------------------------------------------
Function GetRetValFromFile ()
Dim RetValFileStream
Dim iRetValFromFile
On Error Resume Next 'don't fail script execution when getting the return value from file fails
If oFso.FileExists(sScrubDir & "\" & RETVALFILE) Then
Set RetValFileStream = oFso.OpenTextFile(sScrubDir & "\" & RETVALFILE, 1, False, -2)
GetRetValFromFile = RetValFileStream.ReadAll
RetValFileStream.Close
Exit Function
End If
Err.Clear
On Error Goto 0
GetRetValFromFile = ERROR_UNKNOWN
End Function 'GetRetValFromFile
'-------------------------------------------------------------------------------
' CreateLog
'
' Create the removal log file
'-------------------------------------------------------------------------------
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
On Error Goto 0
Log "Microsoft Customer Support Services - " & ONAME & " Removal Utility" & vbCrLf &_
"Removes "& ONAME & " when a regular uninstall is no longer possible." & vbCrLf & vbCrLf & _
"Version: " & vbTab & SCRIPTVERSION & vbCrLf & _
"64 bit OS: " & vbTab & f64 & vbCrLf & _
"Removal start: " & vbTab & Time & vbCrLf
fLogInitialized = True
End Sub 'CreateLog
'-------------------------------------------------------------------------------
' HiveString
'
' Translates the numeric constant into the human readable registry hive string
'-------------------------------------------------------------------------------
Function HiveString(hDefKey)
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
'-------------------------------------------------------------------------------
' RegKeyExists
'
' Returns a boolean for the test on existence of a given registry key
'-------------------------------------------------------------------------------
Function RegKeyExists(hDefKey, sSubKeyName)
Dim arrKeys
RegKeyExists = False
If oReg.EnumKey(hDefKey, sSubKeyName, arrKeys) = 0 Then RegKeyExists = True
End Function
'-------------------------------------------------------------------------------
' RegValExists
'
' Returns a boolean for the test on existence of a given registry value
'-------------------------------------------------------------------------------
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
'-------------------------------------------------------------------------------
' RegReadValue
'
' Read the value of a given registry entry
' The correct type has to be passed in as argument
'-------------------------------------------------------------------------------
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 "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 "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)
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(13))
Case Else
RetVal = -1
End Select 'sValue
RegReadValue = (RetVal = 0)
End Function 'RegReadValue
'-------------------------------------------------------------------------------
' RegEnumValues
'
' 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
'-------------------------------------------------------------------------------
' RegEnumKey
'
' 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
'-------------------------------------------------------------------------------
' RegDeleteValue
'
' Wrapper around oReg.DeleteValue to handle 64 bit
'-------------------------------------------------------------------------------
Sub RegDeleteValue(hDefKey, sSubKeyName, sName, fRegMultiSZ)
Dim sDelKeyName, sValue
Dim iRetVal
Dim fKeep
' ensure trailing "\"
sSubKeyName = sSubKeyName & "\"
While InStr(sSubKeyName, "\\") > 0
sSubKeyName = Replace(sSubKeyName, "\\", "\")
Wend
fKeep = dictionaryKeepReg.Exists(LCase(sSubKeyName & sName))
If (NOT fKeep AND f64) Then fKeep = dictionaryKeepReg.Exists(LCase(Wow64Key(hDefKey, sSubKeyName) & sName))
If fKeep Then
LogOnly "Disallowing the delete of still required keypath element: " & HiveString(hDefKey) & "\" & sSubKeyName & sName
If NOT fForce Then Exit Sub
End If
' check on forced delete
If fKeep Then
LogOnly "Enforced delete of still required keypath element: " & HiveString(hDefKey) & "\" & sSubKeyName & sName
LogOnly " Remaining applications will need a repair!"
End If
' ensure value exists
If RegValExists(hDefKey, sSubKeyName, sName) Then
sDelKeyName = sSubKeyName
ElseIf RegValExists(hDefKey, Wow64Key(hDefKey, sSubKeyName), sName) Then
sDelKeyName = Wow64Key(hDefKey, sSubKeyName)
Else
LogOnly "Value not found. Cannot delete value: " & HiveString(hDefKey) & "\" & sSubKeyName & sName
Exit Sub
End If
' prevent unintentional, unsafe REG_MULTI_SZ delete
If RegReadValue(hDefKey, sDelKeyName, sName, sValue, "REG_MULTI_SZ") AND NOT fRegMultiSZ Then
LogOnly "Disallowing unsafe delete of REG_MULTI_SZ: " & HiveString(hDefKey) & "\" & sDelKeyName & sName
Exit Sub
End If
' execute delete operation
If Not fDetectOnly Then
LogOnly "Delete registry value: " & HiveString(hDefKey) & "\" & sDelKeyName & " -> " & sName
iRetVal = 0
iRetVal = oReg.DeleteValue(hDefKey, sDelKeyName, sName)
CheckError "RegDeleteValue"
If NOT (iRetVal = 0) Then
LogOnly " Delete failed. Return value: " & iRetVal
SetError ERROR_STAGE2
End If
Else
LogOnly "Preview mode. Disallowing delete registry value: " & HiveString(hDefKey) & "\" & sDelKeyName & " -> " & sName
End If
On Error Goto 0
End Sub 'RegDeleteValue
'-------------------------------------------------------------------------------
' RegDeleteKey
'
' Wrappper around RegDeleteKeyEx to handle 64bit
'-------------------------------------------------------------------------------
Sub RegDeleteKey(hDefKey, sSubKeyName)
Dim sDelKeyName
Dim fKeep
' ensure trailing "\"
sSubKeyName = sSubKeyName & "\"
While InStr(sSubKeyName, "\\") > 0
sSubKeyName = Replace(sSubKeyName, "\\", "\")
Wend
fKeep = dictionaryKeepReg.Exists(LCase(sSubKeyName))
If (NOT fKeep AND f64) Then fKeep = dictionaryKeepReg.Exists(LCase(Wow64Key(hDefKey, sSubKeyName)))
If fKeep Then
LogOnly "Disallowing the delete of still required keypath element: " & HiveString(hDefKey) & "\" & sSubKeyName
If NOT fForce Then Exit Sub
End If
' check on forced delete
If fKeep Then
LogOnly "Enforced delete of still required keypath element: " & HiveString(hDefKey) & "\" & sSubKeyName
LogOnly " Remaining applications will need a repair!"
End If
If Len(sSubKeyName) > 1 Then
'Strip of trailing "\"
sSubKeyName = Left(sSubKeyName, Len(sSubKeyName) - 1)
End If
' ensure key exists
If RegKeyExists(hDefKey, sSubKeyName) Then
sDelKeyName = sSubKeyName
ElseIf f64 AND RegKeyExists(hDefKey, Wow64Key(hDefKey, sSubKeyName)) Then
sDelKeyName = Wow64Key(hDefKey, sSubKeyName)
Else
LogOnly "Key not found. Cannot delete key: " & HiveString(hDefKey) & "\" & sSubKeyName
Exit Sub
End If
' execute delete
If Not fDetectOnly Then
LogOnly "Delete registry key: " & HiveString(hDefKey) & "\" & sDelKeyName
On Error Resume Next
RegDeleteKeyEx hDefKey, sDelKeyName
On Error Goto 0
Else
LogOnly "Preview mode. Disallowing delete of registry key: " & HiveString(hDefKey) & "\" & sSubKeyName
End If
End Sub 'RegDeleteKey
'-------------------------------------------------------------------------------
' RegDeleteKeyEx
'
' Recursively delete a registry structure
'-------------------------------------------------------------------------------
Sub RegDeleteKeyEx(hDefKey, sSubKeyName)
Dim arrSubkeys
Dim sSubkey
Dim iRetVal
'Strip of trailing "\"
If Len(sSubKeyName) > 1 Then
If Right(sSubKeyName, 1) = "\" Then sSubKeyName = Left(sSubKeyName, Len(sSubKeyName) - 1)
End If
On Error Resume Next
' exception handler
If (hDefKey = HKLM) AND (sSubKeyName = "SOFTWARE\Microsoft\Office\15.0\ClickToRun") Then
iRetVal = oWShell.Run("reg delete HKLM\SOFTWARE\Microsoft\Office\15.0\ClickToRun /f", 0, True)
Exit Sub
End If
' regular recursion
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
On Error Goto 0
End Sub 'RegDeleteKeyEx
'-------------------------------------------------------------------------------
' Wow64Key
'
' Return the 32bit regkey location on a 64bit environment
'-------------------------------------------------------------------------------
Function Wow64Key(hDefKey, sSubKeyName)
Dim iPos
Select Case hDefKey
Case HKCU
If Left(sSubKeyName, 17) = "Software\Classes\" 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) = "Software\Classes\" 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
'-------------------------------------------------------------------------------
' RemoveDuplicates
'
' Remove duplicate entries from a one dimensional array
'-------------------------------------------------------------------------------
Function RemoveDuplicates(Array)
Dim Item
Dim dicNoDupes
Set dicNoDupes = CreateObject("Scripting.Dictionary")
For Each Item in Array
If Not dicNoDupes.Exists(Item) Then dicNoDupes.Add Item,Item
Next 'Item
RemoveDuplicates = dicNoDupes.Keys
End Function 'RemoveDuplicates
'-------------------------------------------------------------------------------
' CheckError
'
' Checks the status of 'Err' and logs the error details if <> 0
'-------------------------------------------------------------------------------
Sub CheckError(sModule)
If Err <> 0 Then
LogOnly " Error: " & sModule & " - Source: " & Err.Source & "; Err# (Hex): " & Hex( Err ) & _
"; Err# (Dec): " & Err & "; Description : " & Err.Description
End If 'Err = 0
Err.Clear
End Sub
'-------------------------------------------------------------------------------
' LogH
'
' Write a header log string to the log file
'-------------------------------------------------------------------------------
Sub LogH (sLog)
LogStream.WriteLine ""
sLog = sLog & vbCrLf & String(Len(sLog), "=")
If NOT fQuiet AND fCScript Then wscript.echo ""
If NOT fQuiet AND fCScript Then wscript.echo sLog
LogStream.WriteLine sLog
End Sub 'Logh
'-------------------------------------------------------------------------------
' LogH1
'
' Write a header log string to the log file
'-------------------------------------------------------------------------------
Sub LogH1 (sLog)
LogStream.WriteLine ""
sLog = sLog & vbCrLf & String(Len(sLog), "-")
If NOT fQuiet AND fCScript Then wscript.echo ""
If NOT fQuiet AND fCScript Then wscript.echo sLog
LogStream.WriteLine sLog
End Sub 'LogH1
'-------------------------------------------------------------------------------
' LogH2
'
' Write w/o indent Cmd window and the log file
'-------------------------------------------------------------------------------
Sub LogH2 (sLog)
If NOT fQuiet AND fCScript Then wscript.echo sLog
LogStream.WriteLine ""
LogStream.WriteLine sLog
End Sub 'LogH2
'-------------------------------------------------------------------------------
' Log
'
' Echos the log string to the Cmd window and the log file
'-------------------------------------------------------------------------------
Sub Log (sLog)
If NOT fQuiet AND fCScript Then wscript.echo sLog
LogStream.WriteLine " " & Time & ": " & sLog
End Sub 'Log
'-------------------------------------------------------------------------------
' LogOnly
'
' Commits the log string to the log file
'-------------------------------------------------------------------------------
Sub LogOnly (sLog)
LogStream.WriteLine " " & Time & ": " & sLog
End Sub 'Log
'-------------------------------------------------------------------------------
' InScope
'
' Check if ProductCode is in scope for removal
'-------------------------------------------------------------------------------
'Check if ProductCode is in scope
Function InScope(sProductCode)
Dim fInScope
Dim sProd
Const OFFICEID = "0000000FF1CE}"
On Error Resume Next
fInScope = False
If Len(sProductCode) = 38 Then
sProd = UCase(sProductCode)
If Right(sProd, PRODLEN) = OFFICEID Then
If CInt(Mid(sProd, 4, 2)) > 14 Then
If Err <> 0 Then
Err.Clear
Exit Function
End If
Select Case Mid(sProd, 11, 4)
Case "007E", "008F", "008C", "24E1", "237A"
fInScope = True
End Select
End If
End If
' Microsoft Online Services Sign-in Assistant (x64 ship and x86 ship)
If sProd = "{6C1ADE97-24E1-4AE4-AEDD-86D3A209CE60}" Then fInScope = True
If sProd = "{9520DDEB-237A-41DB-AA20-F2EF2360DCEB}" Then fInScope = True
If sProd = UCase(sPackageGuid) Then fInScope = True
If sProd = UCase("{9AC08E99-230B-47e8-9721-4577B7F124EA}") Then fInScope = True
End If '38
InScope = fInScope
End Function 'InScope
'-------------------------------------------------------------------------------
' CheckDelete
'
' Check a ProductCode is known to stay installed
'-------------------------------------------------------------------------------
Function CheckDelete(sProductCode)
CheckDelete = False
' ensure valid GUID length
If NOT Len(sProductCode) = 38 Then Exit Function
' only care if it's in the expected ProductCode pattern
If NOT InScope(sProductCode) Then Exit Function
' check if it's a known product that should be kept
If dictionaryKeepSku.Exists(UCase(sProductCode)) Then Exit Function
CheckDelete = True
End Function 'CheckDelete
'-------------------------------------------------------------------------------
' DeleteService
'
' Delete a service
'-------------------------------------------------------------------------------
'Delete a service
Sub DeleteService(sName)
Dim Services, srvc, Processes, process
Dim sQuery, sStates, sProcessName, sCmd
Dim iRet
On Error Resume Next
sStates = "STARTED;RUNNING"
sQuery = "Select * From Win32_Service Where Name='" & sName & "'"
Set Services = oWmiLocal.Execquery(sQuery)
' stop and delete the service
For Each srvc in Services
Log " Found service " & sName & " (" & srvc.DisplayName & ") in state " & srvc.State
' get the process name
sProcessName = Trim(Replace(Mid(srvc.PathName, InStrRev(srvc.PathName,"\") + 1), chr(34), ""))
' stop the service
If InStr(sStates, UCase(srvc.State)) > 0 Then
iRet = srvc.StopService()
LogOnly " attempt to stop service " & sName & " returned: " & iRet
End If
' ensure no more instances of the service are running
Set Processes = oWmiLocal.ExecQuery("Select * From Win32_Process Where Name='" & sProcessName & "'")
For Each process in Processes
iRet = process.Terminate()
Next 'Process
If fDetectOnly Then
Log " Not deleting service " & sName & " in preview mode"
Exit Sub
End If
iRet = srvc.Delete()
Log " Delete service " & sName & " returned: " & iRet
Next 'srvc
' check if service got deleted
Set Services = oWmiLocal.Execquery(sQuery)
For Each srvc in Services
' failed to delete service. retry with 'sc' command
sLog " Deleting service " & sName & " failed. Retry delete using 'SC' command"
sCmd = "sc delete " & sName
iRet = oWShell.Run(sCmd, 0, True)
Next 'srvc
Set Services = Nothing
Err.Clear
On Error Goto 0
End Sub 'DeleteService
'-------------------------------------------------------------------------------
' SetupRetVal
'
' Translation for known uninstall return values
'-------------------------------------------------------------------------------
Function SetupRetVal(RetVal)
Select Case RetVal
Case 0 : SetupRetVal = "Success"
'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
'-------------------------------------------------------------------------------
' DeleteFile
'
' Wrapper to delete a file
'-------------------------------------------------------------------------------
Sub DeleteFile(sFile)
Dim File, attr
Dim sDelFile, sFileName, sNewPath
Dim fKeep
On Error Resume Next
fKeep = dictionaryKeepFolder.Exists(LCase(sFile))
If (NOT fKeep AND f64) Then fKeep = dictionaryKeepFolder.Exists(LCase(Wow64Folder(sFile)))
If fKeep Then
LogOnly "Disallowing the delete of still required keypath element: " & sFile
If NOT fForce Then Exit Sub
End If
' check on forced delete
If fKeep Then
LogOnly "Enforced delete of still required keypath element: " & sFile
LogOnly " Remaining applications will need a repair!"
End If
If oFso.FileExists(sFile) Then
sDelFile = sFile
ElseIf f64 AND oFso.FileExists(Wow64Folder(sFile)) Then
sDelFile = Wow64Folder(sFile)
Else
LogOnly "Path not found. Cannot not delete folder: " & sFile
Exit Sub
End If
If Not fDetectOnly Then
LogOnly "Delete file: " & sDelFile
Set File = oFso.GetFile(sDelFile)
' ensure read-only flag is not set
attr = File.Attributes
If CBool(attr AND 1) Then File.Attributes = attr AND (attr - 1)
' add folder to empty folder cleanup list
If NOT dicDelFolder.Exists(File.ParentFolder.Path) Then dicDelFolder.Add File.ParentFolder.Path, File.ParentFolder.Path
' delete the file
sFile = File.Path
File.Delete True
Set File = Nothing
If Err <> 0 Then
CheckError "DeleteFile"
' schedule file for delete on next reboot
ScheduleDeleteFile sFile
End If 'Err <> 0
Else
LogOnly "Preview mode. Disallowing delete for folder: " & sDelFile
End If
On Error Goto 0
End Sub 'DeleteFile
'-------------------------------------------------------------------------------
' DeleteFolder
'
' Wrapper to delete a folder
'-------------------------------------------------------------------------------
Sub DeleteFolder(sFolder)
Dim Folder, fld, attr
Dim sDelFolder, sFolderName, sNewPath, sCmd
Dim fKeep
' ensure trailing "\"
' trailing \ is required for dictionaryKeepFolder comparisons
sFolder = sFolder & "\"
While InStr(sFolder,"\\")>0
sFolder = Replace(sFolder,"\\","\")
Wend
' prevent delete of folders that are known to be still required
fKeep = dictionaryKeepFolder.Exists(LCase(sFolder))
If (NOT fKeep AND f64) Then fKeep = dictionaryKeepFolder.Exists(LCase(Wow64Folder(sFolder)))
If fKeep Then
LogOnly "Disallowing the delete of still required keypath element: " & sFolder
If NOT fForce Then Exit Sub
End If
' check on forced delete
If fKeep Then
LogOnly "Enforced delete of still required keypath element: " & sFolder
LogOnly " Remaining applications will need a repair!"
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
LogOnly "Path not found. Cannot not delete folder: " & sFolder
Exit Sub
End If
If Not fDetectOnly Then
LogOnly "Delete folder: " & sDelFolder
Set Folder = oFso.GetFolder(sDelFolder)
' ensure to remove read only flag
attr = Folder.Attributes
If CBool(attr AND 1) Then Folder.Attributes = attr AND (attr - 1)
' add to empty folder cleanup list
If NOT dicDelFolder.Exists(Folder.Path) Then dicDelFolder.Add Folder.Path, Folder.Path
' delete the folder
' for performance reasons try 'rd' first
Set Folder = Nothing
sCmd = "cmd.exe /c rd /s " & chr(34) & sDelFolder & chr(34) & " /q"
oWShell.Run sCmd, 0, True
If NOT oFso.FolderExists(sDelFolder) Then Exit Sub
' rd didn't work check with FileSystemObject
Set Folder = oFso.GetFolder(sDelFolder)
Folder.Delete True
Set Folder = Nothing
' error handling
If Err <> 0 Then
Select Case Err
Case 70
' Access Denied
' Retry after closing running processes
CheckError "DeleteFolder"
If NOT fRerun Then
CloseOfficeApps
' attempt 'rd' command
LogOnly " Attempt to remove with 'rd' command"
sCmd = "cmd.exe /c rd /s " & chr(34) & sDelFolder & chr(34) & " /q"
oWShell.Run sCmd, 0, True
If NOT oFso.FolderExists(sDelFolder) Then Exit Sub
End If
Case 76
' check on invalid path lengt issues Err 76 (0x4C) "Path not found"
' attempt 'rd' command
CheckError "DeleteFolder"
LogOnly " Attempt to remove with 'rd' command"
sCmd = "cmd.exe /c rd /s " & chr(34) & sDelFolder & chr(34) & " /q"
oWShell.Run sCmd, 0, True
If NOT oFso.FolderExists(sDelFolder) Then Exit Sub
End Select
' stil failed!
Log " Failed to delete folder: " & sDelFolder
CheckError "DeleteFolder"
' try to delete as many folder contents as possible
' before the recursive error handling is called
Set Folder = oFso.GetFolder(sDelFolder)
For Each fld in Folder.Subfolders
sCmd = "cmd.exe /c rd /s " & chr(34) & fld.Path & chr(34) & " /q"
oWShell.Run sCmd, 0, True
Next 'fld
sCmd = "cmd.exe /c del " & chr(34) & fld.Path & "\*.*" & chr(34)
oWShell.Run sCmd, 0, True
Set Folder = Nothing
' schedule an additional run of the tool after reboot
If NOT fRerun Then Rerun
' schedule folder for delete on next reboot
ScheduleDeleteFolder sDelFolder
End If 'Err <> 0
Else
LogOnly "Preview mode. Disallowing delete of folder: " & sDelFolder
End If
On Error Goto 0
End Sub 'DeleteFolder
Sub DeleteFolder_WMI (sFolder)
Dim Folder, Folders
Dim sWqlFolder
Dim iRet
sWqlFolder = Replace(sFolder, "\", "\\")
Set Folders = oWmiLocal.ExecQuery ("Select * from Win32_Directory where name = '" & sWqlFolder & "'")
For Each Folder in Folders
iRet = Folder.Delete
Next 'Folder
LogOnly " Delete (wmi) for folder " & sFolder & " returned: " & iRet
End Sub
'-------------------------------------------------------------------------------
' Wow64Folder
'
' Returns the WOW folder structure to handle 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(sWinDir & "\System32"))
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
'-------------------------------------------------------------------------------
' ScheduleDeleteFile
'
' Adds a file to the list of items to delete on reboot
'-------------------------------------------------------------------------------
Sub ScheduleDeleteFile (sFile)
If NOT dicDelInUse.Exists(sFile) Then dicDelInUse.Add sFile, sFile Else Exit Sub
LogOnly "Adding file in use for delete on reboot: " & sFile
fRebootRequired = True
SetError ERROR_REBOOT_REQUIRED
End Sub 'ScheduleDeleteFile
'-------------------------------------------------------------------------------
' ScheduleDeleteFolder
'
' Recursively adds a folder and its contents to the list of
' items to delete on reboot
'-------------------------------------------------------------------------------
Sub ScheduleDeleteFolder (sFolder)
Dim oFolder, fld, file, attr
Set oFolder = oFso.GetFolder(sFolder)
' exclude hidden system folders
attr = oFolder.Attributes
If CBool(attr AND 6) Then Exit Sub
For Each fld In oFolder.SubFolders
DeleteFolder fld.Path
Next
For Each file In oFolder.Files
DeleteFile file.Path
Next
If NOT dicDelInUse.Exists(oFolder.Path) Then dicDelInUse.Add oFolder.Path, "" Else Exit Sub
LogOnly "Adding folder for delete on reboot: " & oFolder.Path
fRebootRequired = True
SetError ERROR_REBOOT_REQUIRED
End Sub 'ScheduleDeleteFile
'-------------------------------------------------------------------------------
' ScheduleDeleteEx
'
' Schedules the delete of files/folders in use on next reboot by adding
' affected files/folders to the PendingFileRenameOperations registry entry
'-------------------------------------------------------------------------------
Sub ScheduleDeleteEx ()
Dim key, hDefKey, sKeyName, sValueName
Dim i
Dim arrData
hDefKey = HKLM
sKeyName = "SYSTEM\CurrentControlSet\Control\Session Manager"
sValueName = "PendingFileRenameOperations"
LogH2 "Adding " & dicDelInUse.Count & " PendingFileRenameOperations"
If NOT RegValExists(hDefKey, sKeyName, sValueName) Then
ReDim arrData(-1)
Else
oReg.GetMultiStringValue hDefKey, sKeyName, sValueName, arrData
End If
i = UBound(arrData) + 1
ReDim Preserve arrData(UBound(arrData) + (dicDelInUse.Count * 2))
For Each key in dicDelInUse.Keys
LogOnly " " & key
arrData(i) = "\??\" & key
arrData(i + 1) = ""
i = i + 2
Next 'key
oReg.SetMultiStringValue hDefKey, sKeyName, sValueName, arrData
End Sub 'ScheduleDeleteEx
'-------------------------------------------------------------------------------
' DeleteEmptyFolders
'
' Deletes an individual folder structure if empty
'-------------------------------------------------------------------------------
Sub DeleteEmptyFolder (sFolder)
Dim Folder
' cosmetic' task don't fail on error
On Error Resume Next
If oFso.FolderExists(sFolder) Then
Set Folder = oFso.GetFolder(sFolder)
If (Folder.Subfolders.Count = 0) AND (Folder.Files.Count = 0) Then
Set Folder = Nothing
SmartDeleteFolder sFolder
End If
End If
CheckError "DeleteEmptyFolder"
On Error Goto 0
End Sub 'DeleteEmptyFolders
'-------------------------------------------------------------------------------
' DeleteEmptyFolders
'
' Delete an empty folder structure
'-------------------------------------------------------------------------------
Sub DeleteEmptyFolders
Dim Folder
Dim sFolder
' cosmetic' task don't fail on error
On Error Resume Next
DeleteEmptyFolder sCommonProgramFiles & "\Microsoft Shared\Office15"
DeleteEmptyFolder sCommonProgramFiles & "\Microsoft Shared\Office16"
DeleteEmptyFolder sCommonProgramFiles & "\Microsoft Shared\"
DeleteEmptyFolder sProgramFiles & "\Microsoft Office\Office15"
DeleteEmptyFolder sProgramFiles & "\Microsoft Office\Office16"
For Each sFolder in dicDelFolder.Keys
If oFso.FolderExists(sFolder) Then
Set Folder = oFso.GetFolder(sFolder)
If (Folder.Subfolders.Count = 0) AND (Folder.Files.Count = 0) Then
Set Folder = Nothing
SmartDeleteFolder sFolder
End If
End If
Next 'sFolder
CheckError "DeleteEmptyFolders"
On Error Goto 0
End Sub 'DeleteEmptyFolders
'-------------------------------------------------------------------------------
' SmartDeleteFolder
'
' Wrapper to delete a folder and the empty parent folder structure
'-------------------------------------------------------------------------------
Sub SmartDeleteFolder(sFolder)
Dim sDelFolder
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 "Request SmartDelete for folder: " & sDelFolder
SmartDeleteFolderEx sDelFolder
Else
LogOnly "Preview mode. Disallowing SmartDelete request for folder: " & sDelFolder
End If
End Sub 'SmartDeleteFolder
'-------------------------------------------------------------------------------
' SmartDeleteFolderEx
'
' Executes the folder delete operation(s)
'-------------------------------------------------------------------------------
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
'-------------------------------------------------------------------------------
' RestoreExplorer
'
' 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
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
End If
On Error Goto 0
End Sub 'RestoreExploer
'-------------------------------------------------------------------------------
' MyJoin
'
' Replacement function to the internal Join function to prevent failures
' that were seen in some instances
'-------------------------------------------------------------------------------
Function MyJoin(arrToJoin, sSeparator)
Dim sJoined
Dim i
sJoined = ""
If IsArray(arrToJoin) Then
For i = 0 To UBound(arrToJoin)
sJoined = sJoined & arrToJoin(i) & sSeparator
Next 'i
End If
If Len(sJoined) > 1 Then sJoined = Left(sJoined, Len(sJoined) - 1)
MyJoin = sJoined
End Function
'-------------------------------------------------------------------------------
' Rerun
'
' Flag need for reboot and schedule autorun to run the tool again on reboot.
'-------------------------------------------------------------------------------
Sub Rerun ()
Dim sValue
' check if Rerun has already been called
If fRerun Then Exit Sub
' set Rerun flag
fRerun = True
' check if the previous run already initiated the Rerun
If RegReadValue(HKCU, "SOFTWARE\Microsoft\Office\15.0\CleanC2R", "Rerun", sValue, "REG_DWORD") Then
' Rerun has already been tried
LogH2 "Error: Removal failed"
SetError ERROR_DCAF_FAILURE
Exit Sub
End If
fRebootRequired = True
SetError ERROR_REBOOT_REQUIRED
SetError ERROR_INCOMPLETE
' cache the script to the local scrub folder
oFso.CopyFile WScript.scriptFullName, sScrubDir & "\" & SCRIPTFILE
oReg.CreateKey HKLM, "SOFTWARE"
oReg.CreateKey HKLM, "SOFTWARE\Microsoft"
oReg.CreateKey HKLM, "SOFTWARE\Microsoft\Office"
oReg.CreateKey HKLM, "SOFTWARE\Microsoft\Office\15.0"
oReg.CreateKey HKLM, "SOFTWARE\Microsoft\Office\15.0\CleanC2R"
oReg.SetDWordValue HKLM, "SOFTWARE\Microsoft\Office\15.0\CleanC2R", "Rerun", 1
fSetRunOnce = True
' oReg.CreateKey HKCU, "SOFTWARE\Microsoft\Windows\CurrentVersion\RunOnce"
' oReg.SetStringValue HKCU, "SOFTWARE\Microsoft\Windows\CurrentVersion\RunOnce", "CleanC2R", "cscript.exe " & chr(34) & sScrubDir & "\" & SCRIPTFILE & chr(34)
End Sub
'-------------------------------------------------------------------------------
' SetRunOnce
'
' Create a RunOnce entry to resume setup after a reboot
'-------------------------------------------------------------------------------
Sub SetRunOnce
Dim sValue
oReg.CreateKey HKLM, "SOFTWARE\Microsoft\Windows\CurrentVersion"
oReg.CreateKey HKLM, "SOFTWARE\Microsoft\Windows\CurrentVersion\RunOnce"
sValue = "cscript.exe " & chr(34) & sScrubDir & "\" & SCRIPTFILE & chr(34) & " /NoElevate /Relaunched"
oReg.SetStringValue HKLM, "SOFTWARE\Microsoft\Windows\CurrentVersion\RunOnce", "O15CleanUp", sValue
End Sub 'SetRunOnce
@KenInTexas
Copy link

Hello. A while back I was working with an MS support technician who stated that you could edit this code and make it run without a restart requirement. I was in the process of trying to use it to deploy Office 2016 to replace 2013. Before I reopen a ticket I was hoping someone might know how to edit the script to ensure it runs silently and does not require a reboot. Any assistance would be appreciated.

@gioxx
Copy link
Author

gioxx commented Jan 31, 2020

Hello. A while back I was working with an MS support technician who stated that you could edit this code and make it run without a restart requirement. I was in the process of trying to use it to deploy Office 2016 to replace 2013. Before I reopen a ticket I was hoping someone might know how to edit the script to ensure it runs silently and does not require a reboot. Any assistance would be appreciated.

Ciao Ken, this script doesn't need to restart your PC but - if necessary - can restart your Explorer.exe process. My advice is anyway to make a restart of the machine after you have upgraded to Office 2016 from Office 2013 to ensure all libraries and executables from this software starts correctly.

Remember: after you uninstall Microsoft Office 2013/16/19 from your PC it's possible not all files can be removed without a PC restart. Please do some tests in a laboratory environment before use this script in production.

Have a nice day :-)

@KenInTexas
Copy link

KenInTexas commented Jan 31, 2020 via email

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment