'

'
'
'
'
'

Name: Robust Office Inventory Scan - Version 1.6.3

Author: Microsoft Customer Support Services
Copyright (c) Microsoft Corporation. All rights reserved.
Script to create an inventory scan of installed Office applications
Supported Office Families: 2000, 2002, 2003, 2007
2010, 2013, 365

Option Explicit
On Error Resume Next
Const SCRIPTBUILD = "1.6.3"
Dim sPathOutputFolder : sPathOutputFolder = ""
Dim fQuiet : fQuiet = False
Dim fLogFeatures : fLogFeatures = False
Dim fLogFull : fLogFull = False
dim fBasicMode : fBasicMode = False
Dim fLogChainedDetails : fLogChainedDetails = False
Dim fLogVerbose : fLogVerbose = False
Dim fListNonOfficeProducts : fListNonOfficeProducts = False
Dim fFileInventory : fFileInventory = False
Dim fFeatureTree : fFeatureTree = False
Dim fDisallowCScript : fDisallowCScript = False
'===============================================================================
========================
'[INI] Section for script behavior customizations
'Directory for Log output.
'Example: "\\<server>\<share>\"
'Default: sPathOutputFolder = vbNullString -> %temp% directory is used
sPathOutputFolder = ""
'Quiet switch.
'Default: False -> Open inventory log when done
fQuiet = False
'Basic Mode
'Generates a basic list of installed Office products with licensing information
only
'Disables all other extended analysis options
'Default: False -> Allow extended analysis options
fBasicMode = False
'Log full (verbose) details. This enables all possible scans for Office products
.
'Default: False -> Only list standard details
fLogFull = False
'Enables additional logging details
'like the "FeatureTree" display and
'the additional individual listing of the chained Office SKU's
'Default: False -> Do not log additional details
fLogVerbose = False
'Starting with Office 2007 a SKU can contain several .msi packages
'The default does not list the details for each chained package
'This option allows to show the full details for each chained package
'Default: Comprehensive view - do not show details for chained packages
fLogChainedDetails = False

'The script filters for products of the Microsoft Office family.

'Set this option to 'True' to get a list of all Windows Installer products in th
e inventory log
'Default: False -> Don't list other products in the log
fListNonOfficeProducts = False
'File level inventory of installed Office products
'Depending on the number of installed products this can be an extremely time con
suming task!
'Default: False -> Don't create a file level inventory
fFileInventory = False
'Detect all features of a product and include a feature tree in the log
'Default: False -> Don't include the feature detection
fFeatureTree = False
'DO NOT CUSTOMIZE BELOW THIS LINE!
'===============================================================================
========================
'Measure total scan runtime
Dim tStart,tEnd
tStart = Time()
'Call the command line parser
ParseCmdLine
'Definition of non customizable settings
'Strings
Dim sComputerName, sTemp, sCurUserSid, sDebugErr, sError, sErrBpa
Dim sStack, sCacheLog, sLogFile, sInstalledProducts, sSystemType, sLogFormat
'Arrays
Dim arrAllProducts(), arrMProducts(), arrUUProducts(), arrUMProducts(), arrMaste
r(), arrArpProducts()
Dim arrVirtProducts(), arrVirt2Products(), arrPatch(), arrAipPatch, arrMspFiles,
arrIS(), arrFeature()
Dim arrLog(4), arrLogFormat(), arrUUSids(), arrUMSids(), arrMVProducts()
Dim arrProdVer09(), arrProdVer10(), arrProdVer11(), arrProdVer12(), arrProdVer14
(), arrProdVer15()
Dim arrFiles()
'Booleans
Dim fIsAdmin, fIsElevated, fIsCriticalError, fGuidCaseWarningOnly, f64, fPatches
Ok, fPatchesExOk
Dim fCScript, bOsppInit, fZipError, fInitArrProdVer
'Integers
Dim iWiVersionMajor,iVersionNt,iPCount,iPatchesExError
'Dictionaries
Dim dicFolders, dicAssembly, dicMspIndex, dicProducts, dicMissingChild
Dim dicPatchLevel, dicScenario
'Other
Dim oMsi, oShell, oFso, oReg, oWsh
Dim TextStream, ShellApp, AppFolder, Ospp, Spp
'Identifier for product family
Const OFFICE_ALL
= "78E1-11D2-B60F-006097C998E7}.0001-11D292F2-00104BC947F0}.6000-11D3-8CFE-0050048383C9}.6000-11D3-8CFE-0150048383C9}.700
0-11D3-8CFE-0150048383C9}.BE5F-4ED1-A0F7-759D40C7622E}.BDCA-11D1-B7AE-00C04FB92F
3D}.6D54-11D4-BEE3-00C04F990354}.CFDA-404E-8992-6AF153ED1719}."
'Office 2000 -> KB230848; Office XP -> KB302663; Office 2003 -> KB832672
Const OFFICE_2000
= "78E1-11D2-B60F-006097C998E7}"
Const ORK_2000
= "0001-11D2-92F2-00104BC947F0}"
Const PRJ_2000
= "BDCA-11D1-B7AE-00C04FB92F3D}"

Const VIS_2002
= "6D54-11D4-BEE3-00C04F990354}"
Const OFFICE_2002
= "6000-11D3-8CFE-0050048383C9}"
Const OFFICE_2003
= "6000-11D3-8CFE-0150048383C9}"
Const WSS2
= "7000-11D3-8CFE-0150048383C9}"
Const SPS_2003
= "BE5F-4ED1-A0F7-759D40C7622E}"
Const PPS_2007
= "CFDA-404E-8992-6AF153ED1719}" 'Project
Portfolio Server 2007
Const POWERPIVOT_2010
= "{72F8ECCE-DAB0-4C23-A471-625FEDABE323},
{A37E1318-29CA-4A9F-9CCA-D9BFDD61D17B}" 'UpgradeCode!
Const OFFICEID
= "000-0000000FF1CE}" 'cover O12, O14 with
32 & 64 bit
Const OREGREFC2R15
= "Microsoft Office 15"
Const PRODLEN
= 13
Const FOR_READING
= 1
Const FOR_WRITING
= 2
Const FOR_APPENDING
= 8
Const TRISTATE_USEDEFAULT
= -2 'Opens the file using the system defa
ult.
Const TRISTATE_TRUE
= -1 'Opens the file as Unicode.
Const TRISTATE_FALSE
= 0 'Opens the file as ASCII.
Const USERSID_EVERYONE
= "s-1-1-0"
Const MACHINESID
= ""
Const PRODUCTCODE_EMPTY
= ""
Const MSIOPENDATABASEMODE_READONLY
= 0
Const MSIOPENDATABASEMODE_PATCHFILE = 32
Const MSICOLUMNINFONAMES
= 0
Const MSICOLUMNINFOTYPES
= 1
'Summary Information fields
Const PID_TITLE
= 2 'Type of installer package. E.g. "Inst
allation Database" or "Transform" or "Patch"
Const PID_SUBJECT
= 3 'Displayname
Const PID_TEMPLATE
= 7 'compatible platform and language vers
ions for .msi / PatchTargets for .msp
Const PID_REVNUMBER
= 9 'PackageCode
Const PID_WORDCOUNT
= 15'InstallSource type
Const MSIPATCHSTATE_UNKNOWN
= -1 'Patch is in an unknown state to this
product instance.
Const MSIPATCHSTATE_APPLIED
= 1 'Patch is applied to this product inst
ance.
Const MSIPATCHSTATE_SUPERSEDED
= 2 'Patch is applied to this product inst
ance but is superseded.
Const MSIPATCHSTATE_OBSOLETED
= 4 'Patch is applied in this product inst
ance but obsolete.
Const MSIPATCHSTATE_REGISTERED
= 8 'The enumeration includes patches that
are registered but not yet applied.
Const MSIPATCHSTATE_ALL
= 15
Const MSIINSTALLCONTEXT_USERMANAGED = 1
Const MSIINSTALLCONTEXT_USERUNMANAGED = 2
Const MSIINSTALLCONTEXT_MACHINE
= 4
Const MSIINSTALLCONTEXT_ALL
= 7
Const MSIINSTALLCONTEXT_C2RV2
= 8 'C2r V2 virtualized context
Const MSIINSTALLMODE_DEFAULT
= 0
'Provide the component and perform
any installation necessary to provide the component.
Const MSIINSTALLMODE_EXISTING
= -1 'Provide the component only if the
feature exists. This option will verify that the assembly exists.
Const MSIINSTALLMODE_NODETECTION
= -2 'Provide the component only if the
feature exists. This option does not verify that the assembly exists.
Const MSIINSTALLMODE_NOSOURCERESOLUTION = -3 'Provides the assembly only if the
assembly is installed local.
Const MSIPROVIDEASSEMBLY_NET
= 0
'A .NET assembly.

Const MSIPROVIDEASSMBLY_WIN32
= 1
'A Win32 side-by-side assembly.
Const MSITRANSFORMERROR_ALL
= 319
'Installstates for products, features, components
Const INSTALLSTATE_NOTUSED
= -7 ' component disabled
Const INSTALLSTATE_BADCONFIG
= -6 ' configuration data corrupt
Const INSTALLSTATE_INCOMPLETE
= -5 ' installation suspended or in progr
ess
Const INSTALLSTATE_SOURCEABSENT
= -4 ' run from source, source is unavail
able
Const INSTALLSTATE_MOREDATA
= -3 ' return buffer overflow
Const INSTALLSTATE_INVALIDARG
= -2 ' invalid function argument. The pro
duct/feature is neither advertised or installed.
Const INSTALLSTATE_UNKNOWN
= -1 ' unrecognized product or feature
Const INSTALLSTATE_BROKEN
= 0 ' broken
Const INSTALLSTATE_ADVERTISED
= 1 'The product/feature is advertised but
not installed.
Const INSTALLSTATE_REMOVED
= 1 'The component is being removed (acti
on state, not settable)
Const INSTALLSTATE_ABSENT
= 2 'The product/feature is not installed.
Const INSTALLSTATE_LOCAL
= 3 'The product/feature/component is inst
alled.
Const INSTALLSTATE_SOURCE
= 4 'The product or feature is installed t
o run from source, CD, or network.
Const INSTALLSTATE_DEFAULT
= 5 'The product or feature will be instal
led to use the default location: local or source.
Const INSTALLSTATE_VIRTUALIZED
= 8 'The product is virtualized (C2R).
Const VERSIONCOMPARE_LOWER
= -1 'Left hand file version is lower than
right hand
Const VERSIONCOMPARE_MATCH
= 0 'File versions are identical
Const VERSIONCOMPARE_HIGHER
= 1 'Left hand file versin is higher than
right hand
Const VERSIONCOMPARE_INVALID
= 2 'Cannot compare. Invalid compare atte
mpt.
Const COPY_OVERWRITE
= &H10&
Const COPY_SUPPRESSERROR
= &H400&
Const HKEY_CLASSES_ROOT
= &H80000000
Const HKEY_CURRENT_USER
= &H80000001
Const HKEY_LOCAL_MACHINE
= &H80000002
Const HKEY_USERS
= &H80000003
Const HKCR
= &H80000000
Const HKCU
= &H80000001
Const HKLM
= &H80000002
Const HKU
= &H80000003
Const KEY_QUERY_VALUE
= &H0001
Const KEY_SET_VALUE
= &H0002
Const KEY_CREATE_SUB_KEY
= &H0004
Const DELETE
= &H00010000
Const REG_SZ
= 1
Const REG_EXPAND_SZ
= 2
Const REG_BINARY
= 3
Const REG_DWORD
= 4
Const REG_MULTI_SZ
= 7
Const REG_QWORD
= 11
Const REG_GLOBALCONFIG
= "SOFTWARE\Microsoft\Windows\CurrentVersi
on\Installer\UserData\"
Const REG_CONTEXTMACHINE
= "Installer\"
Const REG_CONTEXTUSER
= "Software\Microsoft\Installer\"
Const REG_CONTEXTUSERMANAGED
= "Software\Microsoft\Windows\CurrentVersi
on\Installer\Managed\"

Const REG_ARP
= "SOFTWARE\Microsoft\Windows\CurrentVersi
on\Uninstall\"
Const REG_C2RVIRT_HKLM
= "SOFTWARE\Microsoft\Office\15.0\ClickToR
un\REGISTRY\MACHINE\"
Const REG_C2RACTIVEPRODS
= "SOFTWARE\Microsoft\Office\15.0\ClickToR
un\ProductReleaseIDs\Active"
Const REG_C2RPROPERTYBAG
= "SOFTWARE\Microsoft\Office\15.0\ClickToR
un\propertyBag"
Const REG_C2RSCENARIO
= "SOFTWARE\Microsoft\Office\15.0\ClickToR
un\scenario"
Const GUID_UNCOMPRESSED
= 0
Const GUID_COMPRESSED
= 1
Const GUID_SQUISHED
= 2
Const LOGPOS_COMPUTER
= 0 '
ArrLogPosition 0: "Computer"
Const LOGPOS_REVITEM
= 1 '
ArrLogPosition 1: "Review Items"
Const LOGPOS_PRODUCT
= 2 '
ArrLogPosition 2: "Products Inven
tory"
Const LOGPOS_RAW
= 3 '
ArrLogPosition 3: "Raw Data"
Const LOGHEADING_NONE
= 0 '
Not a heading
Const LOGHEADING_H1
= 1 '
Heading 1 '='
Const LOGHEADING_H2
= 2 '
Heading 2 '-'
Const LOGHEADING_H3
= 3 '
Heading 3 ' '
Const TEXTINDENT
= "
"
Const CATEGORY
= 1
Const TAG
= 2
Const OSPP_ID = 0
Const OSPP_APPLICATIONID = 1
Const OSPP_PARTIALPRODUCTKEY = 2
Const OSPP_DESCRIPTION = 3
Const OSPP_NAME = 4
Const OSPP_LICENSESTATUS = 5
Const OSPP_LICENSESTATUSREASON = 6
Const OSPP_PRODUCTKEYID = 7
Const OSPP_GRACEPERIODREMAINING = 8
Const OSPP_LICENSEFAMILY = 9
Const OSPP_DISCOVEREDKEYMANAGEMENTSERVICEMACHINENAME = 10
Const OSPP_KEYMANAGEMENTSERVICEPORT = 11
Const OSPP_VLACTIVATIONINTERVAL = 12
Const OSPP_VLRENEWALINTERVAL = 13
'Arrays
Const UBOUND_LOGARRAYS
= 12
Const UBOUND_LOGCOLUMNS
= 30 ' Controlled by array with the most c
olumns
Redim arrLogFormat(UBOUND_LOGARRAYS,UBOUND_LOGCOLUMNS)
Const ARRAY_MASTER
= 0 'Master
Const UBOUND_MASTER
= 30
' ProductCode
Const COL_PRODUCTCODE
= 0
arrLogFormat(ARRAY_MASTER,COL_PRODUCTCODE)
' Msi ProductName
Const COL_PRODUCTNAME
= 1
arrLogFormat(ARRAY_MASTER,COL_PRODUCTNAME)
' UserSid
Const COL_USERSID
= 2
arrLogFormat(ARRAY_MASTER,COL_USERSID)
' ProductContext
Const COL_CONTEXTSTRING
= 3
arrLogFormat(ARRAY_MASTER,COL_CONTEXTSTRING)

data array id

= "ProductCode"
= "Msi ProductName"
= "UserSid"
= "ProductContext"

' ProductState
Const COL_STATESTRING
= 4
arrLogFormat(ARRAY_MASTER,COL_STATESTRING)
' ProductContext
Const COL_CONTEXT
= 5
arrLogFormat(ARRAY_MASTER,COL_CONTEXT)
' ProductState
Const COL_STATE
= 6
arrLogFormat(ARRAY_MASTER,COL_STATE)
' Arp SystemComponent
Const COL_SYSTEMCOMPONENT
= 7
arrLogFormat(ARRAY_MASTER,COL_SYSTEMCOMPONENT)
' Arp ParentCount
Const COL_ARPPARENTCOUNT
= 8
arrLogFormat(ARRAY_MASTER,COL_ARPPARENTCOUNT)
' Arp Parents
Const COL_ARPPARENTS
= 9
arrLogFormat(ARRAY_MASTER,COL_ARPPARENTS)
' Arp Productname
Const COL_ARPPRODUCTNAME
= 10
arrLogFormat(ARRAY_MASTER,COL_ARPPRODUCTNAME)
' ProductVersion
Const COL_PRODUCTVERSION
= 11
arrLogFormat(ARRAY_MASTER,COL_PRODUCTVERSION)
' ServicePack Level
Const COL_SPLEVEL
= 12
arrLogFormat(ARRAY_MASTER,COL_SPLEVEL)
' InstallDate
Const COL_INSTALLDATE
= 13
arrLogFormat(ARRAY_MASTER,COL_INSTALLDATE)
' Cached .msi
Const COL_CACHEDMSI
= 14
arrLogFormat(ARRAY_MASTER,COL_CACHEDMSI)
' Original .msi name
Const COL_ORIGINALMSI
= 15
arrLogFormat(ARRAY_MASTER,COL_ORIGINALMSI)
' Build/Origin Property
Const COL_ORIGIN
= 16
arrLogFormat(ARRAY_MASTER,COL_ORIGIN)
' ProductID Property
Const COL_PRODUCTID
= 17
arrLogFormat(ARRAY_MASTER,COL_PRODUCTID)
' Package Code
Const COL_PACKAGECODE
= 18
arrLogFormat(ARRAY_MASTER,COL_PACKAGECODE)
' Transform
Const COL_TRANSFORMS
= 19
arrLogFormat(ARRAY_MASTER,COL_TRANSFORMS)
' Architecture
Const COL_ARCHITECTURE
= 20
arrLogFormat(ARRAY_MASTER,COL_ARCHITECTURE)
' Error
Const COL_ERROR
= 21
arrLogFormat(ARRAY_MASTER,COL_ERROR)
' Notes
Const COL_NOTES
= 22
arrLogFormat(ARRAY_MASTER,COL_NOTES)
' MetadataState
Const COL_METADATASTATE
= 23
arrLogFormat(ARRAY_MASTER,COL_METADATASTATE)

= "ProductState"
= "ProductContext"
= "ProductState"
= "Arp SystemComponent"
= "Arp ParentCount"
= "Configuration SKU"
= "ARP ProductName"
= "ProductVersion"
= "ServicePack Level"
= "InstallDate"
= "Cached .msi Package"
= "Original .msi Name"
= "Build/Origin"
= "ProductID (MSI)"
= "Package Code"
= "Transforms"
= "Architecture"
= "Errors"
= "Notes"
= "MetadataState"

' IsOfficeProduct
Const COL_ISOFFICEPRODUCT
= 24
arrLogFormat(ARRAY_MASTER,COL_ISOFFICEPRODUCT)
' PatchFamily
Const COL_PATCHFAMILY
= 25
arrLogFormat(ARRAY_MASTER,COL_PATCHFAMILY)
' OSPP License
Const COL_OSPPLICENSE
= 26
arrLogFormat(ARRAY_MASTER,COL_OSPPLICENSE)
Const COL_OSPPLICENSEXML
= 27
arrLogFormat(ARRAY_MASTER, COL_OSPPLICENSEXML)
' UpgradeCode
Const COL_UPGRADECODE
= 28
arrLogFormat(ARRAY_MASTER,COL_UPGRADECODE)
' Virtualized
Const COL_VIRTUALIZED
= 29
arrLogFormat(ARRAY_MASTER,COL_VIRTUALIZED)
' InstallType
Const COL_INSTALLTYPE
= 30
arrLogFormat(ARRAY_MASTER,COL_INSTALLTYPE)

= "IsOfficeProduct"
= "PatchFamily"
= "OSPP License"
= "OSPP License XML"
= "UpgradeCode"
= "Virtualized"
= "InstallType"

Const ARRAY_PATCH
= 1 'Patch data array id
Const PATCH_COLUMNCOUNT
= 14
Const PATCH_LOGSTART
= 1
Const PATCH_LOGCHAINEDMAX
= 8
Const PATCH_LOGMAX
= 11
' Product
Const PATCH_PRODUCT
= 0
arrLogFormat(ARRAY_PATCH,PATCH_PRODUCT)
= "Patched Product: "
' KB
Const PATCH_KB
= 1
arrLogFormat(ARRAY_PATCH,PATCH_KB)
= "KB: "
' PackageName
Const PATCH_PACKAGE
= 3
arrLogFormat(ARRAY_PATCH,PATCH_PACKAGE)
= "Package: "
' PatchState
Const PATCH_PATCHSTATE
= 2
arrLogFormat(ARRAY_PATCH,PATCH_PATCHSTATE)
= "State: "
' Sequence
Const PATCH_SEQUENCE
= 4
arrLogFormat(ARRAY_PATCH,PATCH_SEQUENCE)
= "Sequence: "
' Uninstallable
Const PATCH_UNINSTALLABLE
= 5
arrLogFormat(ARRAY_PATCH,PATCH_UNINSTALLABLE) = "Uninstallable: "
' InstallDate
Const PATCH_INSTALLDATE
= 6
arrLogFormat(ARRAY_PATCH,PATCH_INSTALLDATE)
= "InstallDate: "
' PatchCode
Const PATCH_PATCHCODE
= 7
arrLogFormat(ARRAY_PATCH,PATCH_PATCHCODE)
= "PatchCode: "
' LocalPackage
Const PATCH_LOCALPACKAGE
= 8
arrLogFormat(ARRAY_PATCH,PATCH_LOCALPACKAGE) = "LocalPackage: "
' PatchTransform
Const PATCH_TRANSFORM
= 9
arrLogFormat(ARRAY_PATCH,PATCH_TRANSFORM)
= "PatchTransform: "
' DisplayName
Const PATCH_DISPLAYNAME
= 10
arrLogFormat(ARRAY_PATCH,PATCH_DISPLAYNAME)
= "DisplayName: "
' MoreInfoUrl

Const PATCH_MOREINFOURL
= 11
arrLogFormat(ARRAY_PATCH,PATCH_MOREINFOURL)
' Client side patch or patched AIP
Const PATCH_CSP
= 12
arrLogFormat(ARRAY_PATCH,PATCH_CSP)
' Local .msp package OK/available
Const PATCH_CPOK
= 13
arrLogFormat(ARRAY_PATCH,PATCH_CPOK)

= "MoreInfoUrl: "
= "ClientSidePatch: "
= "CachedMspOK: "

' arrMsp(MSPDEFAULT,MSP_COLUMNCOUNT)
Const ARRAY_MSPFILES
= 10
Const MSPFILES_COLUMNCOUNT
= 18
Const MSPFILES_LOGMAX
= 9
' Product
Const MSPFILES_TARGETS
= 0
arrLogFormat(ARRAY_MSPFILES,MSPFILES_TARGETS)
' KB
Const MSPFILES_KB
= 1
arrLogFormat(ARRAY_MSPFILES,MSPFILES_KB)
' PackageName
Const MSPFILES_PACKAGE
= 2
arrLogFormat(ARRAY_MSPFILES,MSPFILES_PACKAGE)
' Family
Const MSPFILES_FAMILY
= 3
arrLogFormat(ARRAY_MSPFILES,MSPFILES_FAMILY)
' Sequence
Const MSPFILES_SEQUENCE
= 4
arrLogFormat(ARRAY_MSPFILES,MSPFILES_SEQUENCE)
' PatchState
Const MSPFILES_PATCHSTATE
= 5
arrLogFormat(ARRAY_MSPFILES,MSPFILES_PATCHSTATE)
' Uninstallable
Const MSPFILES_UNINSTALLABLE
= 6
arrLogFormat(ARRAY_MSPFILES,MSPFILES_UNINSTALLABLE)
' InstallDate
Const MSPFILES_INSTALLDATE
= 7
arrLogFormat(ARRAY_MSPFILES,MSPFILES_INSTALLDATE)
' DisplayName
Const MSPFILES_DISPLAYNAME
= 8
arrLogFormat(ARRAY_MSPFILES,MSPFILES_DISPLAYNAME)
' MoreInfoUrl
Const MSPFILES_MOREINFOURL
= 9
arrLogFormat(ARRAY_MSPFILES,MSPFILES_MOREINFOURL)
' PatchCode
Const MSPFILES_PATCHCODE
= 10
arrLogFormat(ARRAY_MSPFILES,MSPFILES_PATCHCODE)
' LocalPackage
Const MSPFILES_LOCALPACKAGE
= 11
arrLogFormat(ARRAY_MSPFILES,MSPFILES_LOCALPACKAGE)
' Bucket
Const MSPFILES_BUCKET
= 12
arrLogFormat(ARRAY_MSPFILES,MSPFILES_BUCKET)
' Attribute msidbPatchSequenceSupersedeEarlier
Const MSPFILES_ATTRIBUTE
= 14
arrLogFormat(ARRAY_MSPFILES,MSPFILES_ATTRIBUTE)
persedeEarlier: "
' PatchTransform
Const MSPFILES_TRANSFORM
= 14
arrLogFormat(ARRAY_MSPFILES,MSPFILES_TRANSFORM)
' PatchXml

= "Patch Targets: "

= "KB: "
= "Package: "
= "Family: "
= "Sequence: "
= "PatchState: "
= "Uninstallable: "
= "InstallDate: "
= "DisplayName: "
= "MoreInfoUrl: "
= "PatchCode: "
= "LocalPackage: "
= "Bucket: "
= "msidbPatchSequenceSu

= "PatchTransform: "

Const MSPFILES_XML
= 15
arrLogFormat(ARRAY_MSPFILES,MSPFILES_XML)
' PatchTables
Const MSPFILES_TABLES
= 16
arrLogFormat(ARRAY_MSPFILES,MSPFILES_TABLES)
' Local .msp package OK/available
Const MSPFILES_CPOK
= 17
arrLogFormat(ARRAY_MSPFILES,MSPFILES_CPOK)

= "PatchXml: "
= "PatchTables: "
= "CachedMspOK: "

Const ARRAY_AIPPATCH
= 11
Const AIPPATCH_COLUMNCOUNT
= 3
' Product
Const AIPPATCH_PRODUCT
= 0
arrLogFormat(ARRAY_AIPPATCH,AIPPATCH_PRODUCT) = "Patched Product: "
' PatchCode
Const AIPPATCH_PATCHCODE
= 1
arrLogFormat(ARRAY_AIPPATCH,AIPPATCH_PATCHCODE)= "PatchCode: "
' DisplayName
Const AIPPATCH_DISPLAYNAME
= 3
arrLogFormat(ARRAY_AIPPATCH,AIPPATCH_DISPLAYNAME)= "DisplayName: "
Const ARRAY_FEATURE
Const FEATURE_COLUMNCOUNT
Const FEATURE_PRODUCTCODE
Const FEATURE_TREE

=
=
=
=

2 'Feature data array id

1
0
1

Const ARRAY_ARP
= 4 'Add/remove products data array id
Const ARP_CHILDOFFSET
= 6
' Config Productcode
Const ARP_CONFIGPRODUCTCODE
= 0
arrLogFormat(ARRAY_ARP,ARP_CONFIGPRODUCTCODE) = "Config ProductCode"
' Config Productname
Const COL_CONFIGNAME
= 1
arrLogFormat(ARRAY_ARP,COL_CONFIGNAME)
= "Config ProductName"
' Config ProductVersion
Const ARP_PRODUCTVERSION
= 2
arrLogFormat(ARRAY_ARP,ARP_PRODUCTVERSION)
= "ProductVersion"
' Config InstallType
Const COL_CONFIGINSTALLTYPE
= 3
arrLogFormat(ARRAY_ARP,COL_CONFIGINSTALLTYPE) = "Config InstallType"
' Config PackageID
Const COL_CONFIGPACKAGEID
= 4
arrLogFormat(ARRAY_ARP,COL_CONFIGPACKAGEID)
= "Config PackageID"
Const COL_ARPALLPRODUCTS
= 5
Const COL_LBOUNDCHAINLIST
= 6
Const ARRAY_IS
= 5 ' MSI InstallSource data array id
Const UBOUND_IS
= 6
Const IS_LOG_LBOUND
= 2
Const IS_LOG_UBOUND
= 6
Const IS_PRODUCTCODE
= 0
Const IS_SOURCETYPE
= 1
Const IS_SOURCETYPESTRING
= 2
arrLogFormat(ARRAY_IS,IS_SOURCETYPESTRING)
= "InstallSource Type"
Const IS_ORIGINALSOURCE
= 3
arrLogFormat(ARRAY_IS,IS_ORIGINALSOURCE)
= "Initially Used Source"
Const IS_LASTUSEDSOURCE
= 4
arrLogFormat(ARRAY_IS,IS_LASTUSEDSOURCE)
= "Last Used Source"
Const IS_LISRESILIENCY
= 5
arrLogFormat(ARRAY_IS,IS_LISRESILIENCY)
= "LIS Resiliency Sources"

Const IS_ADDITIONALSOURCES
= 6
arrLogFormat(ARRAY_IS,IS_ADDITIONALSOURCES)

= "Network Sources"

Const ARRAY_VIRTPROD
= 6 ' Non MSI based virtualized products
Const UBOUND_VIRTPROD
= 8
' Productcode
arrLogFormat(ARRAY_VIRTPROD, COL_PRODUCTCODE)
= "ProductCode"
' Productname
arrLogFormat(ARRAY_VIRTPROD, COL_PRODUCTNAME)
= "ProductName"
' ConfigName
Const VIRTPROD_CONFIGNAME
= 2
arrLogFormat(ARRAY_VIRTPROD, VIRTPROD_CONFIGNAME) = "Config ProductName"
' ProductVersion
Const VIRTPROD_PRODUCTVERSION = 3
arrLogFormat(ARRAY_VIRTPROD, VIRTPROD_PRODUCTVERSION) = "ProductVersion"
' Service Pack Level
Const VIRTPROD_SPLEVEL
= 4
arrLogFormat(ARRAY_VIRTPROD, VIRTPROD_SPLEVEL)
= "ServicePack Level"
' Architecture
Const VIRTPROD_BITNESS
= 5
arrLogFormat(ARRAY_VIRTPROD, VIRTPROD_BITNESS)
= "Architecture"
' (O)SPP License
Const VIRTPROD_OSPPLICENSE
= 6
arrLogFormat(ARRAY_VIRTPROD, VIRTPROD_OSPPLICENSE) = "OSPP License"
' (O)SPP License XML
Const VIRTPROD_OSPPLICENSEXML = 7
arrLogFormat(ARRAY_VIRTPROD, VIRTPROD_OSPPLICENSEXML) = "OSPP License XML"
' Child Packages
Const VIRTPROD_CHILDPACKAGES
= 8
arrLogFormat(ARRAY_VIRTPROD, VIRTPROD_CHILDPACKAGES) = "Child Packages"
Const CSV
= ", "
Const DSV
= " - "
Const DOT
= ". "
Const ERR_CATEGORYNOTE
= "Note: "
Const ERR_CATEGORYWARN
= "Warning: "
Const ERR_CATEGORYERROR
= "Error: "
Const ERR_NONADMIN
= "The script appears to run outside admin
istrator context"
Const ERR_NONELEVATED
= "The script does not appear to run eleva
ted"
Const ERR_DATAINTEGRITY
= "A script internal error occurred. The i
ntegrity of the logged data might be affected"
Const ERR_OBJPRODUCTINFO
= "Installer.ProductInfo -> "
Const ERR_INITSUMINFO
= "Could not connect to summary informatio
n stream"
Const ERR_NOARRAY
= "Array check failed"
Const ERR_UNKNOWNHANDLER
= "Unknown Error Handler: '"
Const ERR_PRODUCTSEXALL
= "ProductsEx for MSIINSTALLCONTEXT_ALL fa
iled"
Const ERR_PATCHESEX
= "PatchesEx failed to get a list of patch
es for: "
Const ERR_PATCHES
= "Installer.Patches failed to get a list
of patches"
Const ERR_MISSINGCHILD
= "A chained product is missing which brea
ks the ability to maintain or uninstall this product. "
Const ERR_ORPHANEDITEM
= "Office application without entry point
in Add/Remove Programs"
Const ERR_INVALIDPRODUCTCODE
= "Critical Windows Installer metadata cor
ruption detected 'Invalid ProductCode'"

Const ERR_INVALIDGUID
= "GUID validation failed"
Const ERR_INVALIDGUIDCHAR
= "Guid contains invalid character(s)"
Const ERR_INVALIDGUIDLENGTH
= "Invalid length for GUID "
Const ERR_GUIDCASE
= "Guid contains lower case character(s)"
Const ERR_BADARPMETADATA
= "Crititcal ARP metadata corruption detec
ted in key: "
Const ERR_OFFSCRUB_TERMINATED
= "Bad ARP metadata. This can be caused by
an OffScrub run that was terminated before it could complete:"
Const ERR_ARPENTRYMISSING
= "Expected regkey not present for ARP con
fig parent"
Const ERR_REGKEYMISSING
= "Regkey does not exist: "
Const ERR_CUSTOMSTACKCORRUPTION
= "Custom stack list string corrupted"
Const ERR_BADMSPMETADATA
= "Metadata mismatch for patch registratio
n"
Const ERR_BADMSINAMEMETADATA
= "Failed to retrieve value for original .
msi name"
Const ERR_BADPACKAGEMETADATA
= "Failed to retrieve value for cached .ms
i package"
Const ERR_PACKAGEAPIFAILURE
= "API failed to retrieve value for cached
.msi package"
Const ERR_BADPACKAGECODEMETADATA
= "Failed to retrieve value for Package Co
de"
Const ERR_PACKAGECODEMISMATCH
= "PackageCode mismatch between registered
value and cached .msi"
Const ERR_LOCALPACKAGEMISSING
= "Local cached .msi appears to be missing
"
Const ERR_BADTRANSFORMSMETADATA
= "Failed to retrieve value for Transforms
"
Const ERR_SICONNECTFAILED
= "Failed to connect to SummaryInformation
stream"
Const ERR_MSPOPENFAILED
= "OpenDatabase failed to open .msp file "
Const ERR_MSIOPENFAILED
= "OpenDatabase failed to open .msi file "
Const ERR_BADFILESTATE
= " has unexpected file state(s). "
Const ERR_FILEVERSIONLOW
= "Review file versions for product "
Const BPA_WIMETADATA
= "This indicates WI metadadata corruption
"
Const BPA_GUID
= "For details on 'GUID' see http://msdn.m
icrosoft.com/en-us/library/Aa368767.aspx"
Const BPA_PACKAGECODE
= "For details on 'Package Codes' see http
://msdn.microsoft.com/en-us/library/aa370568.aspx"
Const BPA_PRODUCTCODE
= "For details on 'Product Codes' see http
://msdn.microsoft.com/en-us/library/aa370860.aspx"
Const BPA_PACKAGECODEMISMATCH
= "A mismatch of the PackageCode will forc
e the Windows Installer to recache the local .msi from the InstallSource. For de
tails on 'Package Code' see http://msdn2.microsoft.com/en-us/library/aa370568.as
px"
'===============================================================================
========================
Main
'===============================================================================
========================
'Module Main
'===============================================================================
========================
Sub Main
Dim fCheckPreReq, FsoLogFile, FsoXmlLogFile
'CheckPreReq needs to be the first thing.
On Error Resume Next

' Check type of scripting host

fCScript = (UCase(Mid(Wscript.FullName, Len(Wscript.Path) + 2, 1)) = "C")
' Ensure all required objects are available. Prerequisite Checks with inline err
or handling.
fCheckPreReq = CheckPreReq()
If fCheckPreReq = False Then Exit Sub
' Initializations
Initialize
' Get computer specific properties
If fCScript AND NOT fQuiet Then wscript.echo "Stage 1 of 11: Get computer sp
ecific properties"
ComputerProperties
' Build an array with a list of all Windows Installer based products
' After this point the master array "arrMaster" is instantiated and has the basi
c product details
If fCScript AND NOT fQuiet Then wscript.echo "Stage 2 of 11: Find products"
FindAllProducts
' Get additional product properties and add them to the master array
If fCScript AND NOT fQuiet Then wscript.echo "Stage 3 of 11: Find additional
product properties"
ProductProperties
' Build an array with data on the InstallSource(s)
If fCScript AND NOT fQuiet Then wscript.echo "Stage 4 of 11: Find registered
InstallSources"
ReadMsiInstallSources
' Build an array with data from Add/Remove Products
' Only Office >= 2007 products that use a multiple .msi structure will be covere
d here
If fCScript AND NOT fQuiet Then wscript.echo "Stage 5 of 11: Add/Remove Prog
rams analysis"
ARPData
' Add Licensing data
' Only Office >= 2010 products that use OSPP are covered here
If fCScript AND NOT fQuiet Then wscript.echo "Stage 6 of 11: Check licensing
(OSPP) data"
OsppCollect
' Build an array with all patch data.
If fCScript AND NOT fQuiet Then wscript.echo "Stage 7 of 11: Find patches"
FindAllPatches
If fFeatureTree Then
' Build a tree structure for the Features
If fCScript AND NOT fQuiet Then wscript.echo "Stage 8 of 11: Find Featur
es and FeatureStates"
FindFeatureStates
Else
If fCScript AND NOT fQuiet Then wscript.echo "Skipping stage 8 of 11: (F
eatureStates)"
End If 'fFeatureTree
' Create file inventory XML files
If fFileInventory Then
If fCScript AND NOT fQuiet Then wscript.echo "Stage 9 of 11: File Invent
ory"
FileInventory
Else
If fCScript AND NOT fQuiet Then wscript.echo "Skipping stage 9 of 11: (F
ileInventory)"
End If 'fFileInventory
' Prepare the collected data for the output file
If fCScript AND NOT fQuiet Then wscript.echo "Stage 10 of 11: Prepare collec
ted data for output"

PrepareLog sLogFormat
' Write the output file
If fCScript AND NOT fQuiet Then wscript.echo "Stage 11 of 11: Write log"
WriteLog
Set FsoLogFile = oFso.GetFile(sLogFile)
Set FsoXmlLogFile = oFso.GetFile(sPathOutputFolder & sComputerName & "_ROISc
an.xml")
If fFileInventory Then
If (oFso.FileExists(sPathOutputFolder & sComputerName & "_ROIScan.zip")
AND NOT fZipError) Then
CopyToZip ShellApp.NameSpace(sPathOutputFolder & sComputerName & "_R
OIScan.zip"), FsoLogFile
CopyToZip ShellApp.NameSpace(sPathOutputFolder & sComputerName & "_R
OIScan.zip"), FsoXmlLogFile
End If
End If
If fCScript AND NOT fQuiet Then wscript.echo "Done!"
' Open the output file
If Not fQuiet Then
Set oShell = CreateObject("WScript.Shell")
If fFileInventory Then
If oFso.FileExists(sPathOutputFolder & sComputerName & "_ROIScan.zip
") AND NOT fZipError Then
oShell.Run "explorer /e," & chr(34) & sPathOutputFolder&sCompute
rName & "_ROIScan.zip" & chr(34)
Else
oShell.Run "explorer /e," & chr(34) & sPathOutputFolder & "ROISc
an" & chr(34)
End If
End If 'fFileInventory
oShell.Run chr(34) & sLogFile & chr(34)
Set oShell = Nothing
End If 'fQuiet
' Clear up Objects
CleanUp
End Sub
'===============================================================================
========================
'Initialize defaults, setting and collect current user information
Sub Initialize
Dim oApp, oWmiLocal, Process, Processes
Dim sEnvVar, Argument
Dim iPopup, iInstanceCnt
Dim fPrompt
On Error Resume Next
'Ensure there's only a single instance running of this script
iInstanceCnt = 0
Set oWmiLocal = GetObject("winmgmts:\\.\root\cimv2")
wscript.sleep 500
Set Processes = oWmiLocal.ExecQuery("Select * From Win32_Process")
For Each Process in Processes
If LCase(Mid(Process.Name,2,6))="script" Then
If InStr(LCase(Process.CommandLine),"roiscan")>0 AND NOT InStr(Proce
ss.CommandLine," UAC") > 0 Then iInstanceCnt=iInstanceCnt+1
End If
Next 'Process
If iInstanceCnt>1 Then
If NOT fQuiet Then wscript.echo "Error: Another instance of this script
is already running."

wscript.quit
End If
If Left(sPathOutputFolder,1)="%" Then
sEnvVar = oShell.ExpandEnvironmentStrings(Mid(sPathOutputFolder,1,InStr(
2,sPathOutputFolder,"%")))
If Len(sPathOutputFolder) = InStr(2,sPathOutputFolder,"%") Then
sPathOutputFolder = sEnvVar
Else
sPathOutputFolder = sEnvVar & Mid(sPathOutputFolder,InStr(2,sPathOu
tputFolder,"%")+1,Len(sPathOutputFolder))
End If
ElseIf Trim(UCase(sPathOutputFolder)) = "DESKTOP" Then
Set oApp = CreateObject ("Shell.Application")
Const DESKTOP = &H10&
sPathOutputFolder = oApp.Namespace(DESKTOP).Self.Path
Set oApp = Nothing
ElseIf InStr(":\",Mid(sPathOutputFolder,2,1))>0 Then
'Validate Folder exists
If Not oFso.FolderExists(sPathOutputFolder) Then sPathOutputFolder = oSh
ell.ExpandEnvironmentStrings("%TEMP%")
Else
sPathOutputFolder = oShell.ExpandEnvironmentStrings("%TEMP%")
End If
sPathOutputFolder = oFso.GetAbsolutePathName(sPathOutputFolder)
While Right(sPathOutputFolder,1) = "\"
sPathOutputFolder = Left(sPathOutputFolder,Len(sPathOutputFolder)-1)
Wend
If Not Right(sPathOutputFolder,1) = "\" Then sPathOutputFolder = sPathOutput
Folder & "\"
If Not oFso.FolderExists(sPathOutputFolder) Then sPathOutputFolder = oShell.
ExpandEnvironmentStrings("%TEMP%") & "\"
sLogFile = sPathOutputFolder & sComputerName & "_ROIScan.log"
CacheLog LOGPOS_COMPUTER,LOGHEADING_H1,Null,"Computer"
CacheLog LOGPOS_REVITEM,LOGHEADING_H1,Null,"Review Items"
'CacheLog LOGPOS_PRODUCT,LOGHEADING_H1,Null,"Products Inventory"
CacheLog LOGPOS_RAW,LOGHEADING_H1,Null,"Raw Data"
iPopup = -1
fPrompt = True
If Wscript.Arguments.Count > 0 Then
For Each Argument in Wscript.Arguments
If Argument = "UAC" Then fPrompt = False
Next 'Argument
End If
'Add warning to log if non-admin was detected
If Not fIsAdmin Then
Cachelog LOGPOS_REVITEM,LOGHEADING_NONE,ERR_CATEGORYERROR,ERR_NONADMIN
If NOT fQuiet AND fPrompt Then RelaunchElevated
End If
If fIsAdmin AND (NOT fIsElevated) Then
Cachelog LOGPOS_REVITEM,LOGHEADING_NONE,ERR_CATEGORYERROR,ERR_NONELEVATE
D
If NOT fQuiet AND fPrompt Then RelaunchElevated
End If
'Ensure CScript as engine
If (NOT UCase(Mid(Wscript.FullName, Len(Wscript.Path) + 2, 1)) = "C") AND (N
OT fDisallowCScript) Then RelaunchAsCScript
'Check on 64 bit OS -> see CheckPreReq
'Init sCurUserSid
GetUserSids("Current")
'Init "arrUUSids"

Redim arrUUSids(-1)
GetUserSids("UserUnmanaged")
'Init "arrUMSids"
Redim arrUMSids(-1)
GetUserSids("UserManaged")
'Set defaults for ProductList arrays
InitPLArrays
Set dicMspIndex = CreateObject("Scripting.Dictionary")
bOsppInit = False
'Other defaults
Set dicPatchLevel = CreateObject("Scripting.Dictionary")
Set dicScenario = CreateObject("Scripting.Dictionary")
fZipError = False
fInitArrProdVer = False
End Sub 'Initialize
'===============================================================================
========================
'End Of Main Module
'===============================================================================
========================
'Module LicenseState (OSPP)
'===============================================================================
========================
Sub OsppInit
On Error Resume Next
Dim oWmiLocal
Set oWmiLocal = GetObject("winmgmts:\\.\root\cimv2")
If iVersionNt > 601 Then
Set Spp = oWmiLocal.ExecQuery("SELECT ID, ApplicationId, PartialProductK
ey, Description, Name, LicenseStatus, LicenseStatusReason, ProductKeyID, GracePe
riodRemaining, LicenseFamily, DiscoveredKeyManagementServiceMachineName, KeyMana
gementServicePort, VLActivationInterval, VLRenewalInterval FROM SoftwareLicensin
gProduct")
End If
Set Ospp = oWmiLocal.ExecQuery("SELECT ID, ApplicationId, PartialProductKey,
Description, Name, LicenseStatus, LicenseStatusReason, ProductKeyID, GracePerio
dRemaining, LicenseFamily, DiscoveredKeyManagementServiceMachineName, KeyManagem
entServicePort, VLActivationInterval, VLRenewalInterval FROM OfficeSoftwareProte
ctionProduct")
bOsppInit = True
End Sub 'OsppInit
'===============================================================================
========================
Function GetLicCnt(iPosMaster, iVersionMajor, ByVal sConfigName, sPossibleSkus,
sPossibleSkusFull)
On Error Resume Next
Dim iLicCnt, iLeft, iCnt
Dim sPrefix
Dim ProdLic, ConfigProd, prop, ProtectionClass
Dim arrLic
Dim fMsiMatchesOsppID, fExclude
If NOT bOsppInit Then OsppInit
If NOT CheckArray(Ospp) AND NOT IsObject(Ospp) Then Exit Function
GetPrefixAndConfig iVersionMajor, sConfigName, sPrefix
If sConfigName <> "" Then arrLic = Split(sConfigName,";")
iLicCnt = 0
If CheckArray(arrLic) Then

For Each ConfigProd in arrLic

iLeft = Len(sPrefix) + Len(ConfigProd)
If iVersionMajor > 14 and iVersionNt > 601 Then
Set ProtectionClass = Spp
Else
Set ProtectionClass = Ospp
End If
Err.Clear
For Each ProdLic in ProtectionClass
If NOT Err = 0 Then
err.Clear
Exit For
End If
fMsiMatchesOsppID = False
fExclude = False
If NOT iPosMaster = -1 Then
If (NOT IsNull (Mid(Prodlic.ProductKeyID, 13, 10))) AND NOT
IsNull(arrMaster(iPosMaster, COL_PRODUCTID)) Then _
fMsiMatchesOsppID = (Mid(arrMaster(iPosMaster, COL_PRODU
CTID), 7, 10) = Mid(Prodlic.ProductKeyID, 13, 10) )
End If
' check for exceptions
If UCase(ConfigProd) = "VISIO" Then
' SingeleImage Delta Trial productid conflicts with Visio signat
ure
fExclude = InStr(Prodlic.Name, "DeltaTrial") > 0
End If 'visio
' add matches to counter and sku-string
If (LCase(Left(ProdLic.Name, iLeft)) = LCase(sPrefix & ConfigPro
d) OR fMsiMatchesOsppID) AND NOT fExclude Then
iLicCnt = iLicCnt + 1
sPossibleSkus = sPossibleSkus & "; " & ProdLic.Name
End If
Next 'ProdLic
Next 'ConfigProd
End If
sPossibleSkusFull = sPossibleSkus
sPossibleSkus = Replace(sPossibleSkus,sPrefix,"")
sPossibleSkus = Replace(sPossibleSkus," edition;",",")
GetLicCnt = iLicCnt
End Function 'GetLicCnt
'===============================================================================
========================
Sub GetPrefixAndConfig(iVersionMajor, sConfigName, sPrefix)
On Error Resume Next
Select Case iVersionMajor
Case 14
sPrefix = "Office 14, Office"
If sConfigName = "SingleImage" Then sConfigName = "SingleImage;Professio
nal;HomeBusiness;HomeStudent;OneNote;Word;HSOneNote;HSWord;OEM"
If sConfigName = "Click2Run" Then sConfigName = "Click2Run;HomeBusiness;
HomeStudent;Starter;OEM"
If Len(sConfigName) > 2 Then
If UCase(Left(sConfigName,3)) = "PRJ" Then sConfigName = "Project"
If UCase(Right(sConfigName,1)) = "R" Then sConfigName = Left(sConfig
Name,(Len(sConfigName)-1))
End If
Case 15
sPrefix = "Office 15, Office"

If sConfigName = "SingleImage" Then sConfigName = "SingleImage;Professio

nal;HomeBusiness;HomeStudent;OneNote;Word;HSOneNote;HSWord;OEM"
If Len(sConfigName) > 2 Then
If UCase(Left(sConfigName,3)) = "PRJ" Then sConfigName = "Project"
If UCase(Right(sConfigName,1)) = "R" Then sConfigName = Left(sConfig
Name,(Len(sConfigName)-1))
End If
Case Else
End Select
End Sub
'===============================================================================
========================
Function GetLicenseData(iPosMaster, iVersionMajor, ByVal sConfigName, iLicPos, s
PossibleSkusFull)
On Error Resume Next
Dim arrLicData (14)
Dim iPropCnt, iLicCnt, iLeft
Dim ProdLic, prop, ConfigProd, ProtectionClass
Dim sPrefix, sAllLic, sName
Dim arrLic
Dim fMsiMatchesOsppID
If NOT bOsppInit Then OsppInit
iLeft = Len(sConfigName)
GetPrefixAndConfig iVersionMajor,sConfigName,sPrefix
If sConfigName <> "" Then arrLic = Split(sConfigName,";")
For Each ConfigProd in arrLic
sAllLic = sAllLic & sPrefix&ConfigProd&";"
Next
If CheckArray(arrLic) Then
iLicCnt = 0
If iVersionMajor > 14 and iVersionNt > 601 Then
Set ProtectionClass = Spp
Else
Set ProtectionClass = Ospp
End If
For Each ProdLic in ProtectionClass
fMsiMatchesOsppID = False
If NOT iPosMaster = -1 Then
If (NOT IsNull (Mid(Prodlic.ProductKeyID, 13, 10))) AND NOT IsNu
ll(arrMaster(iPosMaster, COL_PRODUCTID)) Then _
fMsiMatchesOsppID = (Mid(arrMaster(iPosMaster,COL_PRODUCTID)
, 7, 10) = Mid(Prodlic.ProductKeyID, 13, 10) )
End If
iLicCnt = iLicCnt + 1
For Each ConfigProd in arrLic
iLeft = Len(sPrefix) + Len(ConfigProd)
If Len(ProdLic.Name)>iLeft -1 Then
If (LCase(Left(ProdLic.Name, iLeft)) = LCase(sPrefix & Confi
gProd) OR fMsiMatchesOsppID) AND (iLicCnt > iLicPos) AND InStr(sPossibleSkusFull
, Prodlic.Name) > 0 Then
iLicPos = iLicCnt
arrLicData(OSPP_ID) = ProdLic.ID
arrLicData(OSPP_APPLICATIONID) = ProdLic.ApplicationId
arrLicData(OSPP_PARTIALPRODUCTKEY) = ProdLic.PartialProd
uctKey
arrLicData(OSPP_DESCRIPTION) = ProdLic.Description
arrLicData(OSPP_NAME) = ProdLic.Name
arrLicData(OSPP_LICENSESTATUS) = ProdLic.LicenseStatus

arrLicData(OSPP_LICENSESTATUSREASON) = ProdLic.LicenseSt
atusReason
arrLicData(OSPP_PRODUCTKEYID) = ProdLic.ProductKeyID
arrLicData(OSPP_GRACEPERIODREMAINING) = ProdLic.GracePer
iodRemaining
arrLicData(OSPP_LICENSEFAMILY) = ProdLic.LicenseFamily
arrLicData(OSPP_DISCOVEREDKEYMANAGEMENTSERVICEMACHINENAM
E) = ProdLic.DiscoveredKeyManagementServiceMachineName
arrLicData(OSPP_KEYMANAGEMENTSERVICEPORT) = ProdLic.KeyM
anagementServicePort
arrLicData(OSPP_VLACTIVATIONINTERVAL) = ProdLic.VLActiva
tionInterval
arrLicData(OSPP_VLRENEWALINTERVAL) = ProdLic.VLRenewalIn
terval
GetLicenseData = arrLicData
Exit Function
End If
End If
Next
Next 'ProdLic
End If
GetLicenseData = arrLicData
End Function 'GetLicenseData
'===============================================================================
========================
Function GetLicErrDesc(hErr)
On Error Resume Next
Select Case "0x"& hErr
Case "0x0" : GetLicErrDesc = "Success."
Case "0xC004B001" : GetLicErrDesc = "The activation server determined that the l
icense is invalid."
Case "0xC004B002" : GetLicErrDesc = "The activation server determined that the l
icense is invalid."
Case "0xC004B003" : GetLicErrDesc = "The activation server determined that the l
icense is invalid."
Case "0xC004B004" : GetLicErrDesc = "The activation server determined that the l
icense is invalid."
Case "0xC004B005" : GetLicErrDesc = "The activation server determined that the l
icense is invalid."
Case "0xC004B006" : GetLicErrDesc = "The activation server determined that the l
icense is invalid."
Case "0xC004B007" : GetLicErrDesc = "The activation server reported that the com
puter could not connect to the activation server."
Case "0xC004B008" : GetLicErrDesc = "The activation server determined that the c
omputer could not be activated."
Case "0xC004B009" : GetLicErrDesc = "The activation server determined that the l
icense is invalid."
Case "0xC004B011" : GetLicErrDesc = "The activation server determined that your
computer clock time is not correct. You must correct your clock before you can a
ctivate."
Case "0xC004B100" : GetLicErrDesc = "The activation server determined that the c
omputer could not be activated."
Case "0xC004C001" : GetLicErrDesc = "The activation server determined the specif
ied product key is invalid."
Case "0xC004C002" : GetLicErrDesc = "The activation server determined there is a
problem with the specified product key."
Case "0xC004C003" : GetLicErrDesc = "The activation server determined the specif
ied product key has been blocked."
Case "0xC004C004" : GetLicErrDesc = "The activation server determined the specif

ied product key is invalid."

Case "0xC004C005" : GetLicErrDesc = "The activation server determined the licens
e is invalid."
Case "0xC004C006" : GetLicErrDesc = "The activation server determined the licens
e is invalid."
Case "0xC004C007" : GetLicErrDesc = "The activation server determined the specif
ied product key is invalid."
Case "0xC004C008" : GetLicErrDesc = "The activation server determined that the s
pecified product key could not be used."
Case "0xC004C009" : GetLicErrDesc = "The activation server determined the licens
e is invalid."
Case "0xC004C00A" : GetLicErrDesc = "The activation server determined the licens
e is invalid."
Case "0xC004C00B" : GetLicErrDesc = "The activation server determined the licens
e is invalid."
Case "0xC004C00C" : GetLicErrDesc = "The activation server experienced an error.
"
Case "0xC004C00D" : GetLicErrDesc = "The activation server determined the licens
e is invalid."
Case "0xC004C00E" : GetLicErrDesc = "The activation server determined the specif
ied product key is invalid."
Case "0xC004C00F" : GetLicErrDesc = "The activation server determined the specif
ied product key is invalid."
Case "0xC004C010" : GetLicErrDesc = "The activation server determined the specif
ied product key is invalid."
Case "0xC004C011" : GetLicErrDesc = "The activation server determined the licens
e is invalid."
Case "0xC004C012" : GetLicErrDesc = "The activation server experienced a network
error."
Case "0xC004C013" : GetLicErrDesc = "The activation server experienced an error.
"
Case "0xC004C014" : GetLicErrDesc = "The activation server experienced an error.
"
Case "0xC004C020" : GetLicErrDesc = "The activation server reported that the Mul
tiple Activation Key has exceeded its limit."
Case "0xC004C021" : GetLicErrDesc = "The activation server reported that the Mul
tiple Activation Key extension limit has been exceeded."
Case "0xC004C022" : GetLicErrDesc = "The activation server reported that the reissuance limit was not found."
Case "0xC004C023" : GetLicErrDesc = "The activation server reported that the ove
rride request was not found."
Case "0xC004C016" : GetLicErrDesc = "The activation server reported that the spe
cified product key cannot be used for online activation."
Case "0xC004C017" : GetLicErrDesc = "The activation server determined the specif
ied product key has been blocked for this geographic location."
Case "0xC004C015" : GetLicErrDesc = "The activation server experienced an error.
"
Case "0xC004C050" : GetLicErrDesc = "The activation server experienced a general
error."
Case "0xC004C030" : GetLicErrDesc = "The activation server reported that time ba
sed activation attempted before start date."
Case "0xC004C031" : GetLicErrDesc = "The activation server reported that time ba
sed activation attempted after end date."
Case "0xC004C032" : GetLicErrDesc = "The activation server reported that new tim
e based activation not available."
Case "0xC004C033" : GetLicErrDesc = "The activation server reported that time ba
sed product key not configured for activation."
Case "0xC004C04F" : GetLicErrDesc = "The activation server reported that no busi
ness rules available to activate specified product key."
Case "0xC004C700" : GetLicErrDesc = "The activation server reported that busines

s rule cound not find required input."

Case "0xC004C750" : GetLicErrDesc = "The activation server reported that NULL va
lue specified for business property name and Id."
Case "0xC004C751" : GetLicErrDesc = "The activation server reported that propert
y name specifies unknown property."
Case "0xC004C752" : GetLicErrDesc = "The activation server reported that propert
y Id specifies unknown property."
Case "0xC004C755" : GetLicErrDesc = "The activation server reported that it fail
ed to update product key binding."
Case "0xC004C756" : GetLicErrDesc = "The activation server reported that it fail
ed to insert product key binding."
Case "0xC004C757" : GetLicErrDesc = "The activation server reported that it fail
ed to delete product key binding."
Case "0xC004C758" : GetLicErrDesc = "The activation server reported that it fail
ed to process input XML for product key bindings."
Case "0xC004C75A" : GetLicErrDesc = "The activation server reported that it fail
ed to insert product key property."
Case "0xC004C75B" : GetLicErrDesc = "The activation server reported that it fail
ed to update product key property."
Case "0xC004C75C" : GetLicErrDesc = "The activation server reported that it fail
ed to delete product key property."
Case "0xC004C764" : GetLicErrDesc = "The activation server reported that the pro
duct key type is unknown."
Case "0xC004C770" : GetLicErrDesc = "The activation server reported that the pro
duct key type is being used by another user."
Case "0xC004C780" : GetLicErrDesc = "The activation server reported that it fail
ed to insert product key record."
Case "0xC004C781" : GetLicErrDesc = "The activation server reported that it fail
ed to update product key record."
Case "0xC004C401" : GetLicErrDesc = "The Vista Genuine Advantage Service determi
ned that the installation is not genuine."
Case "0xC004C600" : GetLicErrDesc = "The Vista Genuine Advantage Service determi
ned that the installation is not genuine."
Case "0xC004C801" : GetLicErrDesc = "The activation server determined the specif
ied product key is invalid."
Case "0xC004C802" : GetLicErrDesc = "The activation server determined the specif
ied product key is invalid."
Case "0xC004C803" : GetLicErrDesc = "The activation server determined the specif
ied product key has been revoked."
Case "0xC004C804" : GetLicErrDesc = "The activation server determined the specif
ied product key is invalid."
Case "0xC004C805" : GetLicErrDesc = "The activation server determined the specif
ied product key is invalid."
Case "0xC004C810" : GetLicErrDesc = "The activation server determined the specif
ied product key is invalid."
Case "0xC004C811" : GetLicErrDesc = "The activation server determined the licens
e is invalid."
Case "0xC004C812" : GetLicErrDesc = "The activation server determined that the s
pecified product key has exceeded its activation count."
Case "0xC004C813" : GetLicErrDesc = "The activation server determined the licens
e is invalid."
Case "0xC004C814" : GetLicErrDesc = "The activation server determined the specif
ied product key is invalid."
Case "0xC004C815" : GetLicErrDesc = "The activation server determined the licens
e is invalid."
Case "0xC004C816" : GetLicErrDesc = "The activation server reported that the spe
cified product key cannot be used for online activation."
Case "0xC004E001" : GetLicErrDesc = "The Software Licensing Service determined t
hat the specified context is invalid."
Case "0xC004E002" : GetLicErrDesc = "The Software Licensing Service reported tha

t the license store contains inconsistent data."

Case "0xC004E003" : GetLicErrDesc = "The Software Licensing Service reported tha
t license evaluation failed."
Case "0xC004E004" : GetLicErrDesc = "The Software Licensing Service reported tha
t the license has not been evaluated."
Case "0xC004E005" : GetLicErrDesc = "The Software Licensing Service reported tha
t the license is not activated."
Case "0xC004E006" : GetLicErrDesc = "The Software Licensing Service reported tha
t the license contains invalid data."
Case "0xC004E007" : GetLicErrDesc = "The Software Licensing Service reported tha
t the license store does not contain the requested license."
Case "0xC004E008" : GetLicErrDesc = "The Software Licensing Service reported tha
t the license property is invalid."
Case "0xC004E009" : GetLicErrDesc = "The Software Licensing Service reported tha
t the license store is not initialized."
Case "0xC004E00A" : GetLicErrDesc = "The Software Licensing Service reported tha
t the license store is already initialized."
Case "0xC004E00B" : GetLicErrDesc = "The Software Licensing Service reported tha
t the license property is invalid."
Case "0xC004E00C" : GetLicErrDesc = "The Software Licensing Service reported tha
t the license could not be opened or created."
Case "0xC004E00D" : GetLicErrDesc = "The Software Licensing Service reported tha
t the license could not be written."
Case "0xC004E00E" : GetLicErrDesc = "The Software Licensing Service reported tha
t the license store could not read the license file."
Case "0xC004E00F" : GetLicErrDesc = "The Software Licensing Service reported tha
t the license property is corrupted."
Case "0xC004E010" : GetLicErrDesc = "The Software Licensing Service reported tha
t the license property is missing."
Case "0xC004E011" : GetLicErrDesc = "The Software Licensing Service reported tha
t the license store contains an invalid license file."
Case "0xC004E012" : GetLicErrDesc = "The Software Licensing Service reported tha
t the license store failed to start synchronization properly."
Case "0xC004E013" : GetLicErrDesc = "The Software Licensing Service reported tha
t the license store failed to synchronize properly."
Case "0xC004E014" : GetLicErrDesc = "The Software Licensing Service reported tha
t the license property is invalid."
Case "0xC004E015" : GetLicErrDesc = "The Software Licensing Service reported tha
t license consumption failed."
Case "0xC004E016" : GetLicErrDesc = "The Software Licensing Service reported tha
t the product key is invalid."
Case "0xC004E017" : GetLicErrDesc = "The Software Licensing Service reported tha
t the product key is invalid."
Case "0xC004E018" : GetLicErrDesc = "The Software Licensing Service reported tha
t the product key is invalid."
Case "0xC004E019" : GetLicErrDesc = "The Software Licensing Service determined t
hat validation of the specified product key failed."
Case "0xC004E01A" : GetLicErrDesc = "The Software Licensing Service reported tha
t invalid add-on information was found."
Case "0xC004E01B" : GetLicErrDesc = "The Software Licensing Service reported tha
t not all hardware information could be collected."
Case "0xC004E01C" : GetLicErrDesc = "This evaluation product key is no longer va
lid."
Case "0xC004E01D" : GetLicErrDesc = "The new product key cannot be used on this
installation of Windows. Type a different product key. (CD-AB)"
Case "0xC004E01E" : GetLicErrDesc = "The new product key cannot be used on this
installation of Windows. Type a different product key. (AB-AB)"
Case "0xC004E01F" : GetLicErrDesc = "The new product key cannot be used on this
installation of Windows. Type a different product key. (AB-CD)"
Case "0xC004E020" : GetLicErrDesc = "The Software Licensing Service reported tha

t there is a mismatched between a policy value and information stored in the Oth
erInfo section."
Case "0xC004E021" : GetLicErrDesc = "The Software Licensing Service reported tha
t the Genuine information contained in the license is not consistent."
Case "0xC004E022" : GetLicErrDesc = "The Software Licensing Service reported tha
t the secure store id value in license does not match with the current value."
Case "0x8004E101" : GetLicErrDesc = "The Software Licensing Service reported tha
t the Token Store file version is invalid."
Case "0x8004E102" : GetLicErrDesc = "The Software Licensing Service reported tha
t the Token Store contains an invalid descriptor table."
Case "0x8004E103" : GetLicErrDesc = "The Software Licensing Service reported tha
t the Token Store contains a token with an invalid header/footer."
Case "0x8004E104" : GetLicErrDesc = "The Software Licensing Service reported tha
t a Token Store token has an invalid name."
Case "0x8004E105" : GetLicErrDesc = "The Software Licensing Service reported tha
t a Token Store token has an invalid extension."
Case "0x8004E106" : GetLicErrDesc = "The Software Licensing Service reported tha
t the Token Store contains a duplicate token."
Case "0x8004E107" : GetLicErrDesc = "The Software Licensing Service reported tha
t a token in the Token Store has a size mismatch."
Case "0x8004E108" : GetLicErrDesc = "The Software Licensing Service reported tha
t a token in the Token Store contains an invalid hash."
Case "0x8004E109" : GetLicErrDesc = "The Software Licensing Service reported tha
t the Token Store was unable to read a token."
Case "0x8004E10A" : GetLicErrDesc = "The Software Licensing Service reported tha
t the Token Store was unable to write a token."
Case "0x8004E10B" : GetLicErrDesc = "The Software Licensing Service reported tha
t the Token Store attempted an invalid file operation."
Case "0x8004E10C" : GetLicErrDesc = "The Software Licensing Service reported tha
t there is no active transaction."
Case "0x8004E10D" : GetLicErrDesc = "The Software Licensing Service reported tha
t the Token Store file header is invalid."
Case "0x8004E10E" : GetLicErrDesc = "The Software Licensing Service reported tha
t a Token Store token descriptor is invalid."
Case "0xC004F001" : GetLicErrDesc = "The Software Licensing Service reported an
internal error."
Case "0xC004F002" : GetLicErrDesc = "The Software Licensing Service reported tha
t rights consumption failed."
Case "0xC004F003" : GetLicErrDesc = "The Software Licensing Service reported tha
t the required license could not be found."
Case "0xC004F004" : GetLicErrDesc = "The Software Licensing Service reported tha
t the product key does not match the range defined in the license."
Case "0xC004F005" : GetLicErrDesc = "The Software Licensing Service reported tha
t the product key does not match the product key for the license."
Case "0xC004F006" : GetLicErrDesc = "The Software Licensing Service reported tha
t the signature file for the license is not available."
Case "0xC004F007" : GetLicErrDesc = "The Software Licensing Service reported tha
t the license could not be found."
Case "0xC004F008" : GetLicErrDesc = "The Software Licensing Service reported tha
t the license could not be found."
Case "0xC004F009" : GetLicErrDesc = "The Software Licensing Service reported tha
t the grace period expired."
Case "0xC004F00A" : GetLicErrDesc = "The Software Licensing Service reported tha
t the application ID does not match the application ID for the license."
Case "0xC004F00B" : GetLicErrDesc = "The Software Licensing Service reported tha
t the product identification data is not available."
Case "0x4004F00C" : GetLicErrDesc = "The Software Licensing Service reported tha
t the application is running within the valid grace period."
Case "0x4004F00D" : GetLicErrDesc = "The Software Licensing Service reported tha
t the application is running within the valid out of tolerance grace period."

Case "0xC004F00E" : GetLicErrDesc = "The Software Licensing Service determined t

hat the license could not be used by the current version of the security process
or component."
Case "0xC004F00F" : GetLicErrDesc = "The Software Licensing Service reported tha
t the hardware ID binding is beyond the level of tolerance."
Case "0xC004F010" : GetLicErrDesc = "The Software Licensing Service reported tha
t the product key is invalid."
Case "0xC004F011" : GetLicErrDesc = "The Software Licensing Service reported tha
t the license file is not installed."
Case "0xC004F012" : GetLicErrDesc = "The Software Licensing Service reported tha
t the call has failed because the value for the input key was not found."
Case "0xC004F013" : GetLicErrDesc = "The Software Licensing Service determined t
hat there is no permission to run the software."
Case "0xC004F014" : GetLicErrDesc = "The Software Licensing Service reported tha
t the product key is not available."
Case "0xC004F015" : GetLicErrDesc = "The Software Licensing Service reported tha
t the license is not installed."
Case "0xC004F016" : GetLicErrDesc = "The Software Licensing Service determined t
hat the request is not supported."
Case "0xC004F017" : GetLicErrDesc = "The Software Licensing Service reported tha
t the license is not installed."
Case "0xC004F018" : GetLicErrDesc = "The Software Licensing Service reported tha
t the license does not contain valid location data for the activation server."
Case "0xC004F019" : GetLicErrDesc = "The Software Licensing Service determined t
hat the requested event ID is invalid."
Case "0xC004F01A" : GetLicErrDesc = "The Software Licensing Service determined t
hat the requested event is not registered with the service."
Case "0xC004F01B" : GetLicErrDesc = "The Software Licensing Service reported tha
t the event ID is already registered."
Case "0xC004F01C" : GetLicErrDesc = "The Software Licensing Service reported tha
t the license is not installed."
Case "0xC004F01D" : GetLicErrDesc = "The Software Licensing Service reported tha
t the verification of the license failed."
Case "0xC004F01E" : GetLicErrDesc = "The Software Licensing Service determined t
hat the input data type does not match the data type in the license."
Case "0xC004F01F" : GetLicErrDesc = "The Software Licensing Service determined t
hat the license is invalid."
Case "0xC004F020" : GetLicErrDesc = "The Software Licensing Service determined t
hat the license package is invalid."
Case "0xC004F021" : GetLicErrDesc = "The Software Licensing Service reported tha
t the validity period of the license has expired."
Case "0xC004F022" : GetLicErrDesc = "The Software Licensing Service reported tha
t the license authorization failed."
Case "0xC004F023" : GetLicErrDesc = "The Software Licensing Service reported tha
t the license is invalid."
Case "0xC004F024" : GetLicErrDesc = "The Software Licensing Service reported tha
t the license is invalid."
Case "0xC004F025" : GetLicErrDesc = "The Software Licensing Service reported tha
t the action requires administrator privilege."
Case "0xC004F026" : GetLicErrDesc = "The Software Licensing Service reported tha
t the required data is not found."
Case "0xC004F027" : GetLicErrDesc = "The Software Licensing Service reported tha
t the license is tampered."
Case "0xC004F028" : GetLicErrDesc = "The Software Licensing Service reported tha
t the policy cache is invalid."
Case "0xC004F029" : GetLicErrDesc = "The Software Licensing Service cannot be st
arted in the current OS mode."
Case "0xC004F02A" : GetLicErrDesc = "The Software Licensing Service reported tha
t the license is invalid."
Case "0xC004F02C" : GetLicErrDesc = "The Software Licensing Service reported tha

t the format for the offline activation data is incorrect."

Case "0xC004F02D" : GetLicErrDesc = "The Software Licensing Service determined t
hat the version of the offline Confirmation ID (CID) is incorrect."
Case "0xC004F02E" : GetLicErrDesc = "The Software Licensing Service determined t
hat the version of the offline Confirmation ID (CID) is not supported."
Case "0xC004F02F" : GetLicErrDesc = "The Software Licensing Service reported tha
t the length of the offline Confirmation ID (CID) is incorrect."
Case "0xC004F030" : GetLicErrDesc = "The Software Licensing Service determined t
hat the Installation ID (IID) or the Confirmation ID (CID) could not been saved.
"
Case "0xC004F031" : GetLicErrDesc = "The Installation ID (IID) and the Confirmat
ion ID (CID) do not match. Please confirm the IID and reacquire a new CID if nec
essary."
Case "0xC004F032" : GetLicErrDesc = "The Software Licensing Service determined t
hat the binding data is invalid."
Case "0xC004F033" : GetLicErrDesc = "The Software Licensing Service reported tha
t the product key is not allowed to be installed. Please see the eventlog for de
tails."
Case "0xC004F034" : GetLicErrDesc = "The Software Licensing Service reported tha
t the license could not be found or was invalid."
Case "0xC004F035" : GetLicErrDesc = "The Software Licensing Service reported tha
t the computer could not be activated with a Volume license product key. Volumelicensed systems require upgrading from a qualifying operating system. Please co
ntact your system administrator or use a different type of key."
Case "0xC004F038" : GetLicErrDesc = "The Software Licensing Service reported tha
t the computer could not be activated. The count reported by your Key Management
Service (KMS) is insufficient. Please contact your system administrator."
Case "0xC004F039" : GetLicErrDesc = "The Software Licensing Service reported tha
t the computer could not be activated. The Key Management Service (KMS) is not
enabled."
Case "0x4004F040" : GetLicErrDesc = "The Software Licensing Service reported tha
t the computer was activated but the owner should verify the Product Use Rights.
"
Case "0xC004F041" : GetLicErrDesc = "The Software Licensing Service determined t
hat the Key Management Service (KMS) is not activated. KMS needs to be activated
. Please contact system administrator."
Case "0xC004F042" : GetLicErrDesc = "The Software Licensing Service determined t
hat the specified Key Management Service (KMS) cannot be used."
Case "0xC004F047" : GetLicErrDesc = "The Software Licensing Service reported tha
t the proxy policy has not been updated."
Case "0xC004F04D" : GetLicErrDesc = "The Software Licensing Service determined t
hat the Installation ID (IID) or the Confirmation ID (CID) is invalid."
Case "0xC004F04F" : GetLicErrDesc = "The Software Licensing Service reported tha
t license management information was not found in the licenses."
Case "0xC004F050" : GetLicErrDesc = "The Software Licensing Service reported tha
t the product key is invalid."
Case "0xC004F051" : GetLicErrDesc = "The Software Licensing Service reported tha
t the product key is blocked."
Case "0xC004F052" : GetLicErrDesc = "The Software Licensing Service reported tha
t the licenses contain duplicated properties."
Case "0xC004F053" : GetLicErrDesc = "The Software Licensing Service determined t
hat the license is invalid. The license contains an override policy that is not
configured properly."
Case "0xC004F054" : GetLicErrDesc = "The Software Licensing Service reported tha
t license management information has duplicated data."
Case "0xC004F055" : GetLicErrDesc = "The Software Licensing Service reported tha
t the base SKU is not available."
Case "0xC004F056" : GetLicErrDesc = "The Software Licensing Service reported tha
t the computer could not be activated using the Key Management Service (KMS)."
Case "0xC004F057" : GetLicErrDesc = "The Software Licensing Service reported tha

t the computer BIOS is missing a required license."

Case "0xC004F058" : GetLicErrDesc = "The Software Licensing Service reported tha
t the computer BIOS is missing a required license."
Case "0xC004F059" : GetLicErrDesc = "The Software Licensing Service reported tha
t a license in the computer BIOS is invalid."
Case "0xC004F060" : GetLicErrDesc = "The Software Licensing Service determined t
hat the version of the license package is invalid."
Case "0xC004F061" : GetLicErrDesc = "The Software Licensing Service determined t
hat this specified product key can only be used for upgrading, not for clean ins
tallations."
Case "0xC004F062" : GetLicErrDesc = "The Software Licensing Service reported tha
t a required license could not be found."
Case "0xC004F063" : GetLicErrDesc = "The Software Licensing Service reported tha
t the computer BIOS is missing a required license."
Case "0xC004F064" : GetLicErrDesc = "The Software Licensing Service reported tha
t the non-genuine grace period expired."
Case "0x4004F065" : GetLicErrDesc = "The Software Licensing Service reported tha
t the application is running within the valid non-genuine grace period."
Case "0xC004F066" : GetLicErrDesc = "The Software Licensing Service reported tha
t the genuine information property can not be set before dependent property been
set."
Case "0xC004F067" : GetLicErrDesc = "The Software Licensing Service reported tha
t the non-genuine grace period expired (type 2)."
Case "0x4004F068" : GetLicErrDesc = "The Software Licensing Service reported tha
t the application is running within the valid non-genuine grace period (type 2).
"
Case "0xC004F069" : GetLicErrDesc = "The Software Licensing Service reported tha
t the product SKU is not found."
Case "0xC004F06A" : GetLicErrDesc = "The Software Licensing Service reported tha
t the requested operation is not allowed."
Case "0xC004F06B" : GetLicErrDesc = "The Software Licensing Service determined t
hat it is running in a virtual machine. The Key Management Service (KMS) is not
supported in this mode."
Case "0xC004F06C" : GetLicErrDesc = "The Software Licensing Service reported tha
t the computer could not be activated. The Key Management Service (KMS) determin
ed that the request timestamp is invalid."
Case "0xC004F071" : GetLicErrDesc = "The Software Licensing Service reported tha
t the plug-in manifest file is incorrect."
Case "0xC004F072" : GetLicErrDesc = "The Software Licensing Service reported tha
t the license policies for fast query could not be found."
Case "0xC004F073" : GetLicErrDesc = "The Software Licensing Service reported tha
t the license policies for fast query have not been loaded."
Case "0xC004F074" : GetLicErrDesc = "The Software Licensing Service reported tha
t the computer could not be activated. No Key Management Service (KMS) could be
contacted. Please see the Application Event Log for additional information."
Case "0xC004F075" : GetLicErrDesc = "The Software Licensing Service reported tha
t the operation cannot be completed because the service is stopping."
Case "0xC004F076" : GetLicErrDesc = "The Software Licensing Service reported tha
t the requested plug-in cannot be found."
Case "0xC004F077" : GetLicErrDesc = "The Software Licensing Service determined i
ncompatible version of authentication data."
Case "0xC004F078" : GetLicErrDesc = "The Software Licensing Service reported tha
t the key is mismatched."
Case "0xC004F079" : GetLicErrDesc = "The Software Licensing Service reported tha
t the authentication data is not set."
Case "0xC004F07A" : GetLicErrDesc = "The Software Licensing Service reported tha
t the verification could not be done."
Case "0xC004F07B" : GetLicErrDesc = "The requested operation is unavailable whil
e the Software Licensing Service is running."
Case "0xC004F07C" : GetLicErrDesc = "The Software Licensing Service determined t

hat the version of the computer BIOS is invalid."

Case "0xC004F200" : GetLicErrDesc = "The Software Licensing Service reported tha
t current state is not genuine."
Case "0xC004F301" : GetLicErrDesc = "The Software Licensing Service reported tha
t the computer could not be activated. The token-based activation challenge has
expired."
Case "0xC004F302" : GetLicErrDesc = "The Software Licensing Service reported tha
t Silent Activation failed. The Software Licensing Service reported that there a
re no certificates found in the system that could activate the product without u
ser interaction."
Case "0xC004F303" : GetLicErrDesc = "The Software Licensing Service reported tha
t the certificate chain could not be built or failed validation."
Case "0xC004F304" : GetLicErrDesc = "The Software Licensing Service reported tha
t required license could not be found."
Case "0xC004F305" : GetLicErrDesc = "The Software Licensing Service reported tha
t there are no certificates found in the system that could activate the product.
"
Case "0xC004F306" : GetLicErrDesc = "The Software Licensing Service reported tha
t this software edition does not support token-based activation."
Case "0xC004F307" : GetLicErrDesc = "The Software Licensing Service reported tha
t the computer could not be activated. Activation data is invalid."
Case "0xC004F308" : GetLicErrDesc = "The Software Licensing Service reported tha
t the computer could not be activated. Activation data is tampered."
Case "0xC004F309" : GetLicErrDesc = "The Software Licensing Service reported tha
t the computer could not be activated. Activation challenge and response do not
match."
Case "0xC004F30A" : GetLicErrDesc = "The Software Licensing Service reported tha
t the computer could not be activated. The certificate does not match the condit
ions in the license."
Case "0xC004F30B" : GetLicErrDesc = "The Software Licensing Service reported tha
t the inserted smartcard could not be used to activate the product."
Case "0xC004F30C" : GetLicErrDesc = "The Software Licensing Service reported tha
t the token-based activation license content is invalid."
Case "0xC004F30D" : GetLicErrDesc = "The Software Licensing Service reported tha
t the computer could not be activated. The thumbprint is invalid."
Case "0xC004F30E" : GetLicErrDesc = "The Software Licensing Service reported tha
t the computer could not be activated. The thumbprint does not match any certifi
cate."
Case "0xC004F30F" : GetLicErrDesc = "The Software Licensing Service reported tha
t the computer could not be activated. The certificate does not match the criter
ia specified in the issuance license."
Case "0xC004F310" : GetLicErrDesc = "The Software Licensing Service reported tha
t the computer could not be activated. The certificate does not match the trust
point identifier (TPID) specified in the issuance license."
Case "0xC004F311" : GetLicErrDesc = "The Software Licensing Service reported tha
t the computer could not be activated. A soft token cannot be used for activatio
n."
Case "0xC004F312" : GetLicErrDesc = "The Software Licensing Service reported tha
t the computer could not be activated. The certificate cannot be used because it
s private key is exportable."
Case "0xC004F313" : GetLicErrDesc = "The Software Licensing Service reported tha
t the CNG encryption library could not be loaded. The current certificate may n
ot be available on this version of Windows."
Case "0xC004FC03" : GetLicErrDesc = "A networking problem has occurred while act
ivating your copy of Windows."
Case "0x4004FC04" : GetLicErrDesc = "The Software Licensing Service reported tha
t the application is running within the timebased validity period."
Case "0x4004FC05" : GetLicErrDesc = "The Software Licensing Service reported tha
t the application has a perpetual grace period."
Case "0x4004FC06" : GetLicErrDesc = "The Software Licensing Service reported tha

t the application is running within the valid extended grace period."

Case "0xC004FC07" : GetLicErrDesc = "The Software Licensing Service reported tha
t the validity period expired."
Case "0xC004FE00" : GetLicErrDesc = "The Software Licensing Service reported tha
t activation is required to recover from tampering of SL Service trusted store."
Case "0xC004D101" : GetLicErrDesc = "The security processor reported an initiali
zation error."
Case "0x8004D102" : GetLicErrDesc = "The security processor reported that the ma
chine time is inconsistent with the trusted time."
Case "0xC004D103" : GetLicErrDesc = "The security processor reported that an err
or has occurred."
Case "0xC004D104" : GetLicErrDesc = "The security processor reported that invali
d data was used."
Case "0xC004D105" : GetLicErrDesc = "The security processor reported that the va
lue already exists."
Case "0xC004D107" : GetLicErrDesc = "The security processor reported that an ins
ufficient buffer was used."
Case "0xC004D108" : GetLicErrDesc = "The security processor reported that invali
d data was used."
Case "0xC004D109" : GetLicErrDesc = "The security processor reported that an inv
alid call was made."
Case "0xC004D10A" : GetLicErrDesc = "The security processor reported a version m
ismatch error."
Case "0x8004D10B" : GetLicErrDesc = "The security processor cannot operate while
a debugger is attached."
Case "0xC004D301" : GetLicErrDesc = "The security processor reported that the tr
usted data store was tampered."
Case "0xC004D302" : GetLicErrDesc = "The security processor reported that the tr
usted data store was rearmed."
Case "0xC004D303" : GetLicErrDesc = "The security processor reported that the tr
usted store has been recreated."
Case "0xC004D304" : GetLicErrDesc = "The security processor reported that entry
key was not found in the trusted data store."
Case "0xC004D305" : GetLicErrDesc = "The security processor reported that the en
try key already exists in the trusted data store."
Case "0xC004D306" : GetLicErrDesc = "The security processor reported that the en
try key is too big to fit in the trusted data store."
Case "0xC004D307" : GetLicErrDesc = "The security processor reported that the ma
ximum allowed number of re-arms has been exceeded. You must re-install the OS b
efore trying to re-arm again."
Case "0xC004D308" : GetLicErrDesc = "The security processor has reported that en
try data size is too big to fit in the trusted data store."
Case "0xC004D309" : GetLicErrDesc = "The security processor has reported that th
e machine has gone out of hardware tolerance."
Case "0xC004D30A" : GetLicErrDesc = "The security processor has reported that th
e secure timer already exists."
Case "0xC004D30B" : GetLicErrDesc = "The security processor has reported that th
e secure timer was not found."
Case "0xC004D30C" : GetLicErrDesc = "The security processor has reported that th
e secure timer has expired."
Case "0xC004D30D" : GetLicErrDesc = "The security processor has reported that th
e secure timer name is too long."
Case "0xC004D30E" : GetLicErrDesc = "The security processor reported that the tr
usted data store is full."
Case "0xC004D401" : GetLicErrDesc = "The security processor reported a system fi
le mismatch error."
Case "0xC004D402" : GetLicErrDesc = "The security processor reported a system fi
le mismatch error."
Case "0xC004D501" : GetLicErrDesc = "The security processor reported an error wi
th the kernel data."

Case Else : GetLicErrDesc = ""

End Select
End Function 'GetLicErrDesc
'===============================================================================
========================
'Module FileInventory
'===============================================================================
========================
'File inventory for installed applications
Sub FileInventory
Dim sProductCode,sQueryFT,sQueryMst,sQueryCompID,sQueryFC,sMst,sFtk,sCmp
Dim sPath,sName,sXmlLine,sAscCheck,sQueryDir,sQueryAssembly,sPatchCode
Dim sCurVer,sSqlCreateTable,sTables,sTargetPath
Dim iPosMaster,iPosPatch,iFoo,iFile,iMst,iCnt,iAsc,iAscCnt,iCmp
Dim iPosArr,iArrMaxCnt,iColCnt,iBaseRefCnt,iIndex
Dim bAsc,bMstApplied,bBaseRefFound,bFtkViewComplete,bFtkInScope,bFtkForceOut
OfScope,bNeedKeyPathFallback
Dim bCreate,bDelete,bDrop,bInsert,bFileNameChanged
Dim MsiDb,SessionDb,MspDb,qViewFT,qViewMst,qViewCompID,qViewFC,qViewDir,qVie
wAssembly,Record,Record2,Record3
Dim qViewMspCompId,qViewMspFC,qViewMsiAssembly,AllOfficeFiles,FileStream
Dim SessionDir,Table,ViewTables,tbl
Dim dicTransforms,dicKeys
Dim arrTables
If fBasicMode Then Exit Sub
On Error Resume Next
Const FILES_FTK
= 0 'key field for each file
Const FILES_SOURCE
= 1
Const FILES_ISPATCHED
= 2
Const FILES_FILESTATUS
= 3
Const FILES_FILE
= 4
Const FILES_FOLDER
= 5
Const FILES_FULLNAME
= 6
Const FILES_LANGUAGE
= 7
Const FILES_BASEVERSION
= 8
Const FILES_PATCHVERSION
= 9
Const FILES_CURRENTVERSION =10
Const FILES_VERSIONSTATUS =11
Const FILES_PATCHCODE
=12 'key field for patch
Const FILES_PATCHSTATE
=13
Const FILES_PATCHKB
=14
Const FILES_PATCHPACKAGE
=15
Const FILES_PATCHMOREINFO =16
Const FILES_DIRECTORY
=17
Const FILES_COMPONENTID
=18
Const FILES_COMPONENTNAME =19
Const FILES_COMPONENTSTATE =20
Const FILES_KEYPATH
=21
Const FILES_COMPONENTCLIENTS=22
Const FILES_FEATURENAMES
=23
Const FILES_COLUMNCNT
=23
Const
ORDER BY
Const
Const
Const

SQL_FILETABLE = "SELECT * FROM `_TransformView` WHERE `Table` = 'File'

`Row`"
SQL_PATCHTRANSFORMS = "SELECT `Name` FROM `_Storages` ORDER BY `Name`"
INSTALLSTATE_ASSEMBLY = 6
WAITTIME = 500

' Loop all products

If fCScript AND NOT fQuiet Then wscript.echo vbTab & "File version scan"
For iPosMaster = 0 To UBound(arrMaster)
If (arrMaster(iPosMaster,COL_ISOFFICEPRODUCT) OR fListNonOfficeProducts)
AND (arrMaster(iPosMaster,COL_CONTEXT)=MSIINSTALLCONTEXT_MACHINE) Then
' Cache ProductCode
sProductCode = "" : sProductCode = arrMaster(iPosMaster,COL_PRODUCTC
ODE)
If fCScript AND NOT fQuiet Then wscript.echo vbTab & sProductCode
' Reset Files array
iPosArr = -1
iArrMaxCnt = 5000
ReDim arrFiles(FILES_COLUMNCNT,iArrMaxCnt)
iBaseRefCnt = 0
For iFoo = 1 To 1
' Add fields from msi base
' -----------------------' Connect to the local .msi file for reading
Err.Clear
Set MsiDb = oMsi.OpenDatabase(arrMaster(iPosMaster,COL_CACHEDMSI
),MSIOPENDATABASEMODE_READONLY)
If Not Err = 0 Then
Exit For
End If 'Err = 0
' Check which tables exist in the current .msi
sTables = ""
Set ViewTables = MsiDb.OpenView("SELECT `Name` FROM `_Tables` OR
DER BY `Name`")
ViewTables.Execute
Do
Set Table = ViewTables.Fetch
If Table Is Nothing then Exit Do
sTables = sTables & Table.StringData(1) & ","
If Not Err = 0 Then Exit Do
Loop
ViewTables.Close
arrTables = Split(RTrimComma(sTables),",")
' Build an assembly reference dictionary
Set dicAssembly = Nothing
Set dicAssembly = CreateObject("Scripting.Dictionary")
If InStr(sTables,"MsiAssembly,")>0 Then
sQueryAssembly = "SELECT DISTINCT `Component_` FROM MsiAssem
bly"
Set qViewAssembly = MsiDb.OpenView(sQueryAssembly)
qViewAssembly.Execute
' If the MsiAssmbly table does not exist it returns an error
If Not Err = 0 Then Err.Clear
Set Record = qViewAssembly.Fetch
' must not enter the loop in case of an error!
If Not Err = 0 Then
Err.Clear
Else
Do Until Record Is Nothing
If Not dicAssembly.Exists(Record.StringData(1)) Then
dicAssembly.Add Record.StringData(1),Record.Stri
ngData(1)
End If
Set Record = qViewAssembly.Fetch
Loop
End If 'Not Err = 0

qViewAssembly.Close
End If 'InStr(sTables,"MsiAssembly")>0
If InStr(sTables,"SxsMsmGenComponents,")>0 Then
sQueryAssembly = "SELECT DISTINCT `Component_` FROM SxsMsmGe
nComponents"
Set qViewAssembly = MsiDb.OpenView(sQueryAssembly)
qViewAssembly.Execute
' If the MsiAssmbly table does not exist it returns an error
If Not Err = 0 Then Err.Clear
Set Record = qViewAssembly.Fetch
' must not enter the loop in case of an error!
If Not Err = 0 Then
Err.Clear
Else
Do Until Record Is Nothing
If Not dicAssembly.Exists(Record.StringData(1)) Then
dicAssembly.Add Record.StringData(1),Record.Stri
ngData(1)
End If
Set Record = qViewAssembly.Fetch
Loop
End If 'Not Err = 0
qViewAssembly.Close
End If 'InStr(sTables,"MsiAssembly")>0
' Build directory reference
Set SessionDir = Nothing
oMsi.UILevel = 2 'None
Set SessionDir = oMsi.OpenProduct(sProductCode)
SessionDir.DoAction("CostInitialize")
SessionDir.DoAction("FileCost")
SessionDir.DoAction("CostFinalize")
Set dicFolders = Nothing
Set dicFolders = CreateObject("Scripting.Dictionary")
Err.Clear
Set SessionDb = SessionDir.Database
sQueryDir = "SELECT DISTINCT `Directory` FROM Directory"
Set qViewDir = SessionDb.OpenView(sQueryDir)
qViewDir.Execute
Set Record = qViewDir.Fetch
' must not enter the loop in case of an error!
If Not Err = 0 Then
Err.Clear
Else
Do Until Record Is Nothing
If Not dicFolders.Exists(Record.Stringdata(1)) Then
sTargetPath = "" : sTargetPath = SessionDir.TargetPa
th(Record.Stringdata(1))
If NOT sTargetPath = "" Then dicFolders.Add Record.S
tringdata(1), sTargetPath
End If
Set Record = qViewDir.Fetch
Loop
End If 'Not Err = 0
qViewDir.Close
' .msi file inventory
' ------------------sQueryFT = "SELECT * FROM File"

Set qViewFT = MsiDb.OpenView(sQueryFT)

qViewFT.Execute
Set Record = qViewFT.Fetch()
Do Until Record Is Nothing
' Next Row in Array
' ----------------iPosArr = iPosArr + 1
iBaseRefCnt = iPosArr
If iPosArr > iArrMaxCnt Then
' increase array row buffer
iArrMaxCnt = iArrMaxCnt + 1000
ReDim Preserve arrFiles(FILES_COLUMNCNT,iArrMaxCnt)
End If 'iPosArr > iArrMaxCnt
' add FTK name
arrFiles(FILES_FTK,iPosArr) = Record.StringData(1)
' the FilesSource flag allows to filter the data in the report t
o exclude patch only entries.
arrFiles(FILES_SOURCE,iPosArr) = "Msi"
' default IsPatched field to 'False'
arrFiles(FILES_ISPATCHED,iPosArr) = False
' add the LFN (long filename)
arrFiles(FILES_FILE,iPosArr) = GetLongFileName(Record.String
Data(3))
' add ComponentName
arrFiles(FILES_COMPONENTNAME,iPosArr) = Record.StringData(2)
' add ComponentID and Directory reference from Component table
sQueryCompID = "SELECT `Component`,`ComponentId`,`Directory_
` FROM Component WHERE `Component` = '" & Record.StringData(2) &"'"
Set qViewCompID = MsiDb.OpenView(sQueryCompID)
qViewCompID.Execute
Set Record2 = qViewCompID.Fetch()
arrFiles(FILES_COMPONENTID,iPosArr) = Record2.StringData(2)
arrFiles(FILES_DIRECTORY,iPosArr) = Record2.StringData(3)
Set Record2 = Nothing
qViewCompID.Close
Set qViewCompID = Nothing
' ComponentState
arrFiles(FILES_COMPONENTSTATE,iPosArr) = GetComponentState(s
ProductCode,arrFiles(FILES_COMPONENTID,iPosArr),iPosMaster)
' add ComponentClients
arrFiles(FILES_COMPONENTCLIENTS,iPosArr) = GetComponentClien
ts(arrFiles(FILES_COMPONENTID,iPosArr),arrFiles(FILES_COMPONENTSTATE,iPosArr))
' add Features that use the component
sQueryFC = "SELECT * FROM FeatureComponents WHERE `Component
_` = '" & Record.StringData(2) &"'"
Set qViewFC = MsiDb.OpenView(sQueryFC)
qViewFC.Execute
Set Record2 = qViewFC.Fetch()
Do Until Record2 Is Nothing
arrFiles(FILES_FEATURENAMES,iPosArr) = arrFiles(FILES_FE
ATURENAMES,iPosArr) & Record2.StringData(1) & _
"("&TranslateFeat
ureState(oMsi.FeatureState(sProductCode,Record2.StringData(1)))&")"& ","
Set Record2 = qViewFC.Fetch()
Loop
RTrimComma arrFiles(FILES_FEATURENAMES,iPosArr)
' add KeyPath
arrFiles(FILES_KEYPATH, iPosArr) = GetComponentPath(sProduct
Code, arrFiles(FILES_COMPONENTID, iPosArr), arrFiles(FILES_COMPONENTSTATE, iPosA
rr))

sPath = "" : sName = ""

' add Componentpath
If dicAssembly.Exists(arrFiles(FILES_COMPONENTNAME,iPosArr))
Then
' Assembly
If arrFiles(FILES_COMPONENTSTATE,iPosArr) = INSTALLSTATE
_LOCAL Then
sPath = GetAssemblyPath(arrFiles(FILES_FILE,iPosArr)
,arrFiles(FILES_KEYPATH,iPosArr),dicFolders.Item(arrFiles(FILES_DIRECTORY,iPosAr
r)))
arrFiles(FILES_FOLDER,iPosArr) = Left(sPath,InStrRev
(sPath,"\"))
Else
arrFiles(FILES_FOLDER,iPosArr) = sPath
End If
Else
' Regular component
arrFiles(FILES_FOLDER, iPosArr) = dicFolders.Item(arrFil
es(FILES_DIRECTORY, iPosArr))
If arrFiles(FILES_FOLDER, iPosArr) = "" Then
' failed to obtain the directory from the session ob
ject
' try again by direct read from session object
arrFiles(FILES_FOLDER, iPosArr) = SessionDir.TargetP
ath(arrFiles(FILES_DIRECTORY, iPosArr))
' if still failed, fall back to the keypath by using
the assembly logic to resolve the path
If arrFiles(FILES_FOLDER, iPosArr) = "" AND arrFiles
(FILES_COMPONENTSTATE, iPosArr) = INSTALLSTATE_LOCAL Then
sPath = GetAssemblyPath(arrFiles(FILES_FILE, iPo
sArr), arrFiles(FILES_KEYPATH,iPosArr), dicFolders.Item(arrFiles(FILES_DIRECTORY
,iPosArr)))
arrFiles(FILES_FOLDER,iPosArr) = Left(sPath,InSt
rRev(sPath,"\"))
End If
End If
End If
' add file FullName - if sPath contains a string then it's the r
esult of the assembly detection
If sPath = "" Then
arrFiles(FILES_FULLNAME,iPosArr) = GetFileFullName(arrFi
les(FILES_COMPONENTSTATE,iPosArr),arrFiles(FILES_FOLDER,iPosArr),arrFiles(FILES_
FILE,iPosArr))
Else
arrFiles(FILES_FULLNAME,iPosArr) = sPath
sName = Right(sPath,Len(sPath)-InStrRev(sPath,"\"))
'Update the files field
If Not UCase(sName) = UCase(arrFiles(FILES_FILE,iPosArr)
) Then _
arrFiles(FILES_FILE,iPosArr) = sName '& " ("&arrFile
s(FILES_FILE,iPosArr)&")"
End If
' add (msi) BaseVersion
If Not Err = 0 Then Err.Clear
arrFiles(FILES_BASEVERSION,iPosArr) = Record.StringData(5)
' add FileState and FileVersion
arrFiles(FILES_FILESTATUS,iPosArr) = GetFileState(arrFiles(F
ILES_COMPONENTSTATE,iPosArr),arrFiles(FILES_FULLNAME,iPosArr))
arrFiles(FILES_CURRENTVERSION,iPosArr) = GetFileVersion(arrF

iles(FILES_COMPONENTSTATE,iPosArr),arrFiles(FILES_FULLNAME,iPosArr))
' add Language
arrFiles(FILES_LANGUAGE,iPosArr) = Record.StringData(6)
' get next row
Set Record = qViewFT.Fetch()
Loop
Set Record = Nothing
qViewFT.Close
Set qViewFT = Nothing
'
'
'
'

-------------Add patches '

-------------loop through all patches for the current product
For iPosPatch = 0 to UBound(arrPatch,3)
If Not (IsEmpty (arrPatch(iPosMaster,PATCH_PATCHCODE,iPosPat
ch))) AND (arrPatch(iPosMaster,PATCH_CSP,iPosPatch) = True) Then
Err.Clear
sPatchCode = arrPatch(iPosMaster,PATCH_PATCHCODE,iPosPat
ch)
Set MspDb = oMsi.OpenDatabase(arrPatch(iPosMaster,PATCH_
LOCALPACKAGE,iPosPatch),MSIOPENDATABASEMODE_PATCHFILE)
If Err = 0 Then
' create the table structures from .msi schema to allow
detailed query of the .msp _TransformView
For Each tbl in arrTables
sSqlCreateTable = "CREATE TABLE `" & tbl &"` ("
& GetTableColumnDef(MsiDb,tbl) & " PRIMARY KEY " & GetPrimaryTableKeys(MsiDb,tbl
) &")"
MspDb.OpenView(sSqlCreateTable).Execute
Next 'tbl
' check if a PatchTransform is available
sMst = "" : bMstApplied = False
sMst = arrPatch(iPosMaster,PATCH_TRANSFORM,iPosPatch
)
Err.Clear
If InStr(sMst,";")>0 Then
bMstApplied = True
sMst = Left(sMst,InStr(sMst,";")-1)
' apply the patch transform
' msiTransformErrorAll includes msiTransformErrorVie
wTransform which creates the "_TransformView" table
MspDb.ApplyTransform sMst,MSITRANSFORMERROR_ALL
End If 'InStr(sMst,";")>0
' if no known .mst or failed to apply the .mst we go int
o generic patch embedded transform detection loop
If (Not bMstApplied) OR (Not Err = 0) Then
Err.Clear
' Dictionary object for the patch transforms
Set dicTransforms = CreateObject("Scripting.Dict
ionary")
' create the view to retrieve the patch transforms
sQueryMst = SQL_PATCHTRANSFORMS
Set qViewMst = MspDb.OpenView(sQueryMst): qViewM
st.Execute
Set Record = qViewMst.Fetch
' loop all transforms and add them to the dictionary
Do Until Record Is Nothing
sMst = Record.StringData(1)
dicTransforms.Add sMst,sMst

Set Record = qViewMst.Fetch

Loop
qViewMst.Close : Set qViewMst = Nothing
Set Record = Nothing
' apply the patch transforms
dicKeys = dicTransforms.Keys
For iMst = 0 To dicTransforms.Count - 1
' get the transform name
sMst = dicKeys(iMst)
' apply the patch transform / staple them all on
the table
MspDb.ApplyTransform ":" & sMst,MSITRANSFORM
ERROR_ALL
If Not Err = 0 Then Err.Clear
Next 'iMst
End If '(Not bMstApplied) OR (Not Err = 0)
' _TransformView loop
' ------------------' update the MsiAssembly reference dictionary
Err.Clear
If InStr(sTables,"MsiAssembly,")>0 Then
Set qViewMsiAssembly = MspDb.OpenView("SELECT *
FROM `_TransformView` WHERE `Table`='MsiAssembly' ORDER By `Row`")
qViewMsiAssembly.Execute()
Set Record = qViewMsiAssembly.Fetch()
Do
If Record Is Nothing Then Exit Do
If Not Err = 0 Then
Err.Clear
Exit Do
End If
If Record.StringData(2) = "INSERT" Then
If Not dicAssembly.Exists(Record.StringD
ata(3)) Then dicAssembly.Add Record.StringData(3),Record.StringData(3)
End If
Set Record = qViewMsiAssembly.Fetch()
Loop
qViewMsiAssembly.Close
End If
Set Record = Nothing
If InStr(sTables,"SxsMsmGenComponents,")>0 Then
Set qViewMsiAssembly = MspDb.OpenView("SELECT *
FROM `_TransformView` WHERE `Table`='SxsMsmGenComponents' ORDER By `Row`")
qViewMsiAssembly.Execute()
Set Record = qViewMsiAssembly.Fetch()
Do
If Record Is Nothing Then Exit Do
If Not Err = 0 Then
Err.Clear
Exit Do
End If
If Record.StringData(2) = "INSERT" Then
If Not dicAssembly.Exists(Record.StringD
ata(3)) Then dicAssembly.Add Record.StringData(3),Record.StringData(3)
End If
Set Record = qViewMsiAssembly.Fetch()
Loop
qViewMsiAssembly.Close

End If
Set Record = Nothing
' get the files being modified from the "_TransformView"
'File' table
Set qViewMst = MspDb.OpenView(SQL_FILETABLE) : qView
Mst.Execute()
' loop all of the entries in the File table from "_Trans
formView"
Set Record = qViewMst.Fetch()
' initial defaults
sFtk = ""
bFtkViewComplete = True
bFtkInScope = False
Do
' is this the next FTK?
If (Not sFtk = Record.StringData(3)) OR (Record
Is Nothing) Then
If Record Is Nothing Then Err.Clear
' yes this is the next FTK or the last time befo
re exit of the loop
' is previous FTK handling complete?
If Not bFtkViewComplete Then
' previous FTK handling is not complete
' is previous FTK in scope?
If bFtkInScope AND NOT bFtkForceOutOfSco
pe Then
'FTK is in scope - reset the scope flag
bFtkInScope = False
If bBaseRefFound Then
' update base entry fields with patc
h information
' check if the filename got updated
If bFileNameChanged Then
arrFiles(FILES_FILE,iPosArr)
= GetLongFileName(arrFiles(FILES_FILE,iPosArr))
' the filename got changed by a
patch
' if the patch is in the 'Applie
d' state -> care about this change
If LCase(arrFiles(FILES_PATC
HSTATE,iPosArr)) = "applied" Then
' update the filename in the
baseref if this is (NOT Assembly) OR (broken)
If NOT(dicAssembly.Exist
s(arrFiles(FILES_COMPONENTNAME,iPosArr))) OR (arrFiles(FILES_FILESTATUS,iPosArr)
= INSTALLSTATE_BROKEN) Then
' correct the baseref fi
lename field
arrFiles(FILES_FILE,
iCnt) = arrFiles(FILES_FILE,iPosArr)
' File FullName
arrFiles(FILES_FULLN
AME,iPosArr) = GetFileFullName(arrFiles(FILES_COMPONENTSTATE,iPosArr),arrFiles(F
ILES_FOLDER,iPosArr),arrFiles(FILES_FILE,iPosArr))
' recheck the filestate
arrFiles(FILES_FILES
TATUS,iPosArr) = GetFileState(arrFiles(FILES_COMPONENTSTATE,iPosArr),arrFiles(FI
LES_FULLNAME,iPosArr))
arrFiles(FILES_FILES
TATUS,iCnt) = arrFiles(FILES_FILESTATUS,iPosArr)

' recheck the version

arrFiles(FILES_CURRE
NTVERSION,iPosArr) = GetFileVersion(arrFiles(FILES_COMPONENTSTATE,iPosArr),arrFi
les(FILES_FULLNAME,iPosArr))
arrFiles(FILES_CURRE
NTVERSION,iCnt) = arrFiles(FILES_CURRENTVERSION,iPosArr)
End If
End If 'applied
End If 'bFileNameChanged
' set IsPatched flag
arrFiles(FILES_ISPATCHED,iCnt) =
True
' check if PatchVersion field needs
to be updated
iCmp = 2 : sCmp = ""
iCmp = CompareVersion(arrFiles(F
ILES_PATCHVERSION,iPosArr),arrFiles(FILES_PATCHVERSION,iCnt),True)
Select Case iCmp
Case VERSIONCOMPARE_LOWER ': s
Cmp="ERROR_VersionLow"
Case VERSIONCOMPARE_MATCH ': s
Cmp="SUCCESS_VersionMatch"
Case VERSIONCOMPARE_HIGHER ': s
Cmp="SUCCESS_VersionHigh"
' update the base field
arrFiles(FILES_PATCHVERSION,
iCnt) = arrFiles(FILES_PATCHVERSION,iPosArr)
Case VERSIONCOMPARE_INVALID ': s
Cmp=""
End Select
' update PatchCode field
arrFiles(FILES_PATCHCODE,iCnt) =
arrFiles(FILES_PATCHCODE,iCnt) & sPatchCode&","
' update PatchKB field
If dicMspIndex.Exists(sPatchCode
) Then arrFiles(FILES_PATCHKB,iCnt) = arrFiles(FILES_PATCHKB,iCnt) & arrFiles(FI
LES_PATCHKB,iPosArr) &","
' update PatchMoreInfo field
arrFiles(FILES_PATCHMOREINFO,iCn
t) = arrFiles(FILES_PATCHMOREINFO,iCnt) & arrPatch(iPosMaster,PATCH_MOREINFOURL,
iPosPatch)&","
Else
' bBaseRefFound is False.
' ----------------------' this is a new file introduced with
the patch. set FileSource flag
arrFiles(FILES_SOURCE,iPosArr) =
"Msp"
' define IsPatched field
arrFiles(FILES_ISPATCHED,iPosArr
) = False
' add the LFN (long file name)
arrFiles(FILES_FILE,iPosArr) = G
etLongFileName(arrFiles(FILES_FILE,iPosArr))
' locate the ComponentId from Compon
ent table
sQueryCompID = "SELECT `Componen
t`,`ComponentId`,Directory_` FROM Component WHERE `Component` = '" & arrFiles(FIL
ES_COMPONENTNAME,iPosArr) &"'"
Set qViewCompID = MsiDb.OpenView

(sQueryCompID)
If Not Err = 0 Then
Err.Clear
Set Record2 = Nothing
Else
qViewCompID.Execute
Set Record2 = qViewCompID.Fe
tch()
End If
If Not Record2 Is Nothing Then
' found the ComponentId
' this is a new file added to an
existing component
arrFiles(FILES_COMPONENTID,i
PosArr) = Record2.StringData(2)
' add the Directory_ reference
arrFiles(FILES_DIRECTORY,iPo
sArr) = Record2.StringData(3)
Set Record2 = Nothing
qViewCompID.Close
Set qViewCompID = Nothing
Else
' did not find the ComponentId i
n the base .msi
' this is a new file AND a new c
omponent -> need to query the .msp for details
Set qViewMspCompId = MspDb.O
penView("SELECT * FROM `_TransformView` WHERE `Table`='Component' ORDER BY `Row`
")
qViewMspCompID.Execute
Do
Set Record3 = qViewMspCo
mpId.Fetch()
If Record3 Is Nothing Th
en Exit Do
If Record3.StringData(3)
= arrFiles(FILES_COMPONENTNAME,iPosArr) Then
If Record3.StringDat
a(2) = "ComponentId" Then
arrFiles(FILES_C
OMPONENTID,iPosArr) = Record3.StringData(4)
ElseIf Record3.Strin
gData(2) = "Directory_" Then
arrFiles(FILES_D
IRECTORY,iPosArr) = Record3.StringData(4)
End If
End If
Loop
qViewMspCompID.Close
If arrFiles(FILES_COMPONENTI
D,iPosArr)="" Then bFtkForceOutOfScope = True
End If 'Not Record2 Is Nothing
' all other logic is only needed if
in scope
If Not bFtkForceOutOfScope Then
' ensure the directory reference
exists
If Not dicFolders.Exists(arr
Files(FILES_DIRECTORY,iPosArr)) Then
If SessionDir Is Nothing

Then
' try to recover lost Se
ssionDir object
Set SessionDir = oMs
i.OpenProduct(sProductCode)
SessionDir.DoAction(
"CostInitialize")
SessionDir.DoAction(
"FileCost")
SessionDir.DoAction(
"CostFinalize")
End If
dicFolders.Add arrFiles(
FILES_DIRECTORY,iPosArr),SessionDir.TargetPath(arrFiles(FILES_DIRECTORY,iPosArr)
)
If Not Err = 0 Then
Err.Clear
' still failed to identi
fy the path - get rid of this entry
bNeedKeyPathFallback
= True
End If
End If
' ComponentState
arrFiles(FILES_COMPONENTSTAT
E,iPosArr) = GetComponentState(sProductCode,arrFiles(FILES_COMPONENTID,iPosArr),
iPosMaster)
' add ComponentClients
arrFiles(FILES_COMPONENTCLIE
NTS,iPosArr) = GetComponentClients(arrFiles(FILES_COMPONENTID,iPosArr),arrFiles(
FILES_COMPONENTSTATE,iPosArr))
' add Features that use the comp
onent
Set qViewMspFC = MspDb.OpenV
iew("SELECT * FROM `_TransformView` WHERE `Table`='FeatureComponents' ORDER BY `
Row`")
qViewMspFC.Execute
Set Record2 = qViewMspFC.Fet
ch()
Do
Set Record2 = qViewMspFC
.Fetch()
If Record2 Is Nothing Th
en Exit Do
If Record2.StringData(4)
= arrFiles(FILES_COMPONENTNAME,iPosArr) Then
If Record2.StringDat
a(2) = "Feature_" Then
arrFiles(FILES_F
EATURENAMES,iPosArr) = arrFiles(FILES_FEATURENAMES,iPosArr)&Record2.StringData(3
)& _
"("&TranslateFea
tureState(oMsi.FeatureState(sProductCode,Record2.StringData(3)))&")"& ","
End If
End If
Loop
qViewMspFC.Close
Set Record2 = Nothing
RTrimComma arrFiles(FILES_FE
ATURENAMES,iPosArr)

' add KeyPath

arrFiles(FILES_KEYPATH,iPosA
rr) = GetComponentPath(sProductCode,arrFiles(FILES_COMPONENTID,iPosArr),arrFiles
(FILES_COMPONENTSTATE,iPosArr))
' add Componentpath
sPath = "" : sName = ""
If dicAssembly.Exists(arrFil
es(FILES_COMPONENTNAME,iPosArr)) Then
' Assembly
If arrFiles(FILES_COMPON
ENTSTATE,iPosArr) = INSTALLSTATE_LOCAL Then
sPath = GetAssemblyP
ath(arrFiles(FILES_FILE,iPosArr),arrFiles(FILES_KEYPATH,iPosArr),dicFolders.Item
(arrFiles(FILES_DIRECTORY,iPosArr)))
arrFiles(FILES_FOLDE
R,iPosArr) = Left(sPath,InStrRev(sPath,"\"))
sName = Right(sPath,
Len(sPath)-InStrRev(sPath,"\"))
' update the files field
to ensure the correct value
If Not UCase(sName)
= UCase(arrFiles(FILES_FILE,iPosArr)) Then _
arrFiles(FILES_F
ILE,iPosArr) = sName '& " ("&arrFiles(FILES_FILE,iPosArr)&")"
Else
arrFiles(FILES_FOLDE
R,iPosArr) = sPath
End If
Else
' Regular component
If bNeedKeyPathFallback
Then
arrFiles(FILES_FOLDE
R,iPosArr) = Left(arrFiles(FILES_KEYPATH,iPosArr),InStrRev(arrFiles(FILES_KEYPAT
H,iPosArr),"\"))
Else
arrFiles(FILES_FOLDE
R,iPosArr) = dicFolders.Item(arrFiles(FILES_DIRECTORY,iPosArr))
End If
End If
' add file FullName
' if sPath contains a string the
n it's the result of the assembly detection
If sPath = "" Then
arrFiles(FILES_FULLNAME,
iPosArr) = GetFileFullName(arrFiles(FILES_COMPONENTSTATE,iPosArr),arrFiles(FILES
_FOLDER,iPosArr),arrFiles(FILES_FILE,iPosArr))
Else
arrFiles(FILES_FULLNAME,
iPosArr) = arrFiles(FILES_FOLDER,iPosArr)&arrFiles(FILES_FILE,iPosArr)
End If
' add FileState and FileVersion
arrFiles(FILES_FILESTATUS,iP
osArr) = GetFileState(arrFiles(FILES_COMPONENTSTATE,iPosArr),arrFiles(FILES_FULL
NAME,iPosArr))
arrFiles(FILES_CURRENTVERSIO
N,iPosArr) = GetFileVersion(arrFiles(FILES_COMPONENTSTATE,iPosArr),arrFiles(FILE
S_FULLNAME,iPosArr))
End If
End If 'bBaseRefFound

Else
' No - FTK not in scope
bFtkForceOutOfScope = False
' delete all row contents
For iColCnt = 0 To FILES_COLUMNCNT
arrFiles(iColCnt,iPosArr) = ""
Next 'iColCnt
' decrease array counter
iPosArr = iPosArr - 1
End If 'bFtkInScope
If bFtkForceOutOfScope Then
' delete all row contents
For iColCnt = 0 To FILES_COLUMNCNT
arrFiles(iColCnt,iPosArr) = ""
Next 'iColCnt
' decrease array counter
iPosArr = iPosArr - 1
End If
End If 'bFtkViewComplete
bFtkViewComplete = True
' Previous FTK handling is now complete
' ------------------------------------If Record Is Nothing Then Exit Do
' Init new FTK row
' ---------------' increase array pointer
iPosArr = iPosArr + 1
bFtkViewComplete = False
bFtkInScope = False
bFtkForceOutOfScope = False
bInsert = False
bFileNameChanged = False
If iPosArr > iArrMaxCnt Then
' add more rows to array
iArrMaxCnt = iArrMaxCnt + 1000
ReDim Preserve arrFiles(FILES_COLUMNCNT,
iArrMaxCnt)
End If 'iPosArr > iArrMaxCnt
' update current FTK cache reference
sFtk = Record.StringData(3)
' locate the FTK reference from msi base
bBaseRefFound = False
For iCnt = 0 To iBaseRefCnt
If arrFiles(FILES_FTK,iCnt) = sFtk Then
bBaseRefFound = True
' copy known fields from Base version if
applicable
If bBaseRefFound Then
For iColCnt = 0 To FILES_COLUMNC
NT
arrFiles(iColCnt,iPosArr) =
arrFiles(iColCnt,iCnt)
Next 'iColCnt
bFtkInScope = True
End If 'bBaseRefFound
Exit For 'iCnt = 0 To UBound(arrFile
s,2)-1
End If 'arrFiles(FILES_FTK,iCnt) = sFtk

Then
Next 'iCnt
' add initial available data
' correct/ensure FTK name
arrFiles(FILES_FTK,iPosArr) = Record.StringD
ata(3)
' correct IsPatched field
arrFiles(FILES_ISPATCHED,iPosArr) = False
' correct/ensure FileSource
arrFiles(FILES_SOURCE,iPosArr) = "Msp"
' add fields from patch array
arrFiles(FILES_PATCHSTATE,iPosArr) = arrPatc
h(iPosMaster,PATCH_PATCHSTATE,iPosPatch)
arrFiles(FILES_PATCHCODE,iPosArr) = arrPatch
(iPosMaster,PATCH_PATCHCODE,iPosPatch)
arrFiles(FILES_PATCHMOREINFO,iPosArr) = arrP
atch(iPosMaster,PATCH_MOREINFOURL,iPosPatch)
' add KB reference
If dicMspIndex.Exists(sPatchCode) Then
iIndex = dicMspIndex.Item(sPatchCode)
arrFiles(FILES_PATCHKB,iPosArr) = arrMsp
Files(iIndex,MSPFILES_KB)
arrFiles(FILES_PATCHPACKAGE,iPosArr) = a
rrMspFiles(iIndex,MSPFILES_PACKAGE)
End If
' new FTK row init complete
End If 'Not sFtk = Record.StringData(3)
' add data from _TransformView
Select Case Record.StringData(2)
Case "File"
Case "FileSize"
Case "Component_"
arrFiles(FILES_COMPONENTNAME,iPosArr) = Reco
rd.StringData(4)
Case "CREATE"
Case "DELETE"
Case "DROP"
Case "FileName"
'Add the filename
bFileNameChanged = True
arrFiles(FILES_FILE,iPosArr) = Record.String
Data(4)
Case "Version"
' don't allow version field to contain alpha cha
racters
bAsc = True : sAscCheck = "" : sAscCheck = R
ecord.StringData(4)
If Len(sAscCheck)>0 Then
For iAscCnt = 1 To Len(sAscCheck)
iAsc = Asc(UCase(Mid(sAscCheck,iAscC
nt,1)))
If (iAsc>64) AND (iAsc<91) Then
bAsc = False
Exit For
End If
Next 'iCnt
End If 'Len(sAscCheck)>0
If bAsc Then arrFiles(FILES_PATCHVERSION,iPo
sArr) = Record.StringData(4)
Case "Language"

arrFiles(FILES_LANGUAGE,iPosArr) = Recor
d.StringData(4)
Case "Attributes"
Case "Sequence"
Case "INSERT"
' this is a new file added by the pach
bFtkInScope = True
bInsert = True
Case Else
End Select
' get the next record (column) from _TransformView
Set Record = qViewMst.Fetch()
Loop
' _TransformView analysis for this patch complete
' reset views
MspDb.OpenView("ALTER TABLE _TransformView FREE").Ex
ecute
MspDb.OpenView("DROP TABLE `File`").Execute
End If 'Err = 0
End If 'IsEmpty
Next 'iPosPatch
Next 'iFoo
' Final field & verb fixups
' ------------------------For iFile = 0 To iPosArr
' File VersionState translation
iCmp = 2 : sCmp = "" : sCurVer = ""
If arrFiles(FILES_ISPATCHED,iFile) OR (arrFiles(FILES_SOURCE,iFi
le)="Msp") Then
' compare actual file version to patch file version
sCurVer = arrFiles(FILES_PATCHVERSION,iFile)
Else
' compare actual file version to base file version
sCurVer = arrFiles(FILES_BASEVERSION,iFile)
End If 'arrFiles(FILES_ISPATCHED,iFile)
iCmp = CompareVersion(arrFiles(FILES_CURRENTVERSION,iFile),sCurV
er,False)
Select Case iCmp
Case VERSIONCOMPARE_LOWER
sCmp="ERROR_VersionLow"
' log error
Cachelog LOGPOS_REVITEM,LOGHEADING_NONE,ERR_CATEGORYERROR,ER
R_FILEVERSIONLOW & arrMaster(iPosMaster,COL_PRODUCTCODE) & DSV & _
arrMaster(iPosMaster,COL_PRODUCTNAME)
If Not InStr(arrMaster(iPosMaster,COL_ERROR),arrFiles(FILES_
FILE,iFile)&" expected: ")>0 Then
arrMaster(iPosMaster,COL_ERROR) = arrMaster(iPosMaster,C
OL_ERROR) & ERR_CATEGORYERROR & arrFiles(FILES_FILE,iFile) & " expected: "&sCurV
er& " found: " & arrFiles(FILES_CURRENTVERSION,iFile) & CSV
End If
Case VERSIONCOMPARE_MATCH : sCmp="SUCCESS_VersionMatch"
Case VERSIONCOMPARE_HIGHER : sCmp="SUCCESS_VersionHigh"
Case VERSIONCOMPARE_INVALID : sCmp=""
End Select
arrFiles(FILES_VERSIONSTATUS,iFile) = sCmp
' FileState translation
sCmp = ""
Select Case arrFiles(FILES_FILESTATUS,iFile)
Case INSTALLSTATE_LOCAL : sCmp = "OK_Local"

Case INSTALLSTATE_BROKEN
sCmp = "ERROR_Broken"
' log error
Cachelog LOGPOS_REVITEM,LOGHEADING_NONE,ERR_CATEGORYERROR,"P
roduct " & arrMaster(iPosMaster,COL_PRODUCTCODE) & DSV & _
arrMaster(iPosMaster,COL_PRODUCTNAME) & ": " & ERR_BADFILEST
ATE
If Not InStr(arrMaster(iPosMaster,COL_ERROR),arrFiles(FILES_
FILE,iFile)&" FileState: Broken")>0 Then
arrMaster(iPosMaster,COL_ERROR) = arrMaster(iPosMaster,C
OL_ERROR) & ERR_CATEGORYERROR & arrFiles(FILES_FILE,iFile) & " FileState: Broken
" & CSV
End If
Case INSTALLSTATE_UNKNOWN
sCmp = "Unknown"
If Not arrFiles(FILES_FEATURENAMES,iFile) = "" Then sCmp=Mid
(arrFiles(FILES_FEATURENAMES,iFile),InStrRev(arrFiles(FILES_FEATURENAMES,iFile),
"(")+1, Len(arrFiles(FILES_FEATURENAMES,iFile))-InStrRev(arrFiles(FILES_FEATUREN
AMES,iFile),"(")-1)
Case INSTALLSTATE_NOTUSED : sCmp = "NotUsed"
Case INSTALLSTATE_ASSEMBLY : sCmp = "Assembly"
Case Else
End Select
arrFiles(FILES_FILESTATUS,iFile) = sCmp
' ComponentState translation
sCmp = ""
Select Case arrFiles(FILES_COMPONENTSTATE,iFile)
Case INSTALLSTATE_LOCAL : sCmp = "Local"
Case INSTALLSTATE_BROKEN : sCmp = "Broken"
Case INSTALLSTATE_UNKNOWN : sCmp = "Unknown"
Case INSTALLSTATE_NOTUSED : sCmp = "NotUsed"
Case Else
End Select
arrFiles(FILES_COMPONENTSTATE,iFile) = sCmp
' PatchCode field trim
arrFiles(FILES_PATCHCODE,iFile) = RTrimComma(arrFiles(FILES_PATC
HCODE,iFile))
' PatchKB field trim
arrFiles(FILES_PATCHKB,iFile) = RTrimComma(arrFiles(FILES_PATCHK
B,iFile))
' PatchInfo field trim
arrFiles(FILES_PATCHMOREINFO,iFile) = RTrimComma(arrFiles(FILES_
PATCHMOREINFO,iFile))
Next 'iFile
' dump out the collected data to file
' create the AllOffice file
If IsEmpty(AllOfficeFiles) Then
If NOT oFso.FolderExists(sPathOutputFolder & "ROIScan") Then oFs
o.CreateFolder(sPathOutputFolder & "ROIScan")
Set AllOfficeFiles = oFso.CreateTextFile(sPathOutputFolder&"ROIS
can\"&sComputerName&"_OfficeAll_FileList.xml",True,True)
AllOfficeFiles.WriteLine "<?xml version=""1.0""?>"
AllOfficeFiles.WriteLine "<FILEDATA>"
End If
' individual products file
If NOT oFso.FolderExists(sPathOutputFolder & "ROIScan") Then oFso.Cr
eateFolder(sPathOutputFolder & "ROIScan")
Set FileStream = oFso.CreateTextFile(sPathOutputFolder&"ROIScan\"&sC
omputerName&"_"&sProductCode&"_FileList.xml",True,True)
FileStream.WriteLine "<?xml version=""1.0""?>"

FileStream.WriteLine "<FILEDATA>"
FileStream.WriteLine vbTab & "<PRODUCT ProductCode="""&sProductCode&
""" >"
If arrMaster(iPosMaster,COL_ISOFFICEPRODUCT) Then AllOfficeFiles.Wri
teLine vbTab & "<PRODUCT ProductCode="""&sProductCode&""" >"
For iFile = 0 To iPosArr
sXmlLine = ""
sXmlLine = vbTab & vbTab & "<FILE " & _
"FileName="&chr(34)&arrFiles(FILES_FI
LE,iFile)&chr(34)&" " & _
"FileState="&chr(34)&arrFiles(FILES_F
ILESTATUS,iFile)&chr(34)&" " & _
"VersionStatus="&chr(34)&arrFiles(FIL
ES_VERSIONSTATUS,iFile)&chr(34)&" " & _
"CurrentVersion="&chr(34)&arrFiles(FI
LES_CURRENTVERSION,iFile)&chr(34)&" " & _
"InitialVersion="&chr(34)&arrFiles(FI
LES_BASEVERSION,iFile)&chr(34)&" " & _
"PatchVersion="&chr(34)&arrFiles(FILE
S_PATCHVERSION,iFile)&chr(34)&" " & _
"FileSource="&chr(34)&arrFiles(FILES_
SOURCE,iFile)&chr(34)&" " & _
"IsPatched="&chr(34)&arrFiles(FILES_I
SPATCHED,iFile)&chr(34)&" " & _
"KB="&chr(34)&arrFiles(FILES_PATCHKB,
iFile)&chr(34)&" " & _
"Package="&chr(34)&arrFiles(FILES_PAT
CHPACKAGE,iFile)&chr(34)&" " & _
"PatchState="&chr(34)&arrFiles(FILES_
PATCHSTATE,iFile)&chr(34)&" " & _
"FolderName="&chr(34)&arrFiles(FILES_
FOLDER,iFile)&chr(34)&" " & _
"PatchCode="&chr(34)&arrFiles(FILES_P
ATCHCODE,iFile)&chr(34)&" " & _
"PatchInfo="&chr(34)&arrFiles(FILES_P
ATCHMOREINFO,iFile)&chr(34)&" " & _
"FtkName="&chr(34)&arrFiles(FILES_FTK
,iFile)&chr(34)&" " & _
"KeyPath="&chr(34)&arrFiles(FILES_KEY
PATH,iFile)&chr(34)&" " & _
"MsiDirectory="&chr(34)&arrFiles(FILE
S_DIRECTORY,iFile)&chr(34)&" " & _
"Language="&chr(34)&arrFiles(FILES_LA
NGUAGE,iFile)&chr(34)&" " & _
"ComponentState="&chr(34)&arrFiles(FI
LES_COMPONENTSTATE,iFile)&chr(34)&" " & _
"ComponentID="&chr(34)&arrFiles(FILES
_COMPONENTID,iFile)&chr(34)&" " & _
"ComponentName="&chr(34)&arrFiles(FIL
ES_COMPONENTNAME,iFile)&chr(34)&" " & _
"ComponentClients="&chr(34)&arrFiles(
FILES_COMPONENTCLIENTS,iFile)&chr(34)&" " & _
"FeatureReference="&chr(34)&arrFiles(
FILES_FEATURENAMES,iFile)&chr(34)&" " & _
" />"
If InStr(sXmlLine,"&")>0 Then sXmlLine = Replace(sXmlLine,"&","&
amp;")
FileStream.WriteLine sXmlLine
If arrMaster(iPosMaster,COL_ISOFFICEPRODUCT) Then AllOfficeFiles
.WriteLine sXmlLine

Next 'iFile
FileStream.WriteLine vbTab & "</PRODUCT>"
If arrMaster(iPosMaster,COL_ISOFFICEPRODUCT) Then AllOfficeFiles.Wri
teLine vbTab & "</PRODUCT>"
FileStream.WriteLine "</FILEDATA>"
FileStream.Close
Set FileStream = Nothing
End If 'arrMaster(iPosMaster,COL_ISOFFICEPRODUCT)
Next 'iPosMaster
' close the AllOffice file
If Not AllOfficeFiles Is Nothing Then
AllOfficeFiles.WriteLine "</FILEDATA>"
AllOfficeFiles.Close
Set AllOfficeFiles = Nothing
End if
' compress the files
Dim i,iWait
Dim FileScanFolder,FileVerScanZip,xmlFile,item,zipfile
Dim sDat,sDatCln
Dim fCopyComplete
If oFso.FileExists(sPathOutputFolder&sComputerName&"_ROIScan.zip") Then
' rename existing .zip container by appending a timestamp to prevent overwri
te.
Dim oRegExp
Set oRegExp = CreateObject("Vbscript.RegExp")
Set zipfile = oFso.GetFile(sPathOutputFolder&sComputerName&"_ROIScan.zip
")
oRegExp.Global = True
oRegExp.Pattern = "\D"
Err.Clear
zipfile.Name = sComputerName&"_ROIScan_" & oRegExp.Replace(zipfile.DateL
astModified, "") & ".zip"
If NOT Err = 0 Then
zipfile.Delete
Err.Clear
End If
End If
Set FileVerScanZip = oFso.OpenTextFile(sPathOutputFolder&sComputerName&"_ROI
Scan.zip",FOR_WRITING,True)
FileVerScanZip.write "PK" & chr(5) & chr(6) & String(18,chr(0))
FileVerScanZip.close
Set FileScanFolder = oFso.GetFolder(sPathOutputFolder&"ROIScan")
For Each xmlFile in FileScanFolder.Files
If Right(LCase(xmlFile.Name),4)=".xml" Then
If NOT fZipError Then CopyToZip ShellApp.NameSpace(sPathOutputFolder
&sComputerName&"_ROIScan.zip"), xmlFile
End If
Next 'xmlFile
If fCScript AND NOT fQuiet Then wscript.echo vbTab & "File version scan comp
lete"
End Sub 'FileInventory
'===============================================================================
========================
'Identify the InstallState of a component
Function GetComponentState(sProductCode,sComponentId,iPosMaster)
On Error Resume Next
Dim Product

Dim sPath
GetComponentState = INSTALLSTATE_UNKNOWN
If iWiVersionMajor > 2 Then
'WI 3.x or higher
Set Product = oMsi.Product(sProductCode,arrMaster(iPosMaster,COL_USERSID
),arrMaster(iPosMaster,COL_CONTEXT))
Err.Clear
GetComponentState = Product.ComponentState(sComponentId)
If Not Err = 0 Then
GetComponentState = INSTALLSTATE_UNKNOWN
Err.Clear
End If ' Err = 0
Else
'WI 2.x
If Not Err = 0 Then Err.Clear
sPath = ""
sPath = oMsi.ComponentPath(sProductCode,sComponentId)
If Not Err = 0 Then
GetComponentState = INSTALLSTATE_UNKNOWN
Err.Clear
Else
If oFso.FileExists(sPath) Then
GetComponentState = INSTALLSTATE_LOCAL
Else
GetComponentState = INSTALLSTATE_NOTUSED
End If 'oFso.FileExists(sPath)
End If 'Not Err = 0
End If 'iWiVersionMajor > 2
End Function 'GetComponentState
'===============================================================================
========================
'Get a list of client products that are registered to the component
Function GetComponentClients(sComponentId,iComponentState)
On Error Resume Next
Dim sClients,prod
sClients = ""
GetComponentClients = ""
If Not(iComponentState = INSTALLSTATE_UNKNOWN) Then
For Each prod in oMsi.ComponentClients(sComponentId)
If Not Err = 0 Then
Err.Clear
Exit For
End If 'Not Err = 0
sClients = sClients & prod & ","
Next 'prod
RTrimComma sClients
GetComponentClients = sClients
End If 'Not (arrFiles(FILES_COMPONENTSTATE,...
End Function 'GetComponentClients
'===============================================================================
========================
'Get the keypath value for the component
Function GetComponentPath(sProductCode,sComponentId,iComponentState)

On Error Resume Next

Dim sPath
sPath = ""
If iComponentState = INSTALLSTATE_LOCAL Then
sPath = oMsi.ComponentPath(sProductCode,sComponentId)
End If 'iComponentState = INSTALLSTATE_LOCAL
GetComponentPath = sPath
End Function 'GetComponentPath
'===============================================================================
========================
'Use WI ProvideAssembly function to identify the path for an assembly.
'Returns the path to the file if the file exists.
'Returns an empty string if file does not exist
Function GetAssemblyPath(sLfn,sKeyPath,sDir)
On Error Resume Next
Dim sFile,sFolder,sExt,sRoot,sName
Dim arrTmp
'Defaults
GetAssemblyPath=""
sFile="" : sFolder="" : sExt="" : sRoot="" : sName=""
'The componentpath should already point to the correct folder
'except for components with a registry keypath element.
'In that case tweak the directory folder to match
If Left(sKeyPath,1)="0" Then
sFolder = sDir
sFolder = oShell.ExpandEnvironmentStrings("%SYSTEMROOT%") & Mid(sFolder,
InStr(LCase(sFolder),"\winsxs\"))
sFile = sLfn
End If 'Left(sKeyPath,1)="0"
'Figure out the correct file reference
If sFolder = "" Then sFolder = Left(sKeyPath,InStrRev(sKeyPath,"\"))
sRoot = Left(sFolder,InStrRev(sFolder,"\",Len(sFolder)-1))
arrTmp = Split(sFolder,"\")
If CheckArray(arrTmp) Then sName = arrTmp(UBound(arrTmp)-1)
If sFile = "" Then sFile = Right(sKeyPath,Len(sKeyPath)-InStrRev(sKeyPath,"\
"))
If oFso.FileExists(sFolder&sLfn) Then
sFile = sLfn
Else
'Handle .cat, .manifest and .policy files
If InStr(sLfn,".")>0 Then
sExt = Mid(sLfn,InStrRev(sLfn,"."))
Select Case LCase(sExt)
Case ".cat"
sFile = Left(sFile,InStrRev(sFile,"."))&"cat"
If Not oFso.FileExists(sFolder&sFile) Then
'Check Manifest folder
If oFso.FileExists(sRoot&"Manifests\"&sName&".cat") Then
sFolder = sRoot&"Manifests\"

sFile = sName&".cat"
Else
If oFso.FileExists(sRoot&"Policies\"&sName&".cat") Then
sFolder = sRoot&"Policies\"
sFile = sName&".cat"
End If
End If
End If
Case ".manifest"
sFile = Left(sFile,InStrRev(sFile,"."))&"manifest"
If oFso.FileExists(sRoot&"Manifests\"&sName&".manifest") Then
sFolder = sRoot&"Manifests\"
sFile = sName&".manifest"
End If
Case ".policy"
If iVersionNT < 600 Then
sFile = Left(sFile,InStrRev(sFile,"."))&"policy"
If oFso.FileExists(sRoot&"Policies\"&sName&".policy") Then
sFolder = sRoot&"Policies\"
sFile = sName&".policy"
End If
Else
sFile = Left(sFile,InStrRev(sFile,"."))&"manifest"
If oFso.FileExists(sRoot&"Manifests\"&sName&".manifest") The
n
sFolder = sRoot&"Manifests\"
sFile = sName&".manifest"
End If
End If
Case Else
End Select
'Check if the file exists
If Not oFso.FileExists(sFolder&sFile) Then
'Ensure the right folder
End If
End If 'InStr(sFile,".")>0
End If
GetAssemblyPath = sFolder&sFile
End Function 'GetAssemblyPath
'===============================================================================
========================
'
Function GetFileFullName(iComponentState,sComponentPath,sFileName)
On Error Resume Next
Dim sFileFullName
sFileFullName = ""
If iComponentState = INSTALLSTATE_LOCAL Then
If Len(sComponentPath) > 2 Then sFileFullName = sComponentPath & sFileNa
me
End If 'iComponentState = INSTALLSTATE_LOCAL
GetFileFullName = sFileFullName
End Function 'GetFileFullName

'===============================================================================
========================
'
Function GetLongFileName(sMsiFileName)
On Error Resume Next
Dim sFileTmp
sFileTmp = ""
sFileTmp = sMsiFileName
If InStr(sFileTmp,"|") > 0 Then sFileTmp = Mid(sFileTmp,InStr(sFileTmp,"|")+
1,Len(sFileTmp))
GetLongFileName = sFileTmp
End Function 'GetLongFileName
'===============================================================================
========================
'
Function GetFileState(iComponentState,sFileFullName)
On Error Resume Next
GetFileState = INSTALLSTATE_UNKNOWN
If iComponentState = INSTALLSTATE_LOCAL Then
If oFso.FileExists(sFileFullName) Then
GetFileState = INSTALLSTATE_LOCAL
Else
GetFileState = INSTALLSTATE_BROKEN
End If 'oFso.FileExists(sFileFullName)
Else
If oFso.FileExists(sFileFullName) Then
'This should not happen!
GetFileState = INSTALLSTATE_LOCAL
Else
GetFileState = iComponentState
End If 'oFso.FileExists(sFileFullName)
End If 'iComponentState = INSTALLSTATE_LOCAL
End Function 'GetFileState
'===============================================================================
========================
'
Function GetFileVersion(iComponentState,sFileFullName)
On Error Resume Next
GetFileVersion = ""
If iComponentState = INSTALLSTATE_LOCAL Then
If oFso.FileExists(sFileFullName) Then
GetFileVersion = oFso.GetFileVersion(sFileFullName)
End If 'oFso.FileExists(sFileFullName)
Else
If oFso.FileExists(sFileFullName) Then
'This should not happen!
GetFileVersion = oFso.GetFileVersion(sFileFullName)
End If 'oFso.FileExists(sFileFullName)
End If 'iComponentState = INSTALLSTATE_LOCAL

End Function 'GetFileVersion

'===============================================================================
========================
'===============================================================================
========================
'Module FeatureStates
'===============================================================================
========================
'Builds a FeatureTree indicating the FeatureStates
Sub FindFeatureStates
If fBasicMode Then Exit Sub
On Error Resume Next
Const ADVARCHAR
= 200
Const MAXCHARACTERS = 255
Dim
Dim
Dim
Dim

Features,oRecordSet,oDicLevel,oDicParent
sProductCode,sFeature,sFTree,sFParent,sLeft,sRight
iFoo,iPosMaster,iMaxNestLevel,iNestLevel,iLevel,iFCnt,iLeft,iStart
arrFName,arrFLevel,arrFParent

'ReDim the global feature array

ReDim arrFeature(UBound(arrMaster),FEATURE_COLUMNCOUNT)
'Outer loop to iterate through all products
For iPosMaster=0 To UBound(arrFeature)
iFoo=0
sFTree=""
'Dummy Loop to allow exit out in case of an error
Do While iFoo=0
iFoo=1
'Get the ProductCode for this loop
sProductCode = arrMaster(iPosMaster,COL_PRODUCTCODE)
'Get the Features colection for this product
'oMsi.Features is only valid for installed per-machine or current us
er products.
'The call will fail for advertised and other user products.
Set Features = oMsi.Features(sProductCode)
If Not Err=0 Then
Err.Clear
Exit Do
End If 'Not Err = 0
'Create the dictionary objects
Set oDicLevel = CreateObject("Scripting.Dictionary")
Set oDicParent = CreateObject("Scripting.Dictionary")
'Prepare a recordset to allow sorting of the root features
Set oRecordSet = CreateObject("ADOR.Recordset")
oRecordSet.Fields.Append "FeatureName",ADVARCHAR,MAXCHARACTERS
oRecordSet.Open
If Not Err=0 Then
Err.Clear
Exit Do
End If 'Not Err = 0
iMaxNestLevel=0
'Inner loop # 1 to identify all features

For Each sFeature in Features

'Reset the nested level counter
iNestLevel=-1
'Check for & cache parent feature
sFParent = oMsi.FeatureParent(sProductCode,sFeature)
If sFParent="" Then
'Found a root feature.
iNestLevel=0
'Add to recordset for later sorting
oRecordSet.AddNew
oRecordSet("FeatureName")=TEXTINDENT&sFeature&" ("&Translate
FeatureState(oMsi.FeatureState(sProductCode,sFeature))&")"
oRecordSet.Update
Else
'Call the recursive function to get the nest level of the cu
rrent feature
iNestLevel=GetFeatureNestLevel(sProductCode,sFeature,iNestLe
vel)
'Add to dictionary arrays
oDicLevel.Add sFeature,iNestLevel
oDicParent.Add sFeature,sFParent
End If 'sFParent=""
'Max nest level is required for second inner loop
If iNestLevel>iMaxNestLevel Then iMaxNestLevel=iNestLevel
Next 'sFeature
'First inner loop complete. Sort the root features
oRecordSet.Sort="FeatureName"
oRecordSet.MoveFirst
'Write the sorted root features to the 'treeview' string
Do Until oRecordSet.EOF
sFTree=sFTree&oRecordSet.Fields.Item("FeatureName")&vbCrLf
oRecordSet.MoveNext
Loop 'oRecordSet.EOF
'Copy dic's
arrFName =
arrFLevel =
arrFParent=

to array
oDicLevel.Keys
oDicLevel.Items
oDicParent.Items

'2nd inner loop to add the features to the 'treeview' string

For iLevel = 1 To iMaxNestLevel
For iFCnt = 0 To UBound(arrFName)
If arrFLevel(iFCnt)=iLevel Then
iStart = InStr(sFTree,arrFParent(iFCnt)&" (")+Len(arrFPa
rent(iFCnt))
iLeft = InStr(iStart,sFTree,")")+2
sLeft = Left(sFTree,iLeft)
sRight = Right(sFTree,Len(sFTree)-iLeft)
sFTree = sLeft& TEXTINDENT&FeatureIndent(iLevel) &arrFNa
me(iFCnt)&" ("&TranslateFeatureState(oMsi.FeatureState(sProductCode,arrFName(iFC
nt)))&")" &vbCrLf&sRight
End If 'arrFLevel(iFCnt)=i
Next 'iFCnt
Next 'iLevel
'Reset objects
Set oRecordSet
Set oDicLevel
Set oDicParent

for next cycle

= Nothing
= Nothing
= Nothing

Loop 'iFoo=0
arrFeature(iPosMaster,FEATURE_TREE)=vbCrLf&sFTree
Next 'iProdMaster
End Sub 'FindFeatureStates
'===============================================================================
========================
'Translate the FeatureState value
Function TranslateFeatureState(iFState)
Select Case iFState
Case INSTALLSTATE_UNKNOWN
Case INSTALLSTATE_ADVERTISED
Case INSTALLSTATE_ABSENT
Case INSTALLSTATE_LOCAL
Case INSTALLSTATE_SOURCE
Case INSTALLSTATE_DEFAULT
Case INSTALLSTATE_VIRTUALIZED
Case INSTALLSTATE_BADCONFIG
Case Else
End Select

:
:
:
:
:
:
:
:
:

TranslateFeatureState="Unknown"
TranslateFeatureState="Advertised"
TranslateFeatureState="Absent"
TranslateFeatureState="Local"
TranslateFeatureState="Source"
TranslateFeatureState="Default"
TranslateFeatureState="Virtualized"
TranslateFeatureState="BadConfig"
TranslateFeatureState="Error"

End Function 'GetFeatureStateString

'===============================================================================
========================
Function FeatureIndent(iNestLevel)
Dim iLevel
Dim sIndent
For iLevel = 1 To iNestLevel
sIndent = sIndent & vbTab
Next 'iLevel
FeatureIndent = sIndent
End Function 'FeatureIndent
'===============================================================================
========================
Function GetFeatureNestLevel(sProductCode,sFeature,iNestLevel)
Dim sParent : sParent = ""
iNestLevel=iNestLevel+1
sParent=oMsi.FeatureParent(sProductCode,sFeature)
If Not sParent = "" Then iNestLevel=GetFeatureNestLevel(sProductCode,sParent
,iNestLevel)
GetFeatureNestLevel = iNestLevel
End Function 'GetFeatureNestLevel
'===============================================================================
========================
'===============================================================================
========================
'Module Product InstallSource '===============================================================================
========================
Sub ReadMsiInstallSources ()
If fBasicMode Then Exit Sub
On Error Resume Next

Dim
Dim
Dim
Dim

oProduct, oSumInfo
iProdCnt, iSourceCnt
sSource
MsiSources

ReDim arrIS(UBound(arrMaster),UBOUND_IS)
For iProdCnt = 0 To UBound(arrMaster)
arrIS(iProdCnt,IS_SOURCETYPESTRING) = "No Data Available"
arrIS(iProdCnt,IS_ORIGINALSOURCE) = "No Data Available"
'Add the ProductCode to the array
arrIS(iProdCnt,IS_PRODUCTCODE) = arrMaster(iProdCnt,COL_PRODUCTCODE)
If arrMaster(iProdCnt, COL_VIRTUALIZED) = 1 Then
' do nothing
Else
'SourceType
If oFso.FileExists(arrMaster(iProdCnt,COL_CACHEDMSI)) Then
Err.Clear
Set oSumInfo = oMsi.SummaryInformation(arrMaster(iProdCnt,COL_CA
CHEDMSI),MSIOPENDATABASEMODE_READONLY)
If Err = 0 Then
arrIS(iProdCnt,IS_SOURCETYPE) = oSumInfo.Property(PID_WORDCO
UNT)
Select Case arrIS(iProdCnt,IS_SOURCETYPE)
Case 0 : arrIS(iProdCnt,IS_SOURCETYPESTRING) = "Original sou
rce using long file names"
Case 1 : arrIS(iProdCnt,IS_SOURCETYPESTRING) = "Original sou
rce using short file names"
Case 2 : arrIS(iProdCnt,IS_SOURCETYPESTRING) = "Compressed s
ource files using long file names"
Case 3 : arrIS(iProdCnt,IS_SOURCETYPESTRING) = "Compressed s
ource files using short file names"
Case 4 : arrIS(iProdCnt,IS_SOURCETYPESTRING) = "Administrati
ve image using long file names"
Case 5 : arrIS(iProdCnt,IS_SOURCETYPESTRING) = "Administrati
ve image using short file names"
Case Else : arrIS(iProdCnt,IS_SOURCETYPESTRING) = "Unknown I
nstallSource Type"
End Select
Else
'ERR_SICONNECTFAILED
Cachelog LOGPOS_REVITEM,LOGHEADING_NONE,ERR_CATEGORYERROR,"P
roduct " & arrMaster(iProdCnt,COL_PRODUCTCODE) & DSV & _
arrMaster(iProdCnt,COL_PRODUCTNAME) & ": " & ERR_SICONNECTFA
ILED
arrMaster(iProdCnt,COL_ERROR) = arrMaster(iProdCnt,COL_ERROR
) & ERR_CATEGORYERROR & ERR_SICONNECTFAILED & CSV
End If 'Err
End If
'Get the original InstallSource
arrIS(iProdCnt,IS_ORIGINALSOURCE) = oMsi.ProductInfo(arrMaster(iProd
Cnt,COL_PRODUCTCODE),"InstallSource")
If Not Len(arrIS(iProdCnt,IS_ORIGINALSOURCE)) > 0 Then arrIS(iProdCn
t,IS_ORIGINALSOURCE) = "Not Registered"
'Get Network InstallSource(s)

'With WI 3.x and later the 'Product' object can be used to gather so
me data
If iWiVersionMajor > 2 Then
Err.Clear
Set oProduct = oMsi.Product(arrMaster(iProdCnt,COL_PRODUCTCODE),
arrMaster(iProdCnt,COL_USERSID),arrMaster(iProdCnt,COL_CONTEXT))
If Err = 0 Then
'Get the last used source
arrIS(iProdCnt,IS_LASTUSEDSOURCE) = oProduct.SourceListInfo(
"LastUsedSource")
Set MsiSources = oProduct.Sources(1)
For Each sSource in MsiSources
If IsEmpty(arrIS(iProdCnt,IS_ADDITIONALSOURCES)) Then
arrIS(iProdCnt,IS_ADDITIONALSOURCES)=sSource 'MsiSou
rces(iSourceCnt)
Else
arrIS(iProdCnt,IS_ADDITIONALSOURCES)=arrIS(iProdCnt,
IS_ADDITIONALSOURCES)&" || "& sSource'MsiSources(iSourceCnt)
End If
Next 'MsiSources
End If 'Err
End If 'iWiVersionMajor
'Get the LIS resiliency source (if applicable)
If GetDeliveryResiliencySource(arrMaster(iProdCnt,COL_PRODUCTCODE),i
ProdCnt,sSource) Then arrIS(iProdCnt,IS_LISRESILIENCY)=sSource
End If 'Not Virtualized
Next 'iProdCnt
End Sub 'ReadMsiInstallSources
'===============================================================================
========================
'Return True/False and the LIS source path as sSource
'Empty string for sProductCode forces to identify the DownloadCode from Setup.xm
l
Function GetDeliveryResiliencySource (sProductCode,iPosMaster,sSource)
On Error Resume Next
Dim
Dim
Dim
,source
Dim
Dim
Dim

arrSources,arrDownloadCodeKeys
dicDownloadCode
sSubKeyName,sValue,key,sku,sSkuName,sText,sDownloadCode,sTmpDownloadCode
arrKeys,arrSku
iVersionMajor,iSrc
fFound

GetDeliveryResiliencySource=False
sSource = Empty
iVersionMajor = GetVersionMajor(sProductCode)
Set dicDownloadCode = CreateObject("Scripting.Dictionary")
Select Case iVersionMajor
'Case 14
Case 12,14
'Note: ProductCode doesn't work consistently for this logic
'
To locate the Setup.xml requires additional logic so the tweak he
re is to use the
'
original source location to identify the DownloadCode

sText=arrIS(iPosMaster,IS_ORIGINALSOURCE)
If InStr(source,"{")>0 Then sDownloadCode=Mid(sText,InStr(sText,"{"),40)
Else sDownloadCode=sProductCode
dicDownloadCode.Add sDownloadCode,sProductCode
'Find the additional download locations
'Check if more than one sources are registered
If InStr(arrIS(iPosMaster,IS_ADDITIONALSOURCES),"||")>0 Then
arrSources = Split(arrIS(iPosMaster,IS_ADDITIONALSOURCES)," || ")
For Each source in arrSources
If InStr(source,"{")>0 Then
sTmpDownloadCode=Mid(source,InStr(source,"{"),40)
If Not dicDownloadCode.Exists(sTmpDownloadCode) Then dicDown
loadCode.Add sTmpDownloadCode,sProductCode
End If 'InStr
Next'
End If 'InStr

arrDownloadCodeKeys = dicDownloadCode.Keys
For iSrc = 0 To dicDownloadCode.Count-1
sDownloadCode = UCase(arrDownloadCodeKeys(iSrc))
'Enum HKLM\SOFTWARE\Microsoft\Office\Delivery\SourceEngine\Downloads
sSubKeyName="SOFTWARE\Microsoft\Office\Delivery\SourceEngine\Downloa
ds\"
If RegEnumKey(HKLM,sSubKeyName,arrKeys) Then
For Each key in arrKeys
fFound = False
If Len(key)>37 Then
fFound = (UCase(Left(key,38))=sDownloadCode) OR (UCase(k
ey)=sDownloadCode)
Else
fFound = (UCase(key)=sDownloadCode)
End If 'Len > 37
If fFound Then
'Found the Delivery reference
'Enum the 'Sources' subkey
sSubKeyName=sSubKeyName&key&"\Sources\"
If RegEnumKey(HKLM,sSubKeyName,arrSku) Then
For Each sku in arrSku
If RegReadStringValue(HKLM,sSubKeyName&sku,"Path
",sValue) Then
sSkuName=""
sSkuName=" (" & Left(sku,InStr(sku,"(")-1) &
")"
If IsEmpty(sSource) Then
sSource = sValue & sSkuName
Else
sSource = sSource&" || "&sValue&sSkuName
End If 'IsEmpty
End If 'RegReadStringValue
Next 'sku
End If 'RegEnumKey
'GUID is unique no need to continue loop once we found a
match
Exit For
End If
Next 'key

End If 'RegEnumKey
Next 'iSrc
Case 11
'Get the DownloadCode
sSubKeyName="SOFTWARE\Microsoft\Office\11.0\Delivery\"&sProductCode&"\"
If RegReadStringValue(HKLM,sSubKeyName,"DownloadCode",sDownloadCode) The
n
sSubKeyName="SOFTWARE\Microsoft\Office\Delivery\SourceEngine\Downloa
ds\"&sDownloadCode&"\Sources\"&Mid(sProductCode,2,36)&"\"
If RegReadStringValue(HKLM,sSubKeyName,"Path",sValue) Then sSource =
sValue
End If
Case Else 'Does not have LIS
End Select
If Not IsEmpty(sSource) Then GetDeliveryResiliencySource=True
End Function 'GetDeliveryResiliencySource
'===============================================================================
========================
'===============================================================================
========================
'Module Product Properties
'===============================================================================
========================
'Gather additional properties for the product
'Add them to master array
Sub ProductProperties
Dim sActiveSub, sErrHnd,sProdId,n
Dim prod,MsiDb
Dim iPosMaster,iVersionMajor,iContext,iProd
Dim sProductCode,sSpLevel,sCachedMsi,sSid,sComp,sComp2,sPath,sRef
Dim fVer,fCx
Dim arrCx,arrCxN,arrCxErr,arrKeys,arrTypes,arrNames
On Error Resume Next
If NOT fInitArrProdVer Then InitProdVerArrays
For iPosMaster = 0 to UBound (arrMaster)
' collect properties only for products in state '5' (Default)
If arrMaster(iPosMaster,COL_STATE) = INSTALLSTATE_DEFAULT OR arrMaster(i
PosMaster,COL_STATE) = INSTALLSTATE_VIRTUALIZED Then
sProductCode = arrMaster(iPosMaster,COL_PRODUCTCODE)
sSid = arrMaster(iPosMaster,COL_USERSID)
iContext = arrMaster(iPosMaster,COL_CONTEXT)
' ProductID
sProdId = GetProductId(sProductCode,iPosMaster)
If NOT sProdId = "" Then arrMaster(iPosMaster,COL_PRODUCTID) = sProd
Id
' ProductVersion
arrMaster(iPosMaster,COL_PRODUCTVERSION) = GetProductVersion(sProduc
tCode,iContext,sSid)
If NOT fBasicMode Then
' cached .msi package
Set MsiDb = Nothing
arrMaster(iPosMaster,COL_CACHEDMSI) = GetCachedMsi(sProductCode,

iPosMaster)
If NOT arrMaster(iPosMaster,COL_CACHEDMSI) = "" AND arrMaster(iP
osMaster, COL_VIRTUALIZED) = 0 Then Set MsiDb = oMsi.OpenDatabase(arrMaster(iPos
Master,COL_CACHEDMSI), MSIOPENDATABASEMODE_READONLY)
' PackageCode
arrMaster(iPosMaster,COL_PACKAGECODE) = GetPackageCode(sProductC
ode,iPosMaster,MsiDb)
' UpgradeCode
arrMaster(iPosMaster,COL_UPGRADECODE) = GetUpgradeCode(MsiDb)
' Transforms
arrMaster(iPosMaster,COL_TRANSFORMS) = GetTransforms(sProductCod
e, iPosMaster)
' InstallDate
arrMaster(iPosMaster,COL_INSTALLDATE) = GetInstallDate(sProductC
ode,iContext,sSid,arrMaster(iPosMaster,COL_CACHEDMSI))
' original .MSI Name
arrMaster(iPosMaster,COL_ORIGINALMSI) = GetOriginalMsiName(sProd
uctCode, iPosMaster)
End If 'fBasicMode
' some of this is only valid for Office products
If arrMaster(iPosMaster,COL_ISOFFICEPRODUCT) Then
' SP level
iVersionMajor = GetVersionMajor(sProductCode)
sSpLevel = OVersionToSpLevel(sProductCode, iVersionMajor, arrMas
ter(iPosMaster, COL_PRODUCTVERSION))
arrMaster(iPosMaster, COL_SPLEVEL) = sSpLevel
' Build/Origin
If NOT fBasicMode Then arrMaster(iPosMaster,COL_ORIGIN) = CheckO
rigin(MsiDb)
' Architecture (Bitness)
If Left(arrMaster(iPosMaster,COL_PRODUCTVERSION),2)>11 Then
If Mid(sProductCode,21,1) = "1" Then arrMaster(iPosMaster, C
OL_ARCHITECTURE) = "x64" Else arrMaster(iPosMaster, COL_ARCHITECTURE) = "x86"
End If
If NOT fBasicMode Then
' Cx
fVer = False : fCx = False
Select Case iVersionMajor
Case 11
sComp = "{1EBDE4BC-9A51-4630-B541-2561FA45CCC5}"
sRef = "11.0.8320.0"
Case 12
sComp = "{0638C49D-BB8B-4CD1-B191-051E8F325736}"
sRef = "12.0.6514.5001"
If Mid(sProductCode,11,4) = "0020" Then fVer = True
Case 14
If Mid(sProductCode,21,1) = "1" Then
sComp = "{C0AC079D-A84B-4CBD-8DBA-F1BB44146899}"
sComp2= "{E6AC97ED-6651-4C00-A8FE-790DB0485859}"
Else
sComp = "{019C826E-445A-4649-A5B0-0BF08FCC4EEE}"
sComp2= "{398E906A-826B-48DD-9791-549C649CACE5}"
End If
sRef = "14.0.5123.5004"
Case Else
sComp = "" : sComp2 = "" : sRef = ""
End Select
' obtain product handle
Err.Clear
If oMsi.Product(sProductCode, sSid, iContext).ComponentState

(sComp) = INSTALLSTATE_LOCAL Then

If Err = 0 Then
fCx = True
sPath = oMsi.ComponentPath(sProductCode,sComp)
If oFso.FileExists(sPath) Then
fVer = (CompareVersion(oFso.GetFileVersion(sPath
),sRef,True) > -1)
End If
If iVersionMajor = 14 Then
If oMsi.Product(sProductCode, sSid, iContext).Co
mponentState(sComp2) = INSTALLSTATE_LOCAL Then
sPath = oMsi.ComponentPath(sProductCode,sCom
p2)
If oFso.FileExists(sPath) Then
fVer = (CompareVersion(oFso.GetFileVersi
on(sPath),sRef,True) > -1)
End If
End If 'INSTALLSTATE_LOCAL
Err.Clear
End If
Else
Err.Clear
End If 'Err = 0
End If 'INSTALLSTATE_LOCAL
If fVer Then
arrCxN = Array("44","43","58","46")
Select Case iVersionMajor
Case 11
arrCx = Array("53","4F","46","54","57","41","52","45
","5C","4D","69","63","72","6F","73","6F","66","74","5C","4F","66","66","69","63
","65","5C","31","31","2E","30","5C","57","6F","72","64")
arrCxErr = Array("43","75","73","74","6F","6D","20",
"58","4D","4C","20","66","65","61","74","75","72","65","20","64","69","73","61",
"62","6C","65","64","20","62","79","20","4B","42","20","39","37","39","30","34",
"35")
If RegEnumValues(HKLM,hAtS(arrCx),arrNames,arrTypes)
Then
For Each n in arrNames
If UCase(n) = hAtS(arrCxN) Then arrMaster(iP
osMaster,COL_NOTES) = arrMaster(iPosMaster,COL_NOTES) & hAtS(arrCxErr) & CSV
Next 'n
End If
Case 12
arrCx = Array("53","4F","46","54","57","41","52","45
","5C","4D","69","63","72","6F","73","6F","66","74","5C","4F","66","66","69","63
","65","5C","31","32","2E","30","5C","57","6F","72","64")
arrCxErr = Array("57","6F","72","64","20","43","75",
"73","74","6F","6D","20","58","4D","4C","20","66","65","61","74","75","72","65",
"20","64","69","73","61","62","6C","65","64","20","62","79","20","4B","42","20",
"39","37","34","36","33","31")
If Mid(sProductCode,11,4) = "0020" Then
If CompareVersion(sRef,GetMsiProductVersion(arrM
aster(iPosMaster,COL_CACHEDMSI)),False) < 1 Then
arrCxErr = Array("57","6F","72","64","20","4
3","75","73","74","6F","6D","20","58","4D","4C","20","66","65","61","74","75","7
2","65","20","64","69","73","61","62","6C","65","64","20","62","79","20","43","6
F","6D","70","61","74","69","62","69","6C","69","74","79","20","50","61","63","6
B")
End If
End If '"0020"

If RegEnumValues(HKLM,hAtS(arrCx),arrNames,arrTypes)
Then
For Each n in arrNames
If UCase(n) = hAtS(arrCxN) Then arrMaster(iP
osMaster,COL_NOTES) = arrMaster(iPosMaster,COL_NOTES) & hAtS(arrCxErr) & CSV
Next 'n
End If
Case 14
arrCxErr = Array("43","75","73","74","6F","6D","20",
"58","4D","4C","20","66","65","61","74","75","72","65","20","65","6E","61","62",
"6C","65","64","20","62","79","20","57","6F","72","64","20","32","30","31","30",
"20","4B","42","20","32","34","32","38","36","37","20","61","64","64","2D","69",
"6E")
For Each prod in arrMaster
If Mid(prod,11,4)="0126" Then arrMaster(iPosMast
er,COL_NOTES) = arrMaster(iPosMaster,COL_NOTES) & hAtS(arrCxErr) & CSV
Next 'prod
Case Else
End Select
Else
If (iVersionMajor = 14) AND fCx Then
arrCxErr = Array("43","75","73","74","6F","6D","20",
"58","4D","4C","20","66","65","61","74","75","72","65","20","66","6F","72","20",
"74","68","65","20","62","69","6E","61","72","79","20","2E","64","6F","63","20",
"66","6F","72","6D","61","74","20","72","65","71","75","69","72","65","73","20",
"4B","42","20","32","34","31","33","36","35","39")
arrMaster(iPosMaster,COL_NOTES) = arrMaster(iPosMast
er,COL_NOTES) & hAtS(arrCxErr) & CSV
End If '14
End If 'fVer
End If 'fBasicMode
Else
arrMaster(iPosMaster,COL_ORIGIN) = "n/a"
' checks for known add-ins
' POWERPIVOT_2010
If InStr(POWERPIVOT_2010,arrMaster(iPosMaster,COL_UPGRADECODE))
> 0 Then
If CompareVersion(arrMaster(iPosMaster,COL_PRODUCTVERSION),"
10.50.1747.0",True) < 1 Then
arrMaster(iPosMaster,COL_NOTES) = arrMaster(iPosMaster,C
OL_NOTES) & ERR_CATEGORYWARN & "This is a preview version. Please obtain version
10.50.1747.0 or higher." & CSV
End If
End If 'POWERPIVOT_2010
End If 'IsOfficeProduct
End If 'INSTALLSTATE_DEFAULT
Next 'iPosMaster
End Sub 'ProductProperties
'===============================================================================
========================
'The name of the original installation package 'PackageName' is obtained from HK
CR.
'This limits the availability to products which are installed 'per-machine' or f
or the current user!
'Exception situations WI < 3.x or user profile not available are covered in the
'Error handler'
Function GetOriginalMsiName(sProductCode, iPosMaster)
Dim iPos
Dim sCompGuid, sRegName

Dim fVirtual
On Error Resume Next
fVirtual = (arrMaster(iPosMaster, COL_VIRTUALIZED) = 1)
sRegName = ""
If NOT fVirtual Then sRegName = oMsi.ProductInfo(sProductCode,"PackageName")
'Error Handler
If (Not Err = 0) OR sRegName = "" Then
'This can happen if WI < 3.x or product is installed for other user
Err.Clear
iPos = GetArrayPosition(arrMaster,sProductCode)
sCompGuid = GetCompressedGuid(sProductCode)
sRegName = GetRegOriginalMsiName(sCompGuid,arrMaster(iPos,COL_CONTEXT),a
rrMaster(iPos,COL_USERSID))
If sRegName = "-" AND NOT fVirtual Then arrMaster(iPos,COL_ERROR) = arrM
aster(iPos,COL_ERROR) & ERR_CATEGORYERROR & ERR_BADMSINAMEMETADATA & CSV
End If
GetOriginalMsiName = sRegName
End Function
'===============================================================================
========================
'The 'Transforms' property is obtained from HKCR.
'This limits the availability to products which are installed 'per-machine' or f
or the current user!
'Exception situations WI < 3.x or user profile not available are covered in the
'Error handler'
Function GetTransforms(sProductCode, iPosMaster)
Dim sTransforms, sCompGuid, sRegTransforms
Dim iPos
On Error Resume Next
GetTransforms = "-" : sTransforms = ""
If arrMaster(iPosMaster, COL_VIRTUALIZED) = 0 Then sTransforms = oMsi.Produc
tInfo(sProductCode,"Transforms")
'Error Handler
If NOT Err = 0 OR arrMaster(iPosMaster, COL_VIRTUALIZED) = 1 Then
Err.Clear
iPos = GetArrayPosition(arrMaster,sProductCode)
sCompGuid = GetCompressedGuid(sProductCode)
sTransforms = GetRegTransforms(sCompGuid,arrMaster(iPos,COL_CONTEXT),arr
Master(iPos,COL_USERSID))
End If
If Len(sTransforms) > 0 Then GetTransforms = sTransforms
End Function
'===============================================================================
========================
'InstallDate is available as part of the ProductInfo.
'It's stored in the global key. Introduced with WI 3.x
Function GetInstallDate(sProductCode,iContext,sSid,sCachedMsi)
Dim iPos
Dim hDefKey
Dim sSubKeyName, sName, sValue, sDateLocalized, sDateNormalized, sYY, sMM, s
DD
On Error Resume Next

GetInstallDate = ""
hDefKey = HKEY_LOCAL_MACHINE
sSubKeyName = GetRegConfigKey(sProductCode,iContext,sSid,True) & "InstallPro
perties"
sName = "InstallDate"
GetInstallDate = "-"
If RegReadValue(hDefKey,sSubKeyName,sName,sValue,"REG_EXPAND_SZ") Then GetIn
stallDate = sValue
'The InstallDate is reset with every patch transaction
'As a workaround the CreateDate of the cached .msi package will be used to o
btain the correct date
If oFso.FileExists(sCachedMsi) Then
'GetInstallDate = oFso.GetFile(sCachedMsi).DateCreated
sDateLocalized = oFso.GetFile(sCachedMsi).DateCreated
sYY = Year(sDateLocalized)
sMM = Right("0" & Month(sDateLocalized), 2)
sDD = Right("0" & Day(sDateLocalized), 2)
sDateNormalized = sYY & " " & sMM & " " & sDD & " (yyyy mm dd)"
GetInstallDate = sDateNormalized
End If
End Function 'GetInstallDate
'===============================================================================
========================
'The package code associates a .msi file with an application or product
'This property is used for source verification
'3 possible checks here:
' a) Installer.ProductInfo
Note: ProductInfo object is limited to per-machin
e and current user scope
' b) SummaryInformation stream from cached .msi
' c) SummaryInformation stream from .msi in InstallSource
Function GetPackageCode(sProductCode,iPosMaster,MsiDb)
Dim sValidate, sCompGuid, sPackageCode
Dim oSumInfo
On Error Resume Next
sPackageCode = ""
If arrMaster(iPosMaster, COL_VIRTUALIZED) = 0 Then sPackageCode = oMsi.Produ
ctInfo(sProductCode, "PackageCode")
If (Not Err = 0) OR (sPackageCode="") Then
' Error Handler
sCompGuid = GetCompressedGuid(sProductCode)
sPackageCode = GetRegPackageCode(sCompGuid,arrMaster(iPosMaster,COL_CONT
EXT),arrMaster(iPosMaster,COL_USERSID))
Exit Function
End If
If Not sPackageCode = "n/a" Then
If Not IsValidGuid(sPackageCode,GUID_UNCOMPRESSED) Then
If fGuidCaseWarningOnly Then
arrMaster(iPosMaster,COL_NOTES) = arrMaster(iPosMaster,COL_NOTES
) & ERR_CATEGORYNOTE & ERR_GUIDCASE & DOT & sErrBpa & CSV
Else
Cachelog LOGPOS_REVITEM,LOGHEADING_NONE, ERR_CATEGORYERROR,"Prod
uct " & sProductCode & DSV & arrMaster(iPosMaster,COL_PRODUCTNAME) & _
": " & sError & " for PackageCode '" & sPackageCode & "
'" & DOT & sErrBpa
sError = "" : sErrBpa = ""

arrMaster(iPosMaster,COL_ERROR) = arrMaster(iPosMaster,COL_ERROR
) & ERR_CATEGORYERROR & sError & DOT & sErrBpa & CSV
End If 'fGuidCaseWarningOnly
End If
End If
' Scan cached .msi
If Not arrMaster(iPosMaster,COL_CACHEDMSI) = "" Then
Set oSumInfo = MsiDb.SummaryInformation(MSIOPENDATABASEMODE_READONLY
)
If Not (Err = 0) Then
arrMaster(iPosMaster,COL_NOTES) = arrMaster(iPosMaster,COL_NOTES
) & ERR_CATEGORYWARN & ERR_INITSUMINFO & CSV
Exit Function
End If 'Not Err
If Not sPackageCode = oSumInfo.Property(PID_REVNUMBER) Then
arrMaster(iPosMaster,COL_ERROR) = arrMaster(iPosMaster,COL_ERROR
) & ERR_CATEGORYERROR & ERR_PACKAGECODEMISMATCH & CSV
Cachelog LOGPOS_REVITEM,LOGHEADING_NONE,ERR_CATEGORYERROR,"Produ
ct " & sProductCode & DSV & arrMaster(iPosMaster,COL_PRODUCTNAME) & _
": " & ERR_PACKAGECODEMISMATCH & DOT & BPA_PACKAGECODEMISM
ATCH
End If
End If 'arrMaster
' Scan .msi in InstallSource has to be deferred to module InstallSource
GetPackageCode = sPackageCode
End Function 'GetPackageCode
'===============================================================================
========================
Function GetUpgradeCode (MsiDb)
Dim Record
Dim qView
On Error Resume Next
GetUpgradeCode = ""
If MsiDb Is Nothing Then Exit Function
Set qView = MsiDb.OpenView("SELECT `Value` FROM Property WHERE `Property`='U
pgradeCode'")
qView.Execute()
Set Record = qView.Fetch()
If NOT Err = 0 Then Exit Function
GetUpgradeCode = Record.StringData(1)
WriteDebug sActiveSub,"Upgradecode: " & Record.StringData(1)
End Function 'GetPackageCode
'===============================================================================
========================
'Read the Build / Origin property from the cached .msi
Function CheckOrigin(MsiDb)
Dim sQuery, sCachedMsi
Dim Record
Dim qView
On Error Resume Next
' not all products do support this so the return value is not guaranteed.
CheckOrigin = ""
If MsiDb Is Nothing Then Exit Function
' read the 'Build' entry first
sQuery = "SELECT `Value` FROM Property WHERE `Property` = 'BUILD'"
Set qView = MsiDb.OpenView(sQuery)
qView.Execute

Set Record = qView.Fetch()

If Not Record Is Nothing Then
CheckOrigin = Record.StringData(1)
End If 'Is Nothing
' add the 'Origin' entry to the same field
sQuery = "SELECT `Value` FROM Property WHERE `Property` = 'ORIGIN'"
Set qView = MsiDb.OpenView(sQuery)
qView.Execute
Set Record = qView.Fetch()
If Not Record Is Nothing Then
CheckOrigin = CheckOrigin & " / " & Record.StringData(1)
End If 'Is Nothing
End Function
'===============================================================================
========================
Function GetCachedMsi(sProductCode,iPosMaster)
Dim sCachedMsi
Dim oApp
Dim fVirtual
On Error Resume Next
fVirtual = (arrMaster(iPosMaster, COL_VIRTUALIZED) = 1)
sCachedMsi = ""
If NOT fVirtual Then
' for WI >= 3.x we can use 'InstallProperty' for earlier versions we need to
stick to 'ProductInfo'
If iWiVersionMajor > 2 Then
Set oApp = oMsi.Product(sProductCode,arrMaster(iPosMaster,COL_USERSI
D),arrMaster(iPosMaster,COL_CONTEXT))
sCachedMsi = oApp.InstallProperty("LocalPackage")
ElseIf (arrMaster(iPosMaster,COL_USERSID) = sCurUserSid) Or (arrMaster(i
PosMaster,COL_CONTEXT) = MSIINSTALLCONTEXT_MACHINE) Then
' ProductInfo only available for per-machine or current users' products
sCachedMsi = oMsi.ProductInfo(sProductCode, "LocalPackage")
Else
' rely on error handling to retain the value from direct registry read
End If 'iWiVersionMajor
End If 'fVirtual
If Not Err = 0 Then
' ensure direct registry detection is done
sCachedMsi=""
' log Error
Cachelog LOGPOS_REVITEM,LOGHEADING_NONE,ERR_CATEGORYERROR,"Product " & s
ProductCode & DSV & arrMaster(iPosMaster,COL_PRODUCTNAME) & _
": " & ERR_PACKAGEAPIFAILURE & "."
End If
If sCachedMsi="" Then
sCachedMsi = GetRegCachedMsi(GetCompressedGuid(sProductCode),iPosMaster)
End If 'sCachedMsi=""
' ensure to not reference a non existent .msi
If sCachedMsi="" Then
If NOT fVirtual Then arrMaster(iPosMaster,COL_ERROR) = arrMaster(iPosMas
ter,COL_ERROR) & ERR_CATEGORYERROR & ERR_BADPACKAGEMETADATA & CSV
Else
If Not oFso.FileExists (sCachedMsi) Then
Cachelog LOGPOS_REVITEM,LOGHEADING_NONE,ERR_CATEGORYERROR,"Product "
& sProductCode & " - " &_

arrMaster(iPosMaster,COL_PRODUCTNAME) & ": " & ERR_LOCALPAC

KAGEMISSING & ": " & sCachedMsi
arrMaster(iPosMaster,COL_ERROR) = arrMaster(iPosMaster,COL_ERROR) &
ERR_CATEGORYERROR & ERR_LOCALPACKAGEMISSING & CSV
sCachedMsi = ""
End If 'oFso.FileExists
End If
GetCachedMsi = sCachedMsi
End Function 'GetCachedMsi
'===============================================================================
========================
Function GetRegCachedMsi (sProductCodeCompressed,iPosMaster)
Dim hDefKey
Dim sSubKeyName,sValue,sSid,sName
Dim iContext
On Error Resume Next
GetRegCachedMsi = ""
'Go global
hDefKey = HKLM
iContext = arrMaster(iPosMaster,COL_CONTEXT)
sSid = arrMaster(iPosMaster,COL_USERSID)
sName = "LocalPackage"
'Tweak managed to unmanaged to avoid link to managed global key
If iContext = MSIINSTALLCONTEXT_USERMANAGED Then
iContext = MSIINSTALLCONTEXT_USERUNMANAGED
sName = "ManagedLocalPackage"
End If
sSubKeyName = GetRegConfigKey(sProductCodeCompressed,iContext,sSid,True) & "
InstallProperties\"
If RegReadStringValue(hDefKey,sSubKeyName,sName,sValue) Then GetRegCachedMsi
= sValue
End Function
'===============================================================================
========================
Function GetProductId(sProductCode,iPosMaster)
Dim sProductId
Dim oApp
On Error Resume Next
GetProductId = ""
If arrMaster(iPosMaster,COL_CONTEXT) = MSIINSTALLCONTEXT_C2RV2 Then
sProductId = GetRegProductId(GetCompressedGuid(sProductCode),iPosMaster)
Exit Function
End If
'For WI >= 3.x we can use 'InstallProperty' for earlier versions we need to
stick to 'ProductInfo'
If iWiVersionMajor > 2 Then
Set oApp = oMsi.Product(sProductCode,arrMaster(iPosMaster,COL_USERSID),a
rrMaster(iPosMaster,COL_CONTEXT))
sProductId = oApp.InstallProperty("ProductID")
ElseIf (arrMaster(iPosMaster,COL_USERSID) = sCurUserSid) Or (arrMaster(iPosM
aster,COL_CONTEXT) = MSIINSTALLCONTEXT_MACHINE) Then
'ProductInfo only available for per-machine or current users' products

sProductId = oMsi.ProductInfo(sProductCode, "ProductID")

Else
'Rely on error handling to retain the value from direct registry read
End If 'iWiVersionMajor
If Not Err = 0 Then
'Ensure direct registry detection is done
sProductId=""
End If
If sProductId="" Then
sProductId = GetRegProductId(GetCompressedGuid(sProductCode),iPosMaster)
End If 'sCachedMsi=""
GetProductId = sProductId
End Function 'GetProductId
'===============================================================================
========================
Function GetRegProductId (sProductCodeCompressed,iPosMaster)
Dim hDefKey
Dim sSubKeyName,sValue,sSid,sName
Dim iContext
On Error Resume Next
GetRegProductId = ""
'Go global
hDefKey = HKLM
iContext = arrMaster(iPosMaster,COL_CONTEXT)
sSid = arrMaster(iPosMaster,COL_USERSID)
sName = "ProductID"
'Tweak managed to unmanaged to avoid link to managed global key
If iContext = MSIINSTALLCONTEXT_USERMANAGED Then
iContext = MSIINSTALLCONTEXT_USERUNMANAGED
sName = "ProductID"
End If
sSubKeyName = GetRegConfigKey(sProductCodeCompressed,iContext,sSid,True) & "
InstallProperties\"
If RegReadStringValue(hDefKey,sSubKeyName,sName,sValue) Then GetRegProductId
= sValue
End Function 'GetRegProductId
'===============================================================================
========================
'Get the ProductVersion string from WI ProductInfo
Function GetProductVersion (sProductCode,iContext,sSid)
Dim sTmp
On Error Resume Next
If iContext = MSIINSTALLCONTEXT_C2RV2 Then
GetProductVersion = GetRegProductVersion(sProductCode,iContext,sSid)
Exit Function
End If
sTmp = ""
sTmp = oMsi.ProductInfo (sProductCode, "VersionString")
If (sTmp = "") OR (NOT Err = 0) Then
Err.Clear

sTmp = GetRegProductVersion(sProductCode,iContext,sSid)
End If
GetProductVersion = sTmp
End Function
'===============================================================================
========================
'Get the ProductVersion from Registry
Function GetRegProductVersion (sProductCode,iContext,sSid)
Dim hDefKey
Dim sSubKeyName,sValue
Dim iTmpContext
On Error Resume Next
GetRegProductVersion = "Error"
hDefKey = HKEY_LOCAL_MACHINE
If iContext = MSIINSTALLCONTEXT_USERMANAGED Then
iTmpContext = MSIINSTALLCONTEXT_USERUNMANAGED
Else
iTmpContext = iContext
End If 'iContext = MSIINSTALLCONTEXT_USERMANAGED
sSubKeyName = GetRegConfigKey(GetCompressedGuid(sProductCode),iTmpContext,sS
id,True) & "InstallProperties\"
If RegReadStringValue(hDefKey,sSubKeyName,"DisplayVersion",sValue) Then GetR
egProductVersion = sValue
End Function
'===============================================================================
========================
'Translate the Office ProductVersion to the service pack level
Function OVersionToSpLevel (sProductCode,iVersionMajor,sProductVersion)
On Error Resume Next
'SKU identifier constants for SP level detection
Const O15_EXCEPTION = ""
Const O14_EXCEPTION = "007A,007B,007C,007D,007F,2005"
'#Devonly O12_Server = "1014,1015,104B,104E,1080,1088,10D7,10D8,10EB,10F5,10F6
,10F7,10F8,10FB,10FC,10FD,1103,1104,110D,1105,1110,1121,1122"
Const O12_EXCEPTION = "001C,001F,0020,003F,0045,00A4,00A7,00B0,00B1,00B2,00B
9,011F,CFDA"
Const O11_EXCEPTION = "14,15,16,17,18,19,1A,1B,1C,24,32,3A,3B,44,51,52,53,5E
,A1,A4,A9,E0"
Const O10_EXCEPTION = "17,1D,25,27,30,36,3A,3B,51,52,53,54"
Const O09_EXCEPTION = "3A,3B,3C,5F"
Dim iSpCnt,iExptnCnt,iLevel,iRetry
Dim sSpLevel,sSku
iLevel = 0 : iRetry = 0
Select Case iVersionMajor
Case 9
'Sku ProductID is 2 digits starting at pos 4
sSku = Mid(sProductCode,4,2)
If InStr(O09_EXCEPTION,sSku)>0 Then
For iExptnCnt = 1 To UBound(arrProdVer09,1)
If InStr(arrProdVer10(iExptnCnt,0),sSku)>0 Then Exit For
Next 'iExptnCnt

Else
iExptnCnt = 0
End If 'InStr(O09_Exception,sSku)>0
For iRetry = 0 To 1
For iSpCnt = 1 To UBound(arrProdVer09,2)
If sProductVersion = Left(arrProdVer09(iExptnCnt,iSpCnt),Len(sPr
oductVersion)) Then
'Special release references are noted within same field with
a "," separator
If InStr(arrProdVer09(iExptnCnt,iSpCnt),",")>0 Then
OVersionToSpLevel = Mid(arrProdVer09(iExptnCnt,iSpCnt),I
nStr(arrProdVer09(iExptnCnt,iSpCnt),",")+1,Len(arrProdVer09(iExptnCnt,iSpCnt)))
Exit Function
Else
iLevel = iSpCnt
End If
End If
Next 'iSpCnt
If iLevel > 0 Then Exit For
'Did not find the SP level yet. Retry with core build numbers
iExptnCnt = 0
Next 'iRetry
Case 10
'Sku ProductID is 2 digits starting at pos 4
sSku = Mid(sProductCode,4,2)
If InStr(O10_EXCEPTION,sSku)>0 Then
For iExptnCnt = 1 To UBound(arrProdVer10,1)
If InStr(arrProdVer10(iExptnCnt,0),sSku)>0 Then Exit For
Next 'iExptnCnt
Else
iExptnCnt = 0
End If 'InStr(O10_Exception,sSku)>0
For iRetry = 0 To 1
For iSpCnt = 1 To UBound(arrProdVer10,2)
If sProductVersion = Left(arrProdVer10(iExptnCnt,iSpCnt),Len(sPr
oductVersion)) Then
'Special release references are noted within same field with
a "," separator
If InStr(arrProdVer10(iExptnCnt,iSpCnt),",")>0 Then
OVersionToSpLevel = Mid(arrProdVer10(iExptnCnt,iSpCnt),I
nStr(arrProdVer10(iExptnCnt,iSpCnt),",")+1,Len(arrProdVer10(iExptnCnt,iSpCnt)))
Exit Function
Else
iLevel = iSpCnt
Exit For
End If
End If
Next 'iSpCnt
If iLevel > 0 Then Exit For
'Did not find the SP level yet. Retry with core build numbers
iExptnCnt = 0
Next 'iRetry
Case 11
'Sku ProductID is 2 digits starting at pos 4
sSku = Mid(sProductCode,4,2)
If InStr(O11_EXCEPTION,sSku)>0 Then

For iExptnCnt = 1 To UBound(arrProdVer11,1)

If InStr(arrProdVer11(iExptnCnt,0),sSku)>0 Then Exit For
Next 'iExptnCnt
Else
iExptnCnt = 0
End If 'InStr(O11_Exception,sSku)>0
For iRetry = 0 To 1
For iSpCnt = 1 To UBound(arrProdVer11,2)
If sProductVersion = Left(arrProdVer11(iExptnCnt,iSpCnt),Len(sPr
oductVersion)) Then
'Special release references are noted within same field with
a "," separator
If InStr(arrProdVer11(iExptnCnt,iSpCnt),",")>0 Then
OVersionToSpLevel = Mid(arrProdVer11(iExptnCnt,iSpCnt),I
nStr(arrProdVer11(iExptnCnt,iSpCnt),",")+1,Len(arrProdVer11(iExptnCnt,iSpCnt)))
Exit Function
Else
iLevel = iSpCnt
Exit For
End If
End If
Next 'iSpCnt
If iLevel > 0 Then Exit For
'Did not find the SP level yet. Retry with core build numbers
iExptnCnt = 0
Next 'iRetry
Case 12
'Sku ProductID is 4 digits starting at pos 11
sSku = Mid(sProductCode,11,4)
If InStr(O12_EXCEPTION,sSku)>0 Then
For iExptnCnt = 2 To UBound(arrProdVer12,1)
If InStr(arrProdVer12(iExptnCnt,0),sSku)>0 Then Exit For
Next 'iExptnCnt
ElseIf Left(sSku,1)="1" Then 'Server SKU
iExptnCnt = 1
Else
iExptnCnt = 0
End If 'InStr(O12_Exception,sSku)>0
For iRetry = 0 To 1
For iSpCnt = 1 To UBound(arrProdVer12,2)
If Left(sProductVersion,10) = Left(arrProdVer12(iExptnCnt,iSpCnt
),10) Then
'Special release references are noted within same field with
a "," separator
If InStr(arrProdVer12(iExptnCnt,iSpCnt),",")>0 Then
OVersionToSpLevel = Mid(arrProdVer12(iExptnCnt,iSpCnt),I
nStr(arrProdVer12(iExptnCnt,iSpCnt),",")+1,Len(arrProdVer12(iExptnCnt,iSpCnt)))
Exit Function
Else
iLevel = iSpCnt
Exit For
End If
End If
Next 'iSpCnt
If iLevel > 0 Then Exit For
'Did not find the SP level yet. Retry with core build numbers
iExptnCnt = 0

Next 'iRetry
'Beta build detection
If (iLevel=0) AND (CInt(Mid(sProductVersion,6,4))>6219) AND (CInt(Mid(sP
roductVersion,6,4))<6425) Then
OVersionToSpLevel = "SP2 Beta"
Exit Function
End If
Case 14
'Sku ProductID is 4 digits starting at pos 11
sSku = Mid(sProductCode,11,4)
If InStr(O14_EXCEPTION,sSku)>0 Then
For iExptnCnt = 1 To UBound(arrProdVer14,1)
If InStr(arrProdVer14(iExptnCnt,0),sSku)>0 Then Exit For
Next 'iExptnCnt
Else
iExptnCnt = 0
End If 'InStr(O14_Exception,sSku)>0
For iRetry = 0 To 1
For iSpCnt = 1 To UBound(arrProdVer14,2)
If Left(sProductVersion,10) = Left(arrProdVer14(iExptnCnt,iSpCnt
),10) Then
'Special release references are noted within same field with
a "," separator
If InStr(arrProdVer14(iExptnCnt,iSpCnt),",")>0 Then
OVersionToSpLevel = Mid(arrProdVer14(iExptnCnt,iSpCnt),I
nStr(arrProdVer14(iExptnCnt,iSpCnt),",")+1,Len(arrProdVer14(iExptnCnt,iSpCnt)))
Exit Function
Else
iLevel = iSpCnt
Exit For
End If
End If
Next 'iSpCnt
If iLevel > 0 Then Exit For
'Did not find the SP level yet. Retry with core build numbers
iExptnCnt = 0
Next 'iRetry
'Beta build detection
If (iLevel=0) AND (CInt(Mid(sProductVersion,6,4))<4537) Then
OVersionToSpLevel = "Beta"
Exit Function
End If
If (iLevel=0) AND (CInt(Mid(sProductVersion,6,4))<4763) Then
OVersionToSpLevel = "RC"
Exit Function
End If
If (iLevel=0) AND (CInt(Mid(sProductVersion,6,4))>5999) AND (CInt(Mid(sP
roductVersion,6,4))<6029) Then
OVersionToSpLevel = "SP1 Beta"
Exit Function
End If
Case 15
'Sku ProductID is 4 digits starting at pos 11
sSku = Mid(sProductCode,11,4)
If InStr(O15_EXCEPTION, sSku) > 0 Then
For iExptnCnt = 1 To UBound(arrProdVer15, 1)
If InStr(arrProdVer15(iExptnCnt, 0), sSku) > 0 Then Exit For

Next 'iExptnCnt
Else
iExptnCnt = 0
End If 'InStr(O15_Exception, sSku) > 0
For iRetry = 0 To 1
For iSpCnt = 1 To UBound(arrProdVer15, 2)
If Left(sProductVersion, 10) = Left(arrProdVer15(iExptnCnt, iSpC
nt), 10) Then
'Special release references are noted within same field with
a "," separator
If InStr(arrProdVer15(iExptnCnt, iSpCnt), ",") > 0 Then
OVersionToSpLevel = Mid(arrProdVer15(iExptnCnt, iSpCnt),
InStr(arrProdVer15(iExptnCnt, iSpCnt), ",") + 1, Len(arrProdVer15(iExptnCnt, iS
pCnt)))
Exit Function
Else
iLevel = iSpCnt
Exit For
End If
End If
Next 'iSpCnt
If iLevel > 0 Then Exit For
'Did not find the SP level yet. Retry with core build numbers
iExptnCnt = 0
Next 'iRetry
'Beta build detection
If (iLevel = 0) AND (CInt(Mid(sProductVersion, 6, 4)) < 3919) Then
OVersionToSpLevel = "Technical Preview"
Exit Function
End If
If (iLevel=0) AND (CInt(Mid(sProductVersion,6,4))= 3919) Then
OVersionToSpLevel = "Technical Preview Refresh"
Exit Function
End If
If (iLevel=0) AND (CInt(Mid(sProductVersion,6,4))=4128) Then
OVersionToSpLevel = "Customer Preview"
Exit Function
End If
Case Else
End Select
Select Case iLevel
Case 1 : sSpLevel = "RTM"
Case 2 : sSpLevel = "SP1"
Case 3 : sSpLevel = "SP2"
Case 4 : sSpLevel = "SP3"
Case Else : sSpLevel = "?"
End Select
OVersionToSpLevel = sSpLevel
End Function 'OVersionToSpLevel
'===============================================================================
========================
'Initialize arrays for translation ProductVersion -> ServicePackLevel
Sub InitProdVerArrays
On Error Resume Next

' 2013 Products -> KB

ReDim arrProdVer15(0,1) 'n,1=RTM
arrProdVer15(0,0)="" : arrProdVer15(0,1) = "15.0.4420.1017"
' 2010 Products -> KB
ReDim arrProdVer14(6,3) 'n,1=RTM; n,2=SP1
arrProdVer14(0,0)="" : arrProdVer14(0,1)="14.0.4763.1000" : arrProdVer14(0,2
)="14.0.6029.1000" ': arrProdVer14(0,3)=""
arrProdVer14(1,0)="007A" : arrProdVer14(1,1)="14.0.5118.5000,Web V1" 'Outloo
k Connector
arrProdVer14(2,0)="007B" : arrProdVer14(2,1)="14.0.5117.5000,Web V1" 'Outloo
k Social Connector Provider for Windows Live Messen
arrProdVer14(3,0)="007C" : arrProdVer14(3,1)="14.0.5117.5000,Web V1" 'Outloo
k Social Connector Facebook
arrProdVer14(4,0)="007D" : arrProdVer14(4,1)="14.0.5120.5000,Web V1" 'Outloo
k Social Connector Windows Live
arrProdVer14(5,0)="007F" : arrProdVer14(5,1)="14.0.5139.5001,Web V1" 'Outloo
k Connector
arrProdVer14(6,0)="2005" : arrProdVer14(6,1)="14.0.5130.5003,Web V1" 'OFV Fi
le Validation Add-In
' 2007 Products -> KB
ReDim arrProdVer12(12,4) 'n,1=RTM; n,2=SP1
arrProdVer12(0,0)="": arrProdVer12(0,1)="12.0.4518.1014": arrProdVer12(0,2)=
"12.0.6215.1000" : arrProdVer12(0,3)="12.0.6425.1000" : arrProdVer12(0,4)="12.0.
6612.1000"
arrProdVer12(1,0)="" : arrProdVer12(1,1)="12.0.4518.1016": arrProdVer12(1,2)
="12.0.6219.1000" ': arrProdVer12(1,3)="12.0.6425.1000" 'Server
arrProdVer12(2,0)="0045" : arrProdVer12(2,1)="12.0.4518.1084" 'Expression We
b 2
arrProdVer12(3,0)="011F" : arrProdVer12(3,1)="12.0.6407.1000,Web V1 (Windows
Live)" 'Outlook Connector
arrProdVer12(4,0)="001F" : arrProdVer12(4,1)="12.0.4518.1014" : arrProdVer12
(4,2)="12.0.6213.1000" 'Office Proof (Container)
arrProdVer12(5,0)="00B9" : arrProdVer12(5,1)="12.0.6012.5000,KB 932080": arr
ProdVer12(5,2)="12.0.6015.5000,Web V1 (Windows Live)"'Application Error Reportin
g
arrProdVer12(6,0)="0020" : arrProdVer12(6,1)="12.0.4518.1014,Web V1" : arrPr
odVer12(6,3)="12.0.6021.5000,Web V3" : arrProdVer12(6,4)="12.0.6514.5001,Web V4
(incl. SP2)" ': arrProdVer12(6,5)="12.0.6425.1000,SP2"'Compatibility Pack
arrProdVer12(7,0)="00B0,00B1,00B2" : arrProdVer12(7,1)="12.0.4518.1014,Web V
1" 'Save As packs
arrProdVer12(8,0)="004A" : arrProdVer12(8,1)="12.0.4518.1014,Web RTM" : arrP
rodVer12(8,2)="12.0.6213.1000,Web SP1" 'Web Components
arrProdVer12(9,0)="00A7" : arrProdVer12(9,1)="12.0.4518.1014,Web RTM" : arrP
rodVer12(9,2)="12.0.6520.3001,SP2" 'Calendar Printing Assistant
arrProdVer12(10,0)="CFDA" : arrProdVer12(10,1)="12.0.613.1000,RTM" : arrProd
Ver12(10,2)="12.1.1313.1000,SP1" : arrProdVer12(10,2)="12.0.6511.5000,SP2" 'Pro
ject Portfolio Server 2007
arrProdVer12(11,0)="001C" : arrProdVer12(11,1)="12.0.4518.1049,RTM" : arrPr
odVer12(11,2)="12.0.6230.1000,SP1" : arrProdVer12(11,3)="12.0.6237.1003,SP1" 'Ac
cess Runtime
arrProdVer12(12,0)="003F" : arrProdVer12(12,1)="12.0.6214.1000,SP1" 'Excel V
iewer
' 2003 Products -> KB832672
'ProductVersions
-> KB821549
Redim arrProdVer11(16,4) 'n,1=RTM; n,2=SP1; n,3=SP2; n,4=SP3
arrProdVer11(0,0)="": arrProdVer11(0,1)="11.0.5614.0": arrProdVer11(0,2)="11

.0.6361.0": arrProdVer11(0,3)="11.0.7969.0": arrProdVer11(0,4)="11.0.8173.0" 'Su

ites & Core
arrProdVer11(1,0)="14": arrProdVer11(1,1)="11.0.5614.0": arrProdVer11(1,2)="
11.0.6361.0": arrProdVer11(1,3)="11.0.7969.0": arrProdVer11(1,4)="11.0.8173.0" '
Sharepoint Services
arrProdVer11(2,0)="15,1C": arrProdVer11(2,1)="11.0.5614.0": arrProdVer11(2,2
)="11.0.6355.0"': arrProdVer11(2,3)="11.0.7969.0": arrProdVer11(2,4)="11.0.8173.
0" 'Access
arrProdVer11(3,0)="16": arrProdVer11(3,1)="11.0.5612.0": arrProdVer11(3,2)="
11.0.6355.0"': arrProdVer11(3,3)="11.0.7969.0": arrProdVer11(3,4)="11.0.8173.0"
'Excel
arrProdVer11(4,0)="17": arrProdVer11(4,1)="11.0.5516.0": arrProdVer11(4,2)="
11.0.6356.0"': arrProdVer11(4,3)="11.0.7969.0": arrProdVer11(4,4)="11.0.8173.0"
'FrontPage
arrProdVer11(5,0)="18": arrProdVer11(5,1)="11.0.5529.0": arrProdVer11(5,2)="
11.0.6361.0"': arrProdVer11(5,3)="11.0.7969.0": arrProdVer11(5,4)="11.0.8173.0"
'PowerPoint
arrProdVer11(6,0)="19": arrProdVer11(6,1)="11.0.5525.0": arrProdVer11(6,2)="
11.0.6255.0"': arrProdVer11(6,3)="11.0.7969.0": arrProdVer11(6,4)="11.0.8173.0"
'Publisher
arrProdVer11(7,0)="1A,E0": arrProdVer11(7,1)="11.0.5510.0": arrProdVer11(7,2
)="11.0.6353.0"': arrProdVer11(7,3)="11.0.7969.0": arrProdVer11(7,4)="11.0.8173.
0" 'Outlook
arrProdVer11(8,0)="1B": arrProdVer11(8,1)="11.0.5510.0": arrProdVer11(8,2)="
11.0.6353.0"': arrProdVer11(8,3)="11.0.7969.0": arrProdVer11(8,4)="11.0.8173.0"
'Word
arrProdVer11(9,0)="44": arrProdVer11(9,1)="11.0.5531.0": arrProdVer11(9,2)="
11.0.6357.0"': arrProdVer11(9,3)="11.0.7969.0": arrProdVer11(9,4)="11.0.8173.0"
'InfoPath
arrProdVer11(10,0)="A1": arrProdVer11(10,1)="11.0.5614.0": arrProdVer11(10,2
)="11.0.6360.0"': arrProdVer11(10,3)="11.0.7969.0": arrProdVer11(10,4)="11.0.817
3.0" 'OneNote
arrProdVer11(11,0)="3A,3B,32": arrProdVer11(11,1)="11.0.5614.0": arrProdVer1
1(11,2)="11.0.6707.0"': arrProdVer11(11,3)="11.0.7969.0": arrProdVer11(11,4)="11
.0.8173.0" 'Project
arrProdVer11(12,0)="51,53,5E": arrProdVer11(12,1)="11.0.3216.5614": arrProdV
er11(12,2)="11.0.4301.6360"': arrProdVer11(12,3)="11.0.7969.0": arrProdVer11(12,
4)="11.0.8173.0" 'Visio
arrProdVer11(13,0)="24" : arrProdVer11(13,1)="11.0.5614.0,V1 (Web)" : arrPro
dVer11(13,2)="11.0.6120.0,V2 (Hotfix)": arrProdVer11(13,3)="11.0.6550.0,V2 (Japa
nese Hotfix)" 'ORK
arrProdVer11(14,0)="52": arrProdVer11(14,1)="11.0.3709.5614": arrProdVer11(1
4,2)="11.0.6206.8011,Web V1"': arrProdVer11(14,3)="11.0.7969.0": arrProdVer11(14
,4)="11.0.8173.0" 'Visio Viewer
arrProdVer11(15,0)="A4" : arrProdVer11(15,1)="11.0.5614.0": arrProdVer11(15,
2)="11.0.6361.0" : arrProdVer11(15,3)="11.0.6558.0,MSDE"': arrProdVer11(15,4)="1
1.0.7969.0,SP2": arrProdVer11(15,5)="11.0.8173.0,SP3"'OWC11
arrProdVer11(16,0)="A9" : arrProdVer11(16,1)="11.0.5614.0,RTM" : arrProdVer1
1(16,2)="11.0.6553.0,Web V1" 'PIA11
' Office XP
'Office 10 Numbering Scheme -> KB302663
'ProuctVersions
-> KB291331
Redim arrProdVer10(5,4)
arrProdVer10(0,0)="": arrProdVer10(0,1)="10.0.2627.01": arrProdVer10(0,2)="1
0.0.3520.0": arrProdVer10(0,3)="10.0.4330.0": arrProdVer10(0,4)="10.0.6626.0"
'LPK/MUI RTM have inconsisten RTM build versions but do follow the main SP b
uilds.
'=> Limitation to not cover RTM LPK's
arrProdVer10(1,0)="17,1D": arrProdVer10(1,1)="10.0.2623.0": arrProdVer10(1,2

)="10.0.3506.0": arrProdVer10(1,3)="10.0.4128.0": arrProdVer10(1,4)="10.0.6308.0

"'FrontPage
arrProdVer10(2,0)="27,3A,3B": arrProdVer10(2,1)="10.0.2915.0": arrProdVer10(
2,2)="10.0.3416.0": arrProdVer10(2,3)="10.0.4219.0": arrProdVer10(2,4)="10.0.661
2.0"'Project
arrProdVer10(3,0)="30": arrProdVer10(3,1)="10.0.2619.0" 'Media Content (CAG)
arrProdVer10(4,0)="25,36": arrProdVer10(4,1)="10.0.2701.0,V1": arrProdVer10(
4,2)="10.0.6403.0,V2 (Oct 24 2002 - Release)" 'ORK
arrProdVer10(5,0)="51,52,53,54": arrProdVer10(5,1)="10.0.525": arrProdVer10(
5,2)="10.1.2514" : arrProdVer10(5,3)="10.2.5110" 'Visio
' 2000
Redim arrProdVer09(2,4)
arrProdVer09(0,0)="": arrProdVer09(0,1)="9.00.2720": arrProdVer09(0,2)="9.00
.3821,SR1": arrProdVer09(0,3)="9.00.4527": arrProdVer09(0,4)="9.00.9327"
arrProdVer09(1,0)="3A,3B,3C": arrProdVer09(1,1)="9.00.2720": arrProdVer09(1,
2)="9.00.4527"
arrProdVer09(2,0)="5F":arrProdVer09(2,1)="9.00.00.2010,Web V1" 'ORK
fInitArrProdVer = True
End Sub
'===============================================================================
========================
'Module Patch
'===============================================================================
========================
Sub FindAllPatches
If fBasicMode Then Exit Sub
Dim n
On Error Resume Next
'Set Default for patch array
Redim arrPatch(UBound(arrMaster),PATCH_COLUMNCOUNT,0)
'Check which patch API calls are safe for use
CheckPatchApi
'Iterate all products to add the patches to the array
For n = 0 To UBound(arrMaster)
'If arrMaster(n,COL_VIRTUALIZED) = 0 Then FindPatches(n)
FindPatches(n)
Next 'n
AddDetailsFromPackage
End Sub
'===============================================================================
========================
'Find all patches registered to a product and add them to the Patch array
Sub FindPatches (iPosMaster)
On Error Resume Next
Dim
Dim
Dim
Dim

Patches,Patch,siSumInfo,MsiDb,Record,qView
sQuery,sErr
iMspMax,iMspCnt
fVirtual

fVirtual = (arrMaster(iPosMaster,COL_VIRTUALIZED) = 1)

'Find client side patches (CSP) for the product

If iWiVersionMajor > 2 Then
If NOT fVirtual Then Set Patches = oMsi.PatchesEx(arrMaster(iPosMaster,C
OL_PRODUCTCODE),arrMaster(iPosMaster,COL_USERSID),arrMaster(iPosMaster,COL_CONTE
XT),MSIPATCHSTATE_ALL)
If Not Err = 0 OR fVirtual Then
'PatchesEx API call failed
'Log the error
sErr = GetErrorDescription(Err)
If fPatchesExOk AND NOT fVirtual Then
'Only log the error if fPatchesExOk = True.
'If we're Not fPatchesExOk the error is expected and has already
been logged.
Cachelog LOGPOS_REVITEM,LOGHEADING_NONE,ERR_CATEGORYERROR,"Produ
ct " & arrMaster(iPosMaster,COL_PRODUCTCODE) & DSV & arrMaster(iPosMaster,COL_PR
ODUCTNAME) & _
": " & ERR_PATCHESEX
arrMaster(iPosMaster,COL_ERROR) = arrMaster(iPosMaster,COL_ERROR
) & ERR_CATEGORYERROR & ERR_PATCHESEX & DSV & sErr & CSV
End If 'fPatchesExOk
'Fall back to registry detection
FindRegPatches iPosMaster
Else
'PatchesEx API call succeeded
'Ensure sufficient array size
iMspMax = Patches.Count
If iMspMax > UBound(arrPatch,3) Then ReDim Preserve arrPatch(UBound(
arrMaster),PATCH_COLUMNCOUNT,iMspMax)
'Find the patch details
ReadPatchDetails Patches,iPosMaster
End If 'Err = 0
Else
FindRegPatches iPosMaster
End If 'iWiVersionMajor > 2
'Find patches in InstallSource (AIP)
'Only valid for Office products
Err.Clear
If arrMaster(iPosMaster,COL_ISOFFICEPRODUCT) Then
Set MsiDb = oMsi.OpenDatabase(arrMaster(iPosMaster,COL_CACHEDMSI), MSIOP
ENDATABASEMODE_READONLY)
If Not Err = 0 Then
'Critical error for this sub. Need to terminate i
t to prevent endless loop.
Err.Clear
'Error has already been logged
Exit Sub
End If
sQuery = "SELECT * FROM Property"
Set qView = MsiDb.OpenView(sQuery)
qView.Execute
Set Record = qView.Fetch()
' Loop through the records in the view
Do Until (Record Is Nothing)
'Get the properties name. The 'OR' condition covers the Office 2000
family AIP's
If (Left(Record.StringData(1),1) = "_" And Mid(Record.StringData(1),
15,1) = "_") _
OR (Left(Record.StringData(1),1) = "{" And Mid(Record.StringData(1),

15,1) = "-") Then

'Found AIP patch
'ReDim patch array
iMspCnt = UBound(arrPatch,3)+1
ReDim Preserve arrPatch(UBound(arrMaster),PATCH_COLUMNCO
UNT,iMspCnt)
'Client side patch flag
arrPatch(iPosMaster,PATCH_CSP,iMspCnt) = False
'PatchCode
arrPatch(iPosMaster,PATCH_PATCHCODE,iMspCnt) = _
"{" & Mid(Record.StringData(1),2,8) & _
"-" & Mid(Record.StringData(1),11,4) & _
"-" & Mid(Record.StringData(1),16,4) & _
"-" & Mid(Record.StringData(1),21,4) & _
"-" & Mid(Record.StringData(1),26,12) & "}"
'DisplayName
arrPatch(iPosMaster,PATCH_DISPLAYNAME,iMspCnt) = Record.Stri
ngData(2)
End If
' Next record
Set Record = qView.Fetch()
Loop
End If 'arrMaster(iPosMaster,COL_ISOFFICEPRODUCT)
End Sub 'FindPatches
'===============================================================================
========================
'Find all patches registered to a product by direct registry read and add them t
o the Patch array
Sub FindRegPatches (iPosMaster)
Dim sSid,sSubKeyName,sSubKeyNamePatch,sSubKeyNamePatches,sValue,sProductCode
Dim sPatch,sPatches,sAllPatches,sTmpPatches
Dim hDefKey,hDefKeyGlobal
Dim bPatchRegOk,bPatchMultiSzBroken,bPatchOrgMspNameBroken,bPatchCachedMspLi
nkBroken
Dim bPatchGlobalOK,bPatchProdGlobalBroken,bPatchGlobalMultiSzBroken
Dim iContext,iName,iType,iKey,iState,iMspMax
Dim arrName,arrType,arrKeys,arrRegPatch
Const REGDIM1 = 1
On Error Resume Next
iContext = arrMaster(iPosMaster,COL_CONTEXT)
sSid = arrMaster(iPosMaster,COL_USERSID)
sProductCode = arrMaster(iPosMaster,COL_PRODUCTCODE)
sTmpPatches = ""
bPatchRegOk = False
bPatchGlobalOk = False
bPatchMultiSzBroken = False
bPatchOrgMspNameBroken = False
ReDim arrRegPatch(REGDIM1,-1)
'Find "Applied" patches
hDefKeyGlobal = GetRegHive(iContext,sSid,True)
hDefKey = GetRegHive(iContext,sSid,False)
sSubKeyName = GetRegConfigKey(sProductCode,iContext,sSid,False) & "Patches\"
If RegEnumValues(hDefKey,sSubKeyName,arrName,arrType) AND CheckArray(arrName
) Then
bPatchRegOk = True
'Check Metadata integrity

sPatches = vbNullString
If Not RegReadValue(hDefKey,sSubKeyName,"Patches",sPatches,REG_MULTI_SZ)
Then bPatchRegOk = False
sTmpPatches = sPatches
For iName = 0 To UBound(arrName)
If arrType(iName) = REG_SZ Then
ReDim Preserve arrRegPatch(REGDIM1,UBound(arrRegPatch,2)+1)
sValue = ""
If RegReadStringValue(hDefKey,sSubKeyName,arrName(iName),sValue)
Then sPatch = arrName(iName)
arrRegPatch(0,UBound(arrRegPatch,2)) = GetExpandedGuid(sPatch)
arrRegPatch(1,UBound(arrRegPatch,2)) = MSIPATCHSTATE_APPLIED
If NOT InStr(sTmpPatches,sPatch)>0 Then
bPatchRegOk = False
bPatchMultiSzBroken = True
Else
'Strip current patch from sTmpPatches
sTmpPatches = Replace(sTmpPatches,sPatch,"")
End If 'InStr(sTmpPatches,sPatch)
'Check Patches key
sSubKeyNamePatches = GetRegConfigPatchesKey(iContext,sSid,False)
If Not RegKeyExists(hDefKey,sSubKeyNamePatches & sPatch) Then
bPatchOrgMspNameBroken = True
End If
'Check Global Patches key
sSubKeyNamePatches = ""
sSubKeyNamePatches = GetRegConfigPatchesKey(iContext,sSid,True)
If Not RegKeyExists(hDefKeyGlobal,sSubKeyNamePatches & sPatch) T
hen
bPatchCachedMspLinkBroken = True
End If
'Check Global Product key
sSubKeyNamePatches = ""
sSubKeyNamePatches = GetRegConfigKey(sProductCode,iContext,sSid,
True) & "Patches\" & sPatch
If Not RegKeyExists(hDefKeyGlobal,sSubKeyNamePatches) Then
bPatchProdGlobalBroken = True
Else
If RegReadDWordValue(hDefKeyGlobal,sSubKeyNamePatches,"State
",sValue) Then
arrRegPatch(1,UBound(arrRegPatch,2)) = CInt(sValue)
End If 'RegReadDWordValue
End If 'RegKeyExists(hDefKeyGlobal,sSubKeyNamePatches)
End If 'arrType
Next 'iName
End If 'RegEnumValues
'sTmpPatches should be an empty string now
sTmpPatches = Replace(sTmpPatches,Chr(34),"")
If (Not sTmpPatches = "") OR (NOT fPatchesOk) Then arrMaster(iPosMaster,COL_
ERROR) = arrMaster(iPosMaster,COL_ERROR) & ERR_BADMSPMETADATA & CSV
'Find patches in other states (than 'Applied')
'--------------------------------------------'Get a list from the global patches key
sSubKeyName = GetRegConfigKey(sProductCode,iContext,sSid,True) & "Patches\"
bPatchGlobalMultiSzBroken = NOT RegReadValue(hDefKeyGlobal,sSubKeyName,"AllP
atches",sAllPatches,REG_MULTI_SZ)

'Sanity Check on metadata integrity

If RegEnumKey(hDefKeyGlobal,sSubKeyName,arrKeys) AND CheckArray(arrKeys) The
n
bPatchGlobalOk = True
sTmpPatches = sAllPatches
For iKey = 0 To UBound(arrKeys)
If InStr(sTmpPatches,arrKeys(iKey))>0 Then
sTmpPatches = Replace(sTmpPatches,arrKeys(iKey),"")
End If 'InStr
Next 'iKey
'sTmpPatches should be an empty string now
sTmpPatches = Replace(sTmpPatches,Chr(34),"")
'Add the patches to the array
For iKey = 0 To UBound(arrKeys)
If Not InStr(sPatches,arrKeys(iKey))>0 Then
ReDim Preserve arrRegPatch(REGDIM1,UBound(arrRegPatch,2)+1)
sValue = ""
If RegReadDWordValue(hDefKeyGlobal,sSubKeyName&arrKeys(iKey),"St
ate",sValue) Then iState = CInt(sValue) Else iState = -1
arrRegPatch(0,UBound(arrRegPatch,2)) = GetExpandedGuid(arrKeys(i
Key))
arrRegPatch(1,UBound(arrRegPatch,2)) = iState
End If 'Not InStr
Next 'iKey
End If 'RegEnumKey
'Ensure sufficient array size
iMspMax = 0 : If CheckArray(arrRegPatch) Then iMspMax = UBound(arrRegPatch,2
)
If iMspMax > UBound(arrPatch,3) Then ReDim Preserve arrPatch(UBound(arrMaste
r),PATCH_COLUMNCOUNT,iMspMax)
'Find the patch details
ReadRegPatchDetails arrRegPatch,iPosMaster
End Sub 'FindRegPatches
'===============================================================================
========================
Sub ReadPatchDetails(Patches,iPosMaster)
Dim sTmpState
On Error Resume Next
Dim Patch,siSumInfo
Dim iMspCnt
iMspCnt = 0
For Each Patch in Patches
'Add patch data to array
'ProductCode:
arrPatch(iPosMaster,PATCH_PRODUCT,iMspCnt) = arrMaster(iPosMaster,COL_PR
ODUCTCODE)
'PatchCode:
arrPatch(iPosMaster,PATCH_PATCHCODE,iMspCnt) = Patch.PatchCode
'CSP flag:
arrPatch(iPosMaster,PATCH_CSP,iMspCnt) = True
'LocalPackage:
arrPatch(iPosMaster,PATCH_LOCALPACKAGE,iMspCnt) = Patch.PatchProperty("L
ocalPackage")

'LocalPackage availability:
arrPatch(iPosMaster,PATCH_CPOK,iMspCnt) = False
arrPatch(iPosMaster,PATCH_CPOK,iMspCnt) = oFso.FileExists(arrPatch(iPosM
aster,PATCH_LOCALPACKAGE,iMspCnt))
'DisplayName:
arrPatch(iPosMaster,PATCH_DISPLAYNAME,iMspCnt) = Patch.PatchProperty("Di
splayName")
'Ensure displayname is not blank
If IsEmpty(arrPatch(iPosMaster,PATCH_DISPLAYNAME,iMspCnt)) OR (arrPatch(
iPosMaster,PATCH_DISPLAYNAME,iMspCnt)=vbNullString) Then
'Fall back to registry mode detection
arrPatch(iPosMaster,PATCH_DISPLAYNAME,iMspCnt) = GetRegMspProperty(G
etCompressedGuid(Patch.PatchCode),iMspCnt,iPosMaster,arrMaster(iPosMaster,COL_CO
NTEXT),arrMaster(iPosMaster,COL_USERSID),"DisplayName")
End If 'IsEmpty(iPosMaster,PATCH_DISPLAYNAME,iMspCnt)
'InstallState:
Select Case (Patch.State)
Case MSIPATCHSTATE_APPLIED,MSIPATCHSTATE_SUPERSEDED
If Patch.State = MSIPATCHSTATE_APPLIED Then sTmpState = "App
lied" Else sTmpState = "Superseded"
arrPatch(iPosMaster,PATCH_PATCHSTATE,iMspCnt) = sTmpState
'Check stuff that is only useful/valid for patches in Applie
d/Superseded state
'Uninstallable
If Patch.PatchProperty("Uninstallable") = "1" Then
arrPatch(iPosMaster,PATCH_UNINSTALLABLE,iMspCnt) = "
Yes"
Else
arrPatch(iPosMaster,PATCH_UNINSTALLABLE,iMspCnt) = "
No"
End If
'Check cached package
If Not arrPatch(iPosMaster,PATCH_CPOK,iMspCnt) Then
arrMaster(iPosMaster,COL_ERROR) = arrMaster(iPosMaster,C
OL_ERROR) & _
ERR_CATEGORYERROR & "Local patch package '" & arrPatch(iPos
Master,PATCH_LOCALPACKAGE,iMspCnt) & _
"' missing for patch '." & arrPatch(iPosMaster,PATCH_PA
TCHCODE,iMspCnt) & "'" & CSV
Cachelog LOGPOS_REVITEM,LOGHEADING_NONE,ERR_CATEGORYERROR,"L
ocal patch package '" & arrPatch(iPosMaster,PATCH_LOCALPACKAGE,iMspCnt) & _
"' missing for patch '" & arrPatch(iPosMaster,PATCH_PAT
CHCODE,iMspCnt) & "'"
End If
'InstallDate
arrPatch(iPosMaster,PATCH_INSTALLDATE,iMspCnt) = Pat
ch.PatchProperty("InstallDate")
'MoreInfoUrl
arrPatch(iPosMaster,PATCH_MOREINFOURL,iMspCnt) = Pat
ch.PatchProperty("MoreInfoURL")
Case MSIPATCHSTATE_OBSOLETED
arrPatch(iPosMaster,PATCH_PATCHSTATE,iMspCnt) = "Obsoleted"
'InstallDate
arrPatch(iPosMaster,PATCH_INSTALLDATE,iMspCnt) = Pat
ch.PatchProperty("InstallDate")
'MoreInfoUrl
arrPatch(iPosMaster,PATCH_MOREINFOURL,iMspCnt) = Pat
ch.PatchProperty("MoreInfoURL")

Case MSIPATCHSTATE_REGISTERED
arrPatch(iPosMaster,PATCH_PATCHSTATE,iMspCnt) = "Registered"
'MoreInfoUrl
arrPatch(iPosMaster,PATCH_MOREINFOURL,iMspCnt) = Pat
ch.PatchProperty("MoreInfoURL")
Case Else
arrPatch(iPosMaster,PATCH_PATCHSTATE,iMspCnt) = "Unknown Pat
chstate"
End Select
'PatchTransform
arrPatch(iPosMaster,PATCH_TRANSFORM,iMspCnt) = GetRegMspProperty(GetComp
ressedGuid(Patch.PatchCode),iMspCnt,iPosMaster,arrMaster(iPosMaster,COL_CONTEXT)
,arrMaster(iPosMaster,COL_USERSID),"PatchTransform")
iMspCnt = iMspCnt + 1
Next 'Patch
End Sub 'ReadPatchDetails
'===============================================================================
========================
Sub ReadRegPatchDetails(arrRegPatch,iPosMaster)
Dim hDefKey
Dim sSid,sSubKeyName,sSubKeyNamePatch,sValue,sProductCode,sPatchCodeCompress
ed,sTmpState
Dim iContext
On Error Resume Next
Dim Patch,siSumInfo
Dim iMspCnt
iContext = arrMaster(iPosMaster,COL_CONTEXT)
sSid = arrMaster(iPosMaster,COL_USERSID)
sProductCode = arrMaster(iPosMaster,COL_PRODUCTCODE)
hDefKey = GetRegHive(iContext,sSid,True)
sSubKeyName = GetRegConfigKey(sProductCode,iContext,sSid,True) & "Patches\"
'iMspCnt = 0
'For Each Patch in Patches
For iMspCnt = 0 To UBound(arrRegPatch,2)
sPatchCodeCompressed = GetCompressedGuid(arrRegPatch(0,iMspCnt))
'Add patch data to array
'ProductCode:
arrPatch(iPosMaster,PATCH_PRODUCT,iMspCnt) = arrMaster(iPosMaster,COL_PR
ODUCTCODE)
'PatchCode:
arrPatch(iPosMaster,PATCH_PATCHCODE,iMspCnt) = arrRegPatch(0,iMspCnt)
'CSP flag:
arrPatch(iPosMaster,PATCH_CSP,iMspCnt) = True
'LocalPackage:
arrPatch(iPosMaster,PATCH_LOCALPACKAGE,iMspCnt) = GetRegMspProperty(sPat
chCodeCompressed,iMspCnt,iPosMaster,iContext,sSid,"LocalPackage")
arrPatch(iPosMaster,PATCH_CPOK,iMspCnt) = oFso.FileExists(arrPatch(iPosM
aster,PATCH_LOCALPACKAGE,iMspCnt))
'DisplayName:
arrPatch(iPosMaster,PATCH_DISPLAYNAME,iMspCnt) = GetRegMspProperty(sPatc
hCodeCompressed,iMspCnt,iPosMaster,iContext,sSid,"DisplayName")
'InstallState:
Select Case (arrRegPatch(1,iMspCnt))
Case MSIPATCHSTATE_APPLIED,MSIPATCHSTATE_SUPERSEDED
If arrRegPatch(1,iMspCnt) = MSIPATCHSTATE_APPLIED Then sTmpS

tate = "Applied" Else sTmpState = "Superseded"

arrPatch(iPosMaster,PATCH_PATCHSTATE,iMspCnt) = sTmpState
'Check stuff that is only useful/valid for patches in 'Appli
ed/Superseded' state
'Uninstallable
arrPatch(iPosMaster,PATCH_UNINSTALLABLE,iMspCnt) = GetRegMsp
Property(sPatchCodeCompressed,iMspCnt,iPosMaster,iContext,sSid,"Uninstallable")
'Check cached package
If Not arrPatch(iPosMaster,PATCH_CPOK,iMspCnt) Then
arrMaster(iPosMaster,COL_ERROR) = arrMaster(iPosMaster,C
OL_ERROR) & _
ERR_CATEGORYERROR & "Local patch package '" & arrPatch(iPos
Master,PATCH_LOCALPACKAGE,iMspCnt) & _
"' missing for patch '." & arrPatch(iPosMaster,PATCH_PA
TCHCODE,iMspCnt) & "'" & CSV
Cachelog LOGPOS_REVITEM,LOGHEADING_NONE,ERR_CATEGORYERROR,"L
ocal patch package '" & arrPatch(iPosMaster,PATCH_LOCALPACKAGE,iMspCnt) & _
"' missing for patch '" & arrPatch(iPosMaster,PATCH_PAT
CHCODE,iMspCnt) & "'"
End If
'InstallDate
arrPatch(iPosMaster,PATCH_INSTALLDATE,iMspCnt) = Get
RegMspProperty(sPatchCodeCompressed,iMspCnt,iPosMaster,iContext,sSid,"InstallDat
e")
'MoreInfoUrl
arrPatch(iPosMaster,PATCH_MOREINFOURL,iMspCnt) = Get
RegMspProperty(sPatchCodeCompressed,iMspCnt,iPosMaster,iContext,sSid,"MoreInfoUR
L")
Case MSIPATCHSTATE_OBSOLETED
arrPatch(iPosMaster,PATCH_PATCHSTATE,iMspCnt) = "Obsoleted"
'InstallDate
arrPatch(iPosMaster,PATCH_INSTALLDATE,iMspCnt) = Get
RegMspProperty(sPatchCodeCompressed,iMspCnt,iPosMaster,iContext,sSid,"InstallDat
e")
'MoreInfoUrl
arrPatch(iPosMaster,PATCH_MOREINFOURL,iMspCnt) = Get
RegMspProperty(sPatchCodeCompressed,iMspCnt,iPosMaster,iContext,sSid,"MoreInfoUR
L")
Case MSIPATCHSTATE_REGISTERED
arrPatch(iPosMaster,PATCH_PATCHSTATE,iMspCnt) = "Registered"
'MoreInfoUrl
arrPatch(iPosMaster,PATCH_MOREINFOURL,iMspCnt) = Get
RegMspProperty(sPatchCodeCompressed,iMspCnt,iPosMaster,iContext,sSid,"MoreInfoUR
L")
Case Else
arrPatch(iPosMaster,PATCH_PATCHSTATE,iMspCnt) = "Unknown Pat
chstate"
End Select
'PatchTransform
arrPatch(iPosMaster,PATCH_TRANSFORM,iMspCnt) = GetRegMspProperty(sPatchC
odeCompressed,iMspCnt,iPosMaster,iContext,sSid,"PatchTransform")
Next 'iMspCnt
End Sub 'ReadRegPatchDetails
'===============================================================================
========================
'Get a patch property without MSI API
Function GetRegMspProperty(sPatchCodeCompressed,iMspCnt,iPosMaster,iContext,sSid
,sProperty)
Dim hDefKey

Dim sProductCode,sSubKeyName,sValue
Dim siSumInfo
On Error Resume Next
GetRegMspProperty = ""
sProductCode = arrMaster(iPosMaster,COL_PRODUCTCODE)
'Default to 'Global' registry patch location
hDefKey = GetRegHive(iContext,sSid,True)
sSubKeyName = GetRegConfigKey(sProductCode,iContext,sSid,True) & "Patches\"
& sPatchCodeCompressed & "\"
sValue = ""
Select Case UCase(sProperty)
Case "DISPLAYNAME"
If RegReadStringValue(hDefKey,sSubKeyName,"DisplayName",sValue) Then Get
RegMspProperty = sValue
'Ensure displayname is not blank
If GetRegMspProperty="" Then
'Try to get the value from SummaryInformation stream. Use the PatchC
ode in case of failure
If arrPatch(iPosMaster,PATCH_CPOK,iMspCnt) Then
Err.Clear
Set siSumInfo = oMsi.SummaryInformation(arrPatch(iPosMaster,PATC
H_LOCALPACKAGE,iMspCnt),MSIOPENDATABASEMODE_READONLY)
If Not Err = 0 Then
GetRegMspProperty = GetExpandedGuid(sPatchCodeCompressed)
Else
GetRegMspProperty = siSumInfo.Property(PID_TITLE)
If GetRegMspProperty = vbNullString Then GetRegMspProperty =
GetExpandedGuid(sPatchCodeCompressed)
End If 'Err = 0
Else
GetRegMspProperty = GetExpandedGuid(sPatchCodeCompressed)
End If 'arrPatch(iPosMaster,PATCH_CPOK,iMspCnt)
End If 'GetRegMspProperty=""
Case "INSTALLDATE"
If RegReadStringValue(hDefKey,sSubKeyName,"Installed",sValue) Then GetRe
gMspProperty = sValue
Case "LOCALPACKAGE"
If iContext = MSIINSTALLCONTEXT_USERMANAGED Then iContext = MSIINSTALLCO
NTEXT_USERUNMANAGED
sSubKeyName = GetRegConfigPatchesKey(iContext,sSid,True) & sPatchCodeCom
pressed & "\"
If RegReadStringValue(hDefKey,sSubKeyName,"LocalPackage",sValue) Then Ge
tRegMspProperty = sValue
Case "MOREINFOURL"
If RegReadStringValue(hDefKey,sSubKeyName,"MoreInfoURL",sValue) Then Get
RegMspProperty = sValue
Case "PATCHTRANSFORM"
hDefKey = GetRegHive(iContext,sSid,False)
sSubKeyName = GetRegConfigKey(sProductCode,iContext,sSid,False) & "Patch
es\"
If RegReadStringValue(hDefKey,sSubKeyName,sPatchCodeCompressed,sValue) T
hen GetRegMspProperty = sValue
Case "UNINSTALLABLE"
GetRegMspProperty = "No"
If (RegReadDWordValue(hDefKey,sSubKeyName,"Uninstallable",sValue) AND sV
alue = "1") Then GetRegMspProperty = "Yes"
Case Else
End Select
End Function 'GetRegMspDisplayName

'===============================================================================
========================
'Check if usage of PatchesEx API calls are safe for use.
'PatchesEx requires WI 3.x or higher
'If PatchesEx API calls fail this triggers a fallback to direct registry detecti
on mode
Sub CheckPatchApi
Dim sActiveSub, sErrHnd
sActiveSub = "CheckPatchApi" : sErrHnd = ""
On Error Resume Next
Dim MspCheckEx, MspCheck
'Defaults
fPatchesExOk = False
fPatchesOk = False
iPatchesExError = 0
'WI 2.x specific check
Set MspCheck = oMsi.Patches(arrMaster(0,COL_PRODUCTCODE))
If Err = 0 Then fPatchesOk = True Else Err.Clear
'Ensure WI 3.x for PatchesEx checks
If iWiVersionMajor = 2 Then
Exit Sub
End If 'iWiVersionMajor = 2
'ROIScan error values for PatchesEx to allow to distinguish into unique erro
r messages
Set MspCheckEx = oMsi.PatchesEx(PRODUCTCODE_EMPTY,USERSID_EVERYONE,MSIINSTAL
LCONTEXT_ALL,MSIPATCHSTATE_ALL)
If Err <> 0 Then
iPatchesExError = 8
CheckError sActiveSub,sErrHnd
Else
fPatchesExOk = True
Exit Sub
End If 'Not Err <> 0
Set MspCheckEx = oMsi.PatchesEx(PRODUCTCODE_EMPTY,USERSID_EVERYONE,MSIINSTAL
LCONTEXT_USERMANAGED,MSIPATCHSTATE_ALL)
If Err <> 0 Then
iPatchesExError = iPatchesExError + MSIINSTALLCONTEXT_USERMANAGED
CheckError sActiveSub,sErrHnd
End If 'Not Err <> 0 - MSIINSTALLCONTEXT_USERMANAGED
Set MspCheckEx = oMsi.PatchesEx(PRODUCTCODE_EMPTY,USERSID_EVERYONE,MSIINSTAL
LCONTEXT_USERUNMANAGED,MSIPATCHSTATE_ALL)
If Err <> 0 Then
iPatchesExError = iPatchesExError + MSIINSTALLCONTEXT_USERUNMANAGED
CheckError sActiveSub,sErrHnd
End If 'Not Err <> 0 - MSIINSTALLCONTEXT_USERUNMANAGED
Set MspCheckEx = oMsi.PatchesEx(PRODUCTCODE_EMPTY,MACHINESID,MSIINSTALLCONTE
XT_MACHINE,MSIPATCHSTATE_ALL)
If Err <> 0 Then
iPatchesExError = iPatchesExError + MSIINSTALLCONTEXT_MACHINE
CheckError sActiveSub,sErrHnd
End If 'Not Err <> 0 - MSIINSTALLCONTEXT_MACHINE
Select Case iPatchesExError
Case 8 CacheLog LOGPOS_REVITEM,LOGHEADING_NONE,ERR_CATEGORYERROR,ERR_PA
TCHESEX & "MSIINSTALLCONTEXT_ALL" & DOT

Case 9 CacheLog LOGPOS_REVITEM,LOGHEADING_NONE,ERR_CATEGORYERROR,ERR_PA

TCHESEX & "MSIINSTALLCONTEXT_ALL & MSIINSTALLCONTEXT_USERMANAGED" & DOT
Case 10 CacheLog LOGPOS_REVITEM,LOGHEADING_NONE,ERR_CATEGORYERROR,ERR_PA
TCHESEX & "MSIINSTALLCONTEXT_ALL & MSIINSTALLCONTEXT_USERUNMANAGED" & DOT
Case 11 CacheLog LOGPOS_REVITEM,LOGHEADING_NONE,ERR_CATEGORYERROR,ERR_PA
TCHESEX & "MSIINSTALLCONTEXT_ALL & MSIINSTALLCONTEXT_USERMANAGED & MSIINSTALLCON
TEXT_USERUNMANAGED" & DOT
Case 12 CacheLog LOGPOS_REVITEM,LOGHEADING_NONE,ERR_CATEGORYERROR,ERR_PA
TCHESEX & "MSIINSTALLCONTEXT_ALL & MSIINSTALLCONTEXT_MACHINE" & DOT
Case 13 CacheLog LOGPOS_REVITEM,LOGHEADING_NONE,ERR_CATEGORYERROR,ERR_PA
TCHESEX & "MSIINSTALLCONTEXT_ALL & MSIINSTALLCONTEXT_USERMANAGED & MSIINSTALLCON
TEXT_MACHINE" & DOT
Case 14 CacheLog LOGPOS_REVITEM,LOGHEADING_NONE,ERR_CATEGORYERROR,ERR_PA
TCHESEX & "MSIINSTALLCONTEXT_ALL & MSIINSTALLCONTEXT_USERUNMANAGED & MSIINSTALLC
ONTEXT_MACHINE" & DOT
Case 15 CacheLog LOGPOS_REVITEM,LOGHEADING_NONE,ERR_CATEGORYERROR,ERR_PA
TCHESEX & "MSIINSTALLCONTEXT_ALL & MSIINSTALLCONTEXT_USERMANAGED & MSIINSTALLCON
TEXT_USERUNMANAGED & MSIINSTALLCONTEXT_MACHINE" & DOT
Case Else
End Select
End Sub 'CheckPatchApi
'===============================================================================
========================
'Gather details from the cached patch package
Sub AddDetailsFromPackage
On Error Resume Next
Dim
Dim
Dim
Dim
Dim
Dim
Dim

Element,Elements,Key,XmlDoc,Msp,SumInfo,Record
dicMspSequence,dicMspTmp
sFamily,sSeq,sMsp,sBaseSeqShort
iPosMaster,iPosPatch,iCnt,iIndex
fAdd
qView
arrTitle,arrTmpFam,arrTmpSeq,arrVer

'Defaults
Set XmlDoc = CreateObject("Microsoft.XMLDOM")
Set dicMspSequence = CreateObject("Scripting.Dictionary")
Set dicMspTmp = CreateObject("Scripting.Dictionary")
'Initialize the patch index dictionary to assign each distinct PatchCode an
index number
iCnt = -1
For iPosMaster = 0 To UBound(arrMaster)
For iPosPatch = 0 to UBound(arrPatch,3)
If Not (IsEmpty (arrPatch(iPosMaster,PATCH_PATCHCODE,iPosPatch))) AN
D (arrPatch(iPosMaster,PATCH_CSP,iPosPatch)) Then
If NOT dicMspIndex.Exists(arrPatch(iPosMaster,PATCH_PATCHCODE,iP
osPatch)) Then
iCnt=iCnt+1
dicMspIndex.Add arrPatch(iPosMaster,PATCH_PATCHCODE,iPosPatc
h),iCnt
dicMspTmp.Add arrPatch(iPosMaster,PATCH_PATCHCODE,iPosPatch)
,arrPatch(iPosMaster,PATCH_LOCALPACKAGE,iPosPatch)
End If
End If
Next 'iPosPatch
Next 'iPosMaster
'Initialize the PatchFiles array
ReDim arrMspFiles(dicMspIndex.Count-1,MSPFILES_COLUMNCOUNT-1)

'Open the .msp for reading to add the data to the array
For Each Key in dicMspTmp.Keys
iPosPatch = dicMspIndex.Item(Key)
sMsp = dicMspTmp.Item(Key)
Err.Clear
Set Msp = oMsi.OpenDatabase (sMsp,MSIOPENDATABASEMODE_PATCHFILE)
Set SumInfo = Msp.SummaryInformation
If Not Err = 0 Then
'An error at this points indicates a severe issue
Cachelog LOGPOS_REVITEM,LOGHEADING_NONE,ERR_CATEGORYERROR,ERR_MSPOPE
NFAILED & sMsp
Else
'LocalPackage
arrMspFiles(iPosPatch,MSPFILES_LOCALPACKAGE)=sMsp
'PatchCode
arrMspFiles(iPosPatch,MSPFILES_PATCHCODE)=Key
'PatchTargets
arrMspFiles(iPosPatch,MSPFILES_TARGETS)=SumInfo.Property(PID_TEMPLAT
E)
'PatchTables
arrMspFiles(iPosPatch,MSPFILES_TABLES)=GetPatchTables(Msp)
'KB
If InStr(arrMspFiles(iPosPatch,MSPFILES_TABLES),"MsiPatchMetadata")>
0 Then
Set qView = Msp.OpenView("SELECT `Property`,`Value` FROM MsiPatc
hMetadata WHERE `Property`='KBArticle Number'")
qView.Execute : Set Record = qView.Fetch()
If Not Record Is Nothing Then
arrMspFiles(iPosPatch,MSPFILES_KB) = UCase(Record.StringData
(2))
arrMspFiles(iPosPatch,MSPFILES_KB) = Replace(arrMspFiles(iPo
sPatch,MSPFILES_KB),"KB","")
Else
arrMspFiles(iPosPatch,MSPFILES_KB) = ""
End If
qView.Close
'StdPackageName
Set qView = Msp.OpenView("SELECT `Property`,`Value` FROM MsiPatc
hMetadata WHERE `Property`='StdPackageName'")
qView.Execute : Set Record = qView.Fetch()
If Not Record Is Nothing Then
arrMspFiles(iPosPatch,MSPFILES_PACKAGE) = Record.StringData(
2)
Else
arrMspFiles(iPosPatch,MSPFILES_PACKAGE) = ""
End If
qView.Close
Else
arrMspFiles(iPosPatch,MSPFILES_KB) = ""
arrMspFiles(iPosPatch,MSPFILES_PACKAGE) = ""
End If
arrTitle = Split(SumInfo.Property(PID_TITLE),";")
If arrMspFiles(iPosPatch,MSPFILES_KB) = "" Then
If UBound(arrTitle)>0 Then
arrMspFiles(iPosPatch,MSPFILES_KB) = arrTitle(1)
End If
End If
If arrMspFiles(iPosPatch,MSPFILES_PACKAGE) = "" Then
If UBound(arrTitle)>0 Then
arrMspFiles(iPosPatch,MSPFILES_PACKAGE) = arrTitle(1)

End If
End If
'PatchSequence & PatchFamily
If InStr(arrMspFiles(iPosPatch,MSPFILES_TABLES),"MsiPatchSequence")>
0 Then
Set qView = Msp.OpenView("SELECT `PatchFamily`,`Sequence`,`Attri
butes` FROM MsiPatchSequence")
qView.Execute : Set Record = qView.Fetch()
If Not Record Is Nothing Then
Do Until Record Is Nothing
arrMspFiles(iPosPatch,MSPFILES_FAMILY) = arrMspFiles(iPo
sPatch,MSPFILES_FAMILY)&Record.StringData(1)&","
arrMspFiles(iPosPatch,MSPFILES_SEQUENCE) = arrMspFiles(i
PosPatch,MSPFILES_SEQUENCE)&Record.StringData(2)&","
arrMspFiles(iPosPatch,MSPFILES_ATTRIBUTE) = Record.Strin
gData(3)
Set Record = qView.Fetch()
Loop
arrMspFiles(iPosPatch,MSPFILES_FAMILY) = RTrimComma(arrMspFi
les(iPosPatch,MSPFILES_FAMILY))
arrMspFiles(iPosPatch,MSPFILES_SEQUENCE) = RTrimComma(arrMsp
Files(iPosPatch,MSPFILES_SEQUENCE))
Else
arrMspFiles(iPosPatch,MSPFILES_FAMILY) = ""
arrMspFiles(iPosPatch,MSPFILES_SEQUENCE) = "0"
arrMspFiles(iPosPatch,MSPFILES_ATTRIBUTE) = "0"
End If
qView.Close
Else
arrMspFiles(iPosPatch,MSPFILES_FAMILY) = ""
arrMspFiles(iPosPatch,MSPFILES_SEQUENCE) = "0"
arrMspFiles(iPosPatch,MSPFILES_ATTRIBUTE) = "0"
End If
End If
Next 'Key
'Copy the collected data to the arrPatch array
For iPosMaster = 0 To UBound(arrMaster)
dicMspSequence.RemoveAll
sBaseSeqShort = ""
arrVer = Split(arrMaster(iPosMaster,COL_PRODUCTVERSION),".")
If UBound(arrVer)>1 Then sBaseSeqShort = arrVer(2)
For iPosPatch = 0 to UBound(arrPatch,3)
If Not (IsEmpty (arrPatch(iPosMaster,PATCH_PATCHCODE,iPosPatch))) AN
D (arrPatch(iPosMaster,PATCH_CSP,iPosPatch)) Then
iIndex = -1
iIndex = dicMspIndex.Item(arrPatch(iPosMaster,PATCH_PATCHCODE,iP
osPatch))
If NOT iIndex = -1 Then
'KB field
arrPatch(iPosMaster,PATCH_KB,iPosPatch) = arrMspFiles(iIndex
,MSPFILES_KB)
'StdPackageName
arrPatch(iPosMaster,PATCH_PACKAGE,iPosPatch) = arrMspFiles(i
Index,MSPFILES_PACKAGE)
'PatchSequenece
Set arrTmpSeq = Nothing
arrTmpSeq = Split(arrMspFiles(iIndex,MSPFILES_SEQUENCE),",")
arrPatch(iPosMaster,PATCH_SEQUENCE,iPosPatch) = arrTmpSeq(0)
'PatchFamily

Set arrTmpFam = Nothing

arrTmpFam = Split(arrMspFiles(iIndex,MSPFILES_FAMILY),",")
'dicMspSequence
'Only add to the family sequence number if it's marked to su
persede earlier
If arrMspFiles(iIndex,MSPFILES_ATTRIBUTE) = "1" Then
iCnt = -1
For iCnt = 0 To UBound(arrTmpSeq)
sFamily="" : sSeq=""
sFamily = arrTmpFam(iCnt)
sSeq = arrTmpSeq(iCnt)
fAdd = False
'Don't care if it's not higher than the current base
line
Select Case Len(sSeq)
Case 4
fAdd = (sSeq > sBaseSeqShort)
Case Else
fAdd = (sSeq > arrMaster(iPosMaster, COL_PRODUCT
VERSION))
End Select
If fAdd Then
If dicMspSequence.Exists(sFamily) Then
If (sSeq > dicMspSequence.Item(sFamily)) The
n dicMspSequence.Item(sFamily)=sSeq
Else
dicMspSequence.Add sFamily,sSeq
End If
End If 'fAdd
Next 'iCnt
End If 'Attributes = 1
' update the global PatchLevel dic
iCnt = -1
For iCnt = 0 To UBound(arrTmpSeq)
sFamily="" : sSeq=""
sFamily = arrTmpFam(iCnt)
sSeq = arrTmpSeq(iCnt)
If dicPatchLevel.Exists(sFamily) Then
If (sSeq > dicPatchLevel.Item(sFamily)) Then dicPatc
hLevel.Item(sFamily) = sSeq
Else
dicPatchLevel.Add sFamily, sSeq
End If
Next 'iCnt
End If 'iIndex
End If
Next 'iPosPatch
'Add the sequence data to the master array
For Each Key in dicMspSequence.Keys
arrMaster(iPosMaster,COL_PATCHFAMILY)=arrMaster(iPosMaster,COL_PATCH
FAMILY)&Key&":"&dicMspSequence.Item(Key)&","
Next 'Key
RTrimComma arrMaster(iPosMaster,COL_PATCHFAMILY)
Next 'iPosMaster
End Sub 'AddDetailsFromPackage
'===============================================================================
========================
'Return the tables of a given .msp file

Function GetPatchTables(Msp)
Dim ViewTables,Table
Dim sTables
On Error Resume Next
sTables = ""
Set Table = Nothing
Set ViewTables = Msp.OpenView("SELECT `Name` FROM `_Tables` ORDER BY `Name`"
)
ViewTables.Execute
Do
Set Table = ViewTables.Fetch
If Table Is Nothing then Exit Do
sTables = sTables&Table.StringData(1)&","
Loop
ViewTables.Close
GetPatchTables=RTrimComma(sTables)
End Function 'GetPatchTables
'===============================================================================
========================
'Module ARP - Add Remove Programs
'===============================================================================
========================
'Build array with data from Add/Remove Programs.
'This is essential for Office 2007 family applications
Sub ARPData
On Error Resume Next
'Filter for >O12 products since the logic is proprietary to >O12
FindArpParents
AddArpParentsToMaster
AddSystemComponentFlagToMaster
ValidateSystemComponentProducts
FindArpConfigMsi
End Sub 'ARPData
'===============================================================================
========================
'Identify the core configuration .msi for multi .msi ARP entries
Sub FindArpConfigMsi
Dim n, i, k
Dim hDefKey
Dim sSubKeyName, sCurKey, sName, sValue, sArpProd, sArpProdWW
Dim arrKeys, arrValues, arrTmpArp
Dim ProdId
On Error Resume Next
'Get Reg_Multi_Sz 'PackageIds' entry from 'uninstall' key
'Do an InStr compare on each entry against ARP keyname
'The identified position matches the position of the Reg_Multi_Sz 'ProductCo
des'
hDefKey = HKEY_LOCAL_MACHINE
If Not CheckArray(arrArpProducts) Then
If Not UBound(arrArpProducts) = -1 Then
Cachelog LOGPOS_REVITEM,LOGHEADING_NONE,ERR_CATEGORYERROR,ERR_NOARRA
Y& " Terminated ARP detection"

End If
Err.Clear
Exit Sub
End If
For n = 0 To UBound(arrArpProducts)
k = -1
sArpProd = arrArpProducts(n,COL_CONFIGNAME)
'Server products do not follow the 'WW' naming logic
If Not InStr(sArpProd,".") > 0 Then sArpProdWW = sArpProd & "WW"
sName = "PackageIds"
If UCase(Left(sArpProd,9))="OFFICE14." OR UCase(Left(sArpProd,9))="OFFIC
E15." Then
sName = "PackageRefs"
sArpProdWW = Right(sArpProd,Len(sArpProd)-9) & "WW"
End If
sSubKeyName = REG_ARP & arrArpProducts(n,COL_CONFIGNAME) & "\"
If RegReadMultiStringValue(hDefKey,sSubKeyName,sName,arrValues) Then
i = 0
'The target product is usually at the last entry of the array
'Check last entry first. If this fails search the array
If InStr(UCase(arrValues(UBound(arrValues))),UCase(sArpProdWW)) > 0
Then
k = UBound(arrValues)
ElseIf InStr(UCase(arrValues(UBound(arrValues))),UCase(sArpProd)) >
0 Then
k = UBound(arrValues)
Else
For Each ProdId in arrValues
If InStr(UCase(ProdID),UCase(sArpProdWW)) > 0 Then
k = i
Exit For
End If 'InStr
i = i + 1
Next 'ProdId
'Before failing completely try without the 'WW' extension
If k = - 1 Then
For Each ProdId in arrValues
If InStr(UCase(ProdID),UCase(sArpProd)) > 0 Then
k = i
Exit For
End If 'InStr
i = i + 1
Next 'ProdId
End If 'k = -1
End If 'InStr
Else
'Cachelog LOGPOS_REVITEM,LOGHEADING_NONE,ERR_CATEGORYERROR,ERR_NOARR
AY
End If 'RegReadMultiStringValue
If Not k = -1 Then 'found a matching 'Config Guid' for the product
'Add the Config PackageID to the array
arrArpProducts(n,COL_CONFIGPACKAGEID) = arrValues(k)
End If 'k
Next 'n
End Sub 'FindArpConfigMsi
'===============================================================================
========================

'Check if every Office product flagged as 'SystemComponent = 1' has a parent reg
istered
Sub ValidateSystemComponentProducts
Dim n
On Error Resume Next
For n = 0 To UBound (arrMaster)
If Not Err=0 Then Exit For
If arrMaster(n,COL_ISOFFICEPRODUCT) Then
If (NOT arrMaster(n, COL_SYSTEMCOMPONENT) = 0) AND (arrMaster(n, CO
L_ARPPARENTCOUNT) = 0) Then
'Identified orphaned product
'Log warning except for C2R, AER or Rosebud
Select Case Mid(arrMaster(n, COL_PRODUCTCODE), 11, 4)
Case "0010", "00B9", "008C", "008F", "007E"
' don't add warning
Case Else
Cachelog LOGPOS_REVITEM,LOGHEADING_NONE,ERR_CATEGORYNOTE,ERR
_ORPHANEDITEM & DSV & arrMaster(n,COL_PRODUCTNAME) & DSV & arrMaster(n,COL_PRODU
CTCODE)
arrMaster(n,COL_NOTES) = arrMaster(n,COL_NOTES) & ERR_CATEGO
RYNOTE & ERR_ORPHANEDITEM & CSV
End Select
End If 'Not arrMaster
End If 'IsOfficeProduct
Next 'n
End Sub
'===============================================================================
========================
'Adds the ARP config product information to the individual products
Sub AddArpParentsToMaster
Dim i, n
On Error Resume Next
For n = 0 To UBound(arrMaster)
If Not Err=0 Then Exit For
If arrMaster(n,COL_ISOFFICEPRODUCT) Then
For i = 0 To UBound(arrArpProducts)
If InStr(arrArpProducts(i,COL_ARPALLPRODUCTS),arrMaster(n,COL_PR
ODUCTCODE)) > 0 Then
'add COL_ARPPARENTCOUNT COL_ARPPARENTS
arrMaster(n,COL_ARPPARENTCOUNT) = arrMaster(n,COL_ARPPARENTC
OUNT) + 1
arrMaster(n,COL_ARPPARENTS) = arrMaster(n,COL_ARPPARENTS) &
"," & arrArpProducts(i,COL_CONFIGNAME)
End If
Next 'i
End If
Next 'n
End Sub
'===============================================================================
========================
'Add applications 'SystemComponent' flag from ARP to Master array
Sub AddSystemComponentFlagToMaster
Dim sValue, sSubKeyName
Dim n
On Error Resume Next

For n = 0 To UBound(arrMaster)
If Not Err=0 Then Exit For
sSubKeyName = REG_ARP & arrMaster(n,COL_PRODUCTCODE) & "\"
If RegReadDWordValue(HKEY_LOCAL_MACHINE,sSubKeyName,"SystemComponent",sV
alue) Then
arrMaster(n,COL_SYSTEMCOMPONENT) = sValue
Else
arrMaster(n,COL_SYSTEMCOMPONENT) = 0
End If 'RegReadDWordValue "SystemComponent"
Next 'n
End Sub
'===============================================================================
========================
'Find parent entries from 'Add/Remove Programs' for Office applications which ar
e flagged as 'Systemcomponent'
'ARP entries flagged as Systemcomponent will not display under 'Add/Remove Progr
ams'
'From Office 2007 on ARP groups the multi MSI configuration together.
Sub FindArpParents
Dim ArpProd, ProductCode, Key, dicKey
Dim n, i, j, iMaxVal, iArpCnt, iPosMaster, iLoop
Dim bNoSysComponent, bOConfigEntry, fFoundConfigProductCode, fUninstallStrin
g
Dim hDefKey
Dim sSubKeyName, sCurKey, sName, sValue, sNames, sArpProductName, sRegArp
Dim arrKeys, arrValues, arrTmpArp, arrNames, arrTypes
Dim dicArpTmp
Dim tModulStart, tModulEnd
On Error Resume Next
iLoop = 0 : iMaxVal = 0: iArpCnt = 0 : Redim arrTmpArp(-1)
Set dicArpTmp = CreateObject("Scripting.Dictionary")
While iLoop < 2
iLoop = iLoop + 1
hDefKey = HKEY_LOCAL_MACHINE
sRegArp = REG_ARP
If iLoop = 2 Then sRegArp = REG_C2RVIRT_HKLM & REG_ARP
sSubKeyName = sRegArp
Set dicMissingChild = CreateObject("Scripting.Dictionary")
If RegEnumKey (hDefKey,sSubKeyName,arrKeys) Then
For Each ArpProd in arrKeys
sCurKey = sSubKeyName & ArpProd & "\"
bNoSysComponent = True
bOConfigEntry = False
sNames = "" : Redim arrNames(-1) : Redim arrTypes(-1)
If RegEnumValues(hDefKey,sCurKey,arrNames,arrTypes) Then sNames
= Join(arrNames)
If InStr(sNames,"PackageIds") OR InStr(sNames,"PackageRefs") OR
UCase(Left(ArpProd, 9)) = "OFFICE14." OR UCase(Left(ArpProd, 9)) = "OFFICE15."
Then bOConfigEntry = True
If bOConfigEntry Then
sName = "SystemComponent"
'If RegDWORD 'SystemComponent' = 1 then it's not showing up
in ARP
If RegReadDWordValue(hDefKey,sCurKey,sName,sValue) Then
If CInt(sValue) = 1 Then

CacheLog LOGPOS_REVITEM, LOGHEADING_NONE, ERR_CATEGO

RYWARN, "Office configuration entry that has been hidden from ARP: " & ArpProd
End If
End If 'RegReadValue "SystemComponent"
If bOConfigEntry Then
' found ARP Parent entry
' only care if it's not a 'helper' entry like it's creat
ed by OffScrub
If UBound(arrNames) > 5 OR InStr(UCase(ArpProd), ".MONDO
") > 0 Then
Redim Preserve arrTmpArp(iArpCnt)
arrTmpArp(iArpCnt) = ArpProd
If NOT dicArpTmp.Exists(sCurKey) Then dicArpTmp.Add
sCurKey, ArpProd
iArpCnt = iArpCnt + 1
Cachelog LOGPOS_RAW,LOGHEADING_NONE,Null,"ARP Entry:
" & ArpProd
Else
Cachelog LOGPOS_RAW,LOGHEADING_NONE,Null,"Bad ARP En
try: " & ArpProd
Cachelog LOGPOS_REVITEM,LOGHEADING_NONE,ERR_CATEGORY
ERROR,ERR_OFFSCRUB_TERMINATED
Cachelog LOGPOS_REVITEM,LOGHEADING_NONE,ERR_CATEGORY
ERROR,ERR_BADARPMETADATA & GetHiveString(hDefKey) & "\" & sCurKey
End If
End If
Else
'
'Handled in Click2Run V2 below
End If
Next 'ArpProd
End If 'RegEnumKey
Wend
' initialize arrArpProducts
If iArpCnt > 0 Then
iArpCnt = iArpCnt - 1
Redim arrArpProducts(iArpCnt,ARP_CHILDOFFSET)
Else
Redim arrArpProducts(-1)
End If
' copy the identified configuration parents to the actual target array and a
dd additional fields
n = 0
'For Each ArpProd in arrTmpArp
For Each dicKey in dicArpTmp.Keys
' get the MultiString entry 'ProductCodes' from 'HKEY_LOCAL_MACHINE\SOFTWARE
\Microsoft\Windows\CurrentVersion\Uninstall\<Product>'
ArpProd = dicArpTmp.Item(dicKey)
sName = "ProductCodes"
'sSubKeyName = sRegArp & ArpProd & "\"
sSubKeyName = dicKey
If RegReadMultiStringValue(hDefKey,sSubKeyName,sName,arrValues) Then
' fill the array set
arrArpProducts(n,COL_CONFIGNAME) = ArpProd
arrArpProducts(n, COL_CONFIGINSTALLTYPE) = "MSI"
RegReadStringValue hDefKey, sSubKeyName, "DisplayVersion", sValue
arrArpProducts(n, ARP_PRODUCTVERSION) = sValue
If UBound (arrValues) + ARP_CHILDOFFSET > iMaxVal Then
iMaxVal = UBound (arrValues)+ARP_CHILDOFFSET
Redim Preserve arrArpProducts(iArpCnt,iMaxVal)

End If 'UBound(arrValues)
j = ARP_CHILDOFFSET
For Each ProductCode in arrValues
arrArpProducts(n,COL_ARPALLPRODUCTS) = arrArpProducts(n,COL_ARPA
LLPRODUCTS) & ProductCode
arrArpProducts(n,j) = ProductCode
' validate that the product is installed
If NOT dicProducts.Exists(ProductCode) Then
Cachelog LOGPOS_REVITEM,LOGHEADING_NONE,ERR_CATEGORYERROR,ER
R_MISSINGCHILD&"Config Product: "&ArpProd& CSV & "Missing Product: "&ProductCode
If NOT dicMissingChild.Exists(ProductCode) Then dicMissingCh
ild.Add ProductCode,ArpProd
End If
j = j + 1
Next 'ProductCode
' identify the config ProductCode
fFoundConfigProductCode = False
sArpProductName = ""
sArpProductName = GetArpProductName(ArpProd)
For Each ProductCode in arrValues
iPosMaster = GetArrayPosition(arrMaster,ProductCode)
If NOT iPosMaster = -1 Then
If LCase(Trim(sArpProductName)) = LCase(Trim(arrMaster(GetAr
rayPosition(arrMaster,ProductCode),COL_PRODUCTNAME))) Then
arrArpProducts(n,ARP_CONFIGPRODUCTCODE) = ProductCode
fFoundConfigProductCode = True
Exit For
End If
End If
Next 'ProductCode
If NOT fFoundConfigProductCode Then
i = 0
For Each ProductCode in arrValues
If (NOT Mid(ProductCode,11,4)="002A") AND (Mid(ProductCode,1
6,4)="0000") _
OR (Mid(ProductCode,12,2)="10") _
Then
i = i + 1
arrArpProducts(n,ARP_CONFIGPRODUCTCODE) = ProductCode
End If
Next 'ProductCode
' ensure to not have ambigious hits
If i > 1 Then
Dim MsiDb,Record
Dim qView
For Each ProductCode in arrValues
If (NOT Mid(ProductCode,11,4)="002A") AND (Mid(ProductCo
de,16,4)="0000") _
OR (Mid(ProductCode,12,2)="10") _
Then
Set MsiDb = oMsi.OpenDatabase(arrMaster(GetArrayPosi
tion(arrMaster,ProductCode),COL_CACHEDMSI),MSIOPENDATABASEMODE_READONLY)
Set qView = MsiDb.OpenView("SELECT * FROM Proper
ty WHERE `Property` = 'SetupExeArpId'")
qView.Execute
Set Record = qView.Fetch()
If Not Record Is Nothing Then
arrArpProducts(n,ARP_CONFIGPRODUCTCODE) = Pr
oductCode
qView.Close

Exit For
End If 'Is Nothing
'SetupExeArpId'
End If
Next 'ProductCode
End If
End If 'NOT fFoundConfigProductCode
Else
' handle Click2Run
arrArpProducts(n,COL_CONFIGNAME) = ArpProd
arrArpProducts(n, COL_CONFIGINSTALLTYPE) = "C2R"
If 1 + ARP_CHILDOFFSET > iMaxVal Then
iMaxVal = 1 + ARP_CHILDOFFSET
Redim Preserve arrArpProducts(iArpCnt, iMaxVal)
End If
' V1
If RegEnumKey (HKLM, REG_ARP, arrKeys) Then
For Each Key in arrKeys
If Len(Key)=38 Then
If Mid(Key,11,4) = "006D" Then
arrArpProducts(n,COL_ARPALLPRODUCTS) = Key
arrArpProducts(n,ARP_CHILDOFFSET) = Key
arrArpProducts(n,ARP_CONFIGPRODUCTCODE) = Key
End If
End If
Next 'Key
End If
' V2
iPosMaster = GetArrayPositionFromPattern(arrMaster, "150000-000F-000
0-0000-0000000FF1CE}")
If iPosMaster = -1 Then iPosMaster = GetArrayPositionFromPattern(arr
Master, "150000-000F-0000-1000-0000000FF1CE}")
If InStr(UCase(ArpProd), ".MONDO") > 0 Then
arrArpProducts(n, COL_CONFIGINSTALLTYPE) = "VIRTUAL"
If NOT iPosMaster = -1 Then
arrArpProducts(n,ARP_CONFIGPRODUCTCODE) = arrMaster(iPosMast
er, COL_PRODUCTCODE)
End If
If UBound (arrMVProducts) + ARP_CHILDOFFSET > iMaxVal Then
iMaxVal = UBound (arrMVProducts) + ARP_CHILDOFFSET
Redim Preserve arrArpProducts(iArpCnt,iMaxVal)
End If 'UBound(arrMVProducts)
' fill the array set
j = ARP_CHILDOFFSET
i = 0
For i = 0 To UBound(arrMVProducts)
'If arrMaster(i, COL_VIRTUALIZED) = 1 Then
arrArpProducts(n, COL_ARPALLPRODUCTS) = arrArpProducts(n
, COL_ARPALLPRODUCTS) & arrMVProducts(i, COL_PRODUCTCODE)
arrArpProducts(n, j) = arrMVProducts(i, COL_PRODUCTCODE)
j = j + 1
'End If
Next 'i
Else
If NOT iPosMaster = -1 Then
arrArpProducts(n,COL_ARPALLPRODUCTS) = arrMaster(iPosMaster,
COL_PRODUCTCODE)
arrArpProducts(n,ARP_CHILDOFFSET) = arrMaster(iPosMaster, CO
L_PRODUCTCODE)

arrArpProducts(n,ARP_CONFIGPRODUCTCODE) = arrMaster(iPosMast
er, COL_PRODUCTCODE)
End If
End If
End If 'RegReadValue "ProductCodes"
n = n + 1
Next 'ArpProd
End Sub 'FindArpParents
'===============================================================================
========================
'Module OSPP - Licensing Data
'===============================================================================
========================
'Use WMI to query the license details for installed Office products
'The license details of the products are mapped to the OSPP data based on the "C
onfiguration Productname"
Sub OsppCollect
Dim iArpCnt, iPosMaster, iLicCnt, iLicPos, iLic, iVPCnt, iVersionMajor
Dim sText, sOsppLicenses, sPossibleSkus, sPossibleSkusFull, sTmp, sXmlLogLin
e
Dim arrLicData
If CheckArray(arrArpProducts) Then
For iArpCnt = 0 To UBound(arrArpProducts)
sOsppLicenses = ""
sXmlLogLine = ""
'Get the link to the master array
iPosMaster = GetArrayPosition(arrMaster,arrArpProducts(iArpCnt,ARP_C
ONFIGPRODUCTCODE))
If iPosMaster > -1 Then
iLicCnt = 0
'OSPP is first used by O14
iVersionMajor = CInt(GetVersionMajor(arrMaster(iPosMaster, COL_P
RODUCTCODE)))
If (arrMaster(iPosMaster, COL_ISOFFICEPRODUCT)) AND iVersionMajo
r > 13 Then
'Get the Config Productname
sText = "" : sText = arrArpProducts(iArpCnt,COL_CONFIGNAME)
If InStr(sText,".") > 0 Then sText = Mid(sText, InStr(sText,
".") + 1)
'A list of all possible licenses this product can use is sto
red in sPossibleSkus
sPossibleSkus = ""
sXmlLogLine = ""
'Loop all licenses
iLicCnt = GetLicCnt(iPosMaster, iVersionMajor, sText, sPossi
bleSkus, sPossibleSkusFull)
If iLicCnt > 0 Then
sOsppLicenses = "Possible Licenses;" & Mid(sPossibleSkus
, 3)
'List installed licenses (ProductKeyID <> "")
iLicPos = 0
sXmlLogLine = ""
For iLic = 1 To iLicCnt
arrLicData = GetLicenseData(iPosMaster,CInt(GetVersi
onMajor(arrMaster(iPosMaster,COL_PRODUCTCODE))),sText,iLicPos,sPossibleSkusFull)

If InStr(sPossibleSkusFull, arrLicData(OSPP_NAME)) >

0 Then AddLicXmlString sXmlLogLine, arrLicData
If arrLicData(OSPP_PRODUCTKEYID) <> "" Then AddLicTx
tString sOsppLicenses, arrLicData
Next 'iLic
arrMaster(iPosMaster, COL_OSPPLICENSEXML) = sXmlLogLine
arrMaster(iPosMaster, COL_OSPPLICENSE) = sOsppLicenses
End If 'iLicCnt > 0
End If 'VersionMajor > 14
End If 'iPosMaster > -1
Next 'iArpCnt
End If 'arrArpProducts
If UBound(arrVirt2Products) > -1 Then
For iVPCnt = 0 To UBound(arrVirt2Products, 1)
sText = "" : sText = arrVirt2Products(iVPCnt, VIRTPROD_CONFIGNAME)
sText = Replace(sText, "O365", "")
sText = Replace(sText, "Volume", "")
sText = Replace(sText, "Retail", "")
iVersionMajor = CInt(Left(arrVirt2Products(iVPCnt, VIRTPROD_PRODUCTV
ERSION), 2))
'A list of all possible licenses this product can use is stored in s
PossibleSkus
sPossibleSkus = ""
sXmlLogLine = ""
'Loop all licenses
iLicCnt = GetLicCnt(-1, iVersionMajor, sText, sPossibleSkus, sPossib
leSkusFull)
If iLicCnt > 0 Then
sOsppLicenses = "Possible Licenses;" & Mid(sPossibleSkus, 3)
'List installed licenses (ProductKeyID <> "")
iLicPos = 0
sXmlLogLine = ""
For iLic = 1 To iLicCnt
arrLicData = GetLicenseData(-1, iVersionMajor, sText, iLicPo
s, sPossibleSkusFull)
If InStr(sPossibleSkusFull, arrLicData(OSPP_NAME)) > 0 Then
AddLicXmlString sXmlLogLine, arrLicData
If arrLicData(OSPP_PRODUCTKEYID) <> "" Then AddLicTxtString
sOsppLicenses, arrLicData
Next 'iLic
arrVirt2Products(iVPCnt, VIRTPROD_OSPPLICENSEXML) = sXmlLogLine
arrVirt2Products(iVPCnt, VIRTPROD_OSPPLICENSE) = sOsppLicenses
End If 'iLicCnt
Next 'iVPCnt
End If 'arrVirt2Products
End Sub 'OsppCollect
'===============================================================================
========================
Function GetLicenseStateString (iState)
Dim sTmp
sTmp =
Select
Case 0
Case 1
Case 2
Case 3

""
Case iState
: sTmp = "UNLICENSED"
: sTmp = "LICENSED"
: sTmp = "OOB GRACE"
: sTmp = "OOT GRACE"

Case 4 : sTmp = "NON GENUINE GRACE"

Case 5 : sTmp = "NOTIFICATIONS"
Case Else : sTmp = "UNKNOWN"
End Select
GetLicenseStateString = sTmp
End Function 'GetLicenseStateString
'===============================================================================
========================
Sub AddLicXmlString (sXmlLogLine, arrLicData)
Dim sTmp
If NOT sXmlLogLine = "" Then sXmlLogLine = sXmlLogLine & vbCrLf
If arrLicData(OSPP_PRODUCTKEYID) <> "" Then sTmp = "TRUE" Else sTmp = "FALSE
"
sXmlLogLine = sXmlLogLine & "<License"
sXmlLogLine = sXmlLogLine & " IsActive=" & chr(34) & sTmp & chr(34)
sXmlLogLine = sXmlLogLine & " Name=" & chr(34) & arrLicData(OSPP_NAME) & chr
(34)
sXmlLogLine = sXmlLogLine & " Description=" & chr(34) & arrLicData(OSPP_DESC
RIPTION) & chr(34)
sXmlLogLine = sXmlLogLine & " Family=" & chr(34) & arrLicData(OSPP_LICENSEFA
MILY) & chr(34)
sXmlLogLine = sXmlLogLine & " Status=" & chr(34) & arrLicData(OSPP_LICENSEST
ATUS) & chr(34)
sXmlLogLine = sXmlLogLine & " StatusString=" & chr(34) & GetLicenseStateStri
ng(arrLicData(OSPP_LICENSESTATUS)) & chr(34)
sXmlLogLine = sXmlLogLine & " StatusCode=" & chr(34) & "0x" & Hex(arrLicData
(OSPP_LICENSESTATUSREASON)) & chr(34)
sXmlLogLine = sXmlLogLine & " StatusDescription=" & chr(34) & GetLicErrDesc(
Hex(arrLicData(OSPP_LICENSESTATUSREASON))) & chr(34)
sXmlLogLine = sXmlLogLine & " PartialProductkey=" & chr(34) & arrLicData(OSP
P_PARTIALPRODUCTKEY) & chr(34)
sXmlLogLine = sXmlLogLine & " ApplicationID=" & chr(34) & arrLicData(OSPP_AP
PLICATIONID) & chr(34)
sXmlLogLine = sXmlLogLine & " ProductKeyID=" & chr(34) & arrLicData(OSPP_PRO
DUCTKEYID) & chr(34)
sXmlLogLine = sXmlLogLine & " SkuID=" & chr(34) & arrLicData(OSPP_ID) & chr(
34)
sXmlLogLine = sXmlLogLine & " KmsServer=" & chr(34) & arrLicData(OSPP_DISCOV
EREDKEYMANAGEMENTSERVICEMACHINENAME) & chr(34)
sXmlLogLine = sXmlLogLine & " KmsPort=" & chr(34) & arrLicData(OSPP_KEYMANAG
EMENTSERVICEPORT) & chr(34)
sXmlLogLine = sXmlLogLine & " RmainingGracePeriod=" & chr(34) & CInt(arrLicD
ata(OSPP_GRACEPERIODREMAINING) / 1440) & chr(34)
sXmlLogLine = sXmlLogLine & " ActivationInterval=" & chr(34) & arrLicData(OS
PP_VLACTIVATIONINTERVAL) / 60 & chr(34)
sXmlLogLine = sXmlLogLine & " RenewalInterval=" & chr(34) & arrLicData(OSPP_
VLRENEWALINTERVAL) / 1440 & chr(34) & " />"
End Sub 'AddLicXmlString
'===============================================================================
========================
Sub AddLicTxtString (sOsppLicenses, arrLicData)
Dim sTmp
sOsppLicenses = sOsppLicenses & "#;#" & "Active License;" & arrLicData(OSPP_
NAME)
sOsppLicenses = sOsppLicenses & "#;#" & "Description;" & arrLicData(OSPP_DES

CRIPTION)
sOsppLicenses = sOsppLicenses & "#;#" & "License Family;" & arrLicData(OSPP_
LICENSEFAMILY)
sTmp = GetLicenseStateString(arrLicData(OSPP_LICENSESTATUS))
sTmp = arrLicData(OSPP_LICENSESTATUS) & " - " & sTmp & " (Error Code: 0x" &
Hex(arrLicData(OSPP_LICENSESTATUSREASON))
sTmp = sTmp & " - " & GetLicErrDesc(Hex(arrLicData(OSPP_LICENSESTATUSREASON)
)) & ")"
sOsppLicenses = sOsppLicenses & "#;#" & "License Status;" & sTmp
sOsppLicenses = sOsppLicenses & "#;#" & "Partial ProductKey;" & arrLicData(O
SPP_PARTIALPRODUCTKEY)
sOsppLicenses = sOsppLicenses & "#;#" & "ApplicationID;" & arrLicData(OSPP_A
PPLICATIONID)
sOsppLicenses = sOsppLicenses & "#;#" & "ProductKeyID;" & arrLicData(OSPP_PR
ODUCTKEYID)
sOsppLicenses = sOsppLicenses & "#;#" & "SKU ID;" & arrLicData(OSPP_ID)
If InStr(arrLicData(OSPP_DESCRIPTION),"VOLUME_KMSCLIENT") > 0 Then
sOsppLicenses = sOsppLicenses & "#;#" & "KMS Server;" & arrLicData(OSPP_
DISCOVEREDKEYMANAGEMENTSERVICEMACHINENAME)
sOsppLicenses = sOsppLicenses & "#;#" & "KMS Port;" & arrLicData(OSPP_KE
YMANAGEMENTSERVICEPORT)
sOsppLicenses = sOsppLicenses & "#;#" & "Licensed Days Remaining;" & CIn
t(arrLicData(OSPP_GRACEPERIODREMAINING) / 1440)
sOsppLicenses = sOsppLicenses & "#;#" & "VL Activation Interval;" & arrL
icData(OSPP_VLACTIVATIONINTERVAL) / 60 & " hours"
sOsppLicenses = sOsppLicenses & "#;#" & "VL Renewal Interval;" & arrLicD
ata(OSPP_VLRENEWALINTERVAL) / 1440 & " days"
Else
If arrLicData(OSPP_GRACEPERIODREMAINING) <> 0 Then _
sOsppLicenses = sOsppLicenses & "#;#" & "Remaining Grace Period;" &
CInt(arrLicData(OSPP_GRACEPERIODREMAINING) / 1440) & " days"
End If
End Sub 'AddLicTxtString
'===============================================================================
========================
'Module Productslist
'===============================================================================
========================
Sub FindAllProducts
Dim sActiveSub, sErrHnd
Dim AllProducts, ProdX
Dim arrTmpSids()
Dim sSid, Arr
Dim i
sActiveSub = "FindAllProducts" : sErrHnd = ""
On Error Resume Next
'Build an array of all applications registered to Windows Installer
'Iterate products depending of available WI version
Select Case iWiVersionMajor
Case 3, 4, 5, 6
sErrHnd = "_ErrorHandler3x" : Err.Clear
Set AllProducts = oMsi.ProductsEx("",USERSID_EVERYONE,MSIINSTALLCONTEXT_
ALL) : CheckError sActiveSub,sErrHnd
If CheckObject(AllProducts) Then WritePLArrayEx 3, arrAllProducts, AllPr
oducts, Null, Null
Case 2
'Only available for backwards compatibility reasons

'Will use direct registry reading. Reuse logic from FindProducts_ErrorHa

ndler
For i = 1 to 4
'Note that 'i=3' is not a valid context which is simply ignored in F
indRegProducts.
FindRegProducts i
Next 'i
Case Else
'Not Handled - Not Supported
End Select
FindRegProducts MSIINSTALLCONTEXT_C2RV2
InitMasterArray
Set dicProducts = CreateObject("Scripting.Dictionary")
For i = 0 To UBound(arrMaster)
arrMaster(i,COL_ISOFFICEPRODUCT) = IsOfficeProduct(arrMaster(i,COL_PRODU
CTCODE))
If NOT dicProducts.Exists(arrMaster(i,COL_PRODUCTCODE)) Then dicProducts
.Add arrMaster(i,COL_PRODUCTCODE),arrMaster(i,COL_USERSID)
Next 'i
'Build an array of all virtualized applications (Click2Run)
FindV1VirtualizedProducts
FindV2VirtualizedProducts
End Sub
'===============================================================================
========================
Sub FindAllProducts_ErrorHandler3x
Dim sActiveSub, sErrHnd
sActiveSub = "FindAllProducts_ErrorHandler3x" : sErrHnd = ""
Cachelog LOGPOS_REVITEM,LOGHEADING_NONE,ERR_CATEGORYERROR,ERR_PRODUCTSEXALL
& DOT & " Error Details: " & _
Err.Source & " " & Hex( Err ) & ": " & Err.Description
On Error Resume Next
FindProducts "",MSIINSTALLCONTEXT_MACHINE
FindProducts USERSID_EVERYONE,MSIINSTALLCONTEXT_USERUNMANAGED
FindProducts USERSID_EVERYONE,MSIINSTALLCONTEXT_USERMANAGED
End Sub
'===============================================================================
========================
Sub FindProducts(sSid, iContext)
Dim sActiveSub, sErrHnd
Dim Arr, Products
sActiveSub = "FindProducts" : sErrHnd = ""
On Error Resume Next
sErrHnd = iContext : Err.Clear
Set Products = oMsi.ProductsEx("",sSid,iContext) : CheckError sActiveSub,sEr
rHnd
Select Case iContext
Case MSIINSTALLCONTEXT_MACHINE :
If CheckObject(Products) Then Write
PLArrayEx 3,arrMProducts,Products,iContext,sSid
Case MSIINSTALLCONTEXT_USERUNMANAGED : If CheckObject(Products) Then Wri

tePLArrayEx 3,arrUUProducts,Products,iContext,sSid
Case MSIINSTALLCONTEXT_USERMANAGED : If CheckObject(Products) Then Write
PLArrayEx 3,arrUMProducts,Products,iContext,sSid
Case Else
End Select
End Sub
'===============================================================================
========================
Sub FindProducts_ErrorHandler (iContext)
Dim sSid, Arr
Dim n
Cachelog LOGPOS_REVITEM,LOGHEADING_NONE,ERR_CATEGORYERROR,"ProductsEx for "
& GetContextString(iContext) & " failed. Error Details: " & _
Err.Source & " " & Hex( Err ) & ": " & Err.Description
On Error Resume Next
FindRegProducts iContext
End Sub
'===============================================================================
========================
'General entry point for getting a list of products from the registry.
Sub FindRegProducts (iContext)
Dim arrKeys,arrTmpKeys
Dim sSid,sSubKeyName,sUMSids,sProd,sTmpProd
Dim hDefKey
Dim n,iProdCnt,iProdFind,iProdTotal
On Error Resume Next
Select Case iContext
Case MSIINSTALLCONTEXT_MACHINE
sSid = MACHINESID
hDefKey = GetRegHive(iContext, sSid, False)
sSubKeyName = GetRegConfigKey("", iContext, sSid, False)
FindRegProductsEx hDefKey, sSubKeyName, sSid, iContext, arrMProducts
Case MSIINSTALLCONTEXT_C2RV2
sSid = MACHINESID
hDefKey = GetRegHive(iContext, sSid, False)
sSubKeyName = GetRegConfigKey("", iContext, sSid, False)
FindRegProductsEx hDefKey, sSubKeyName, sSid, iContext, arrMVProducts
Case MSIINSTALLCONTEXT_USERUNMANAGED
sUMSids = ""
If CheckArray (arrUMSids) Then sUMSids = Join(arrUMSids)
If CheckArray (arrUUSids) Then
iProdTotal = -1
For iProdFind = 0 To 1
For n = 0 To UBound(arrUUSids)
sSid = arrUUSids(n)
hDefKey = GetRegHive(iContext, sSid, False)
sSubKeyName = GetRegConfigKey("", iContext, sSid, False)
If InStr(sUMSids, sSid)>0 Then
'Current SID has installed managed per-user products
'Create a string list with products
sTmpProd = ""

If NOT sUMSids="" Then

For iProdCnt = 0 To UBound(arrUMProducts)
If arrUMProducts(iProdCnt, COL_USERSID)=sSid The
n sTmpProd = sTmpProd & arrUMProducts(iProdCnt, COL_PRODUCTCODE)
Next 'iProdCnt
End If
If RegEnumKey(hDefKey, sSubKeyName, arrTmpKeys) Then
ReDim arrKeys(-1)
For iProdCnt = 0 To UBound(arrTmpKeys)
If Not InStr(sTmpProd, GetExpandedGuid(arrTmpKey
s(iProdCnt)))>0 Then
ReDim Preserve arrKeys(UBound(arrKeys)+1)
arrKeys(UBound(arrKeys))=arrTmpKeys(iProdCnt
)
End If 'Not InStr(sTmpProd, arrTmpKeys(iProdCnt)
)>0
Next 'iProdCnt
If iProdFind = 0 Then
iProdTotal = iProdTotal + UBound(arrKeys) + 1
Else
WritePLArrayEx 0, arrUUProducts, arrKeys, iConte
xt, sSid
End If
End If 'RegEnumKey(hDefKey, sSubKeyName, arrTmpKeys)
Else
'No conflict with managed per user products
If RegEnumKey(hDefKey,sSubKeyName,arrKeys) Then
If iProdFind = 0 Then
iProdTotal = iProdTotal + UBound(arrKeys) + 1
Else
WritePLArrayEx 0,arrUUProducts,arrKeys,iContext,
sSid
End If
End If 'RegEnumKey(hDefKey,sSubKeyName,arrKeys)
End If 'InStr(sUMSid,sSid)>0
Next 'n
If iProdFind = 0 Then ReDim arrUUProducts(iProdFind,UBOUND_MASTE
R)
Next 'iProdFind
End If 'CheckArray
Case MSIINSTALLCONTEXT_USERMANAGED
iProdCnt = -1
If CheckArray (arrUMSids) Then
'Determine number of products
For n = 0 To UBound(arrUMSids)
sSid = arrUMSids (n)
hDefKey = GetRegHive(iContext,sSid,False)
sSubKeyName = GetRegConfigKey("",iContext,sSid,False)
If RegEnumKey(hDefKey,sSubKeyName,arrTmpKeys) Then
iProdCnt = iProdCnt + UBound(arrTmpKeys) + 1
End If
Next 'n
ReDim arrUMProducts(iProdCnt,UBOUND_MASTER)
'Add the products to array
For n = 0 To UBound(arrUMSids)
sSid = arrUMSids (n)
hDefKey = GetRegHive(iContext,sSid,False)
sSubKeyName = GetRegConfigKey("",iContext,sSid,False)

If RegEnumKey(hDefKey,sSubKeyName,arrTmpKeys) Then WritePLArrayE

x 0,arrUMProducts,arrTmpKeys,iContext,sSid
Next 'n
End If 'CheckArray
Case Else
End Select
End Sub
'===============================================================================
========================
'Usually called from FindRegProducts
Sub FindRegProductsEx (hDefKey,sSubKeyName,sSid,iContext,Arr)
Dim arrKeys
On Error Resume Next
If RegEnumKey(hDefKey,sSubKeyName,arrKeys) Then
WritePLArrayEx 0,Arr,arrKeys,iContext,sSid
End If 'RegKeyExists
End Sub
'===============================================================================
========================
'Starting with O14 virtualized applications are available as part of "Click2Run"
'These SKU's are not fully covered by native .msi installations
Sub FindV1VirtualizedProducts
Dim
Dim
Dim
Dim

Key, sValue, VProd

arrKeys
dicVirtProd
iVCnt

'HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Office\14.0\CVH
'HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\<Product
Code> -> InstallLocation = "Virtualized Application"
Set dicVirtProd = CreateObject("Scripting.Dictionary")
If RegEnumKey (HKLM,REG_ARP,arrKeys) Then
For Each Key in arrKeys
If Len(Key)=38 Then
If IsOfficeProduct(Key) Then
If RegReadValue(HKLM,REG_ARP&"\"&Key,"CVH",sValue,"REG_DWORD") T
hen
If sValue = "1" Then
If NOT dicVirtProd.Exists(Key) Then dicVirtProd.Add Key,
Key
End If
End If
End If
End If
Next 'Key
End If
'Fill the virtual products array
If dicVirtProd.Count > 0 Then
ReDim arrVirtProducts(dicVirtProd.Count-1,UBOUND_VIRTPROD)
iVCnt = 0

For Each VProd in dicVirtProd.Keys

'ProductCode
arrVirtProducts(iVCnt,COL_PRODUCTCODE) = VProd
'ProductName
If RegReadValue(HKLM,REG_ARP&"\"&VProd,"DisplayName",sValue,"REG_SZ") Th
en
arrVirtProducts(iVCnt,COL_PRODUCTNAME) = sValue
End If
'DisplayVersion
If RegReadValue(HKLM,REG_ARP&"\"&VProd,"DisplayVersion",sValue,"REG_SZ")
Then
arrVirtProducts(iVCnt,VIRTPROD_PRODUCTVERSION) = sValue
End If
If IsOfficeProduct(VProd) Then
'SP level
If NOT fInitArrProdVer Then InitProdVerArrays
arrVirtProducts(iVCnt,VIRTPROD_SPLEVEL) = OVersionToSpLevel (VProd,G
etVersionMajor(VProd),arrVirtProducts(iVCnt,VIRTPROD_PRODUCTVERSION))
'Architecture (bitness)
arrVirtProducts(iVCnt,VIRTPROD_BITNESS) = "x86"
If Mid(VProd,21,1)="1" Then arrVirtProducts(iVCnt,VIRTPROD_BITNESS)
= "x64"
End If 'IsOfficeProduct
iVCnt = iVCnt + 1
Next 'VProd
End If 'dicVirtProd > 0
End Sub 'FindV1VirtualizedProducts
'===============================================================================
========================
'------------------------------------------------------------------------------' FindV2VirtualizedProducts
'
' Locate virtualized O15 products
'------------------------------------------------------------------------------Sub FindV2VirtualizedProducts
Dim ArpItem, VProd, ConfigProd, culture, child, name
Dim sSubKeyName, sCurKey, sConfigName, sValue, sChild
Dim sPackageGuid, sVersion, sFileName
Dim iVCnt
Dim dicVirt2Prod
Dim arrKeys, arrConfigProducts, arrVersion, arrCultures, arrChildPackages
Dim arrNames, arrTypes, arrScenario
Dim fUninstallString
On Error Resume Next
Set dicVirt2Prod = CreateObject("Scripting.Dictionary")
' enum ARP to identify configuration products
RegEnumKey HKLM, REG_ARP, arrKeys
' count loop
For Each ArpItem in arrKeys
' filter on Office 15 products
sCurKey = REG_ARP & ArpItem & "\"

fUninstallString = RegReadValue(HKLM, sCurKey, "UninstallString", sValue

, "REG_SZ")
If UCase(Left(ArpItem, 19)) = UCase(OREGREFC2R15) OR (fUninstallString A
ND InStr(UCase(sValue), UCase(OREGREFC2R15)) > 0) Then
If NOT dicVirt2Prod.Exists(ArpItem) Then dicVirt2Prod.Add ArpItem,sC
urKey
End If
Next 'ArpItem
'Fill the virtual products array
If dicVirt2Prod.Count > 0 Then
' Scenario key state
If RegEnumValues(HKLM, REG_C2RSCENARIO, arrNames, arrTypes) Then
For Each name in arrNames
RegReadValue HKLM, REG_C2RSCENARIO, name, sValue, "REG_DWORD"
If NOT dicScenario.Exists(name) Then dicScenario.Add name, sValu
e
Next 'name
End If
ReDim arrVirt2Products(dicVirt2Prod.Count - 1, UBOUND_VIRTPROD)
iVCnt = 0
For Each VProd in dicVirt2Prod.Keys
'ProductName
If RegReadValue(HKLM,REG_ARP & "\" & VProd, "DisplayName", sValue, "
REG_SZ") Then arrVirt2Products(iVCnt,COL_PRODUCTNAME) = sValue
If NOT Len(sValue) > 0 Then arrVirt2Products(iVCnt,COL_PRODUCTNAME)
= VProd
'ConfigName
fUninstallString = RegReadValue(HKLM, dicVirt2Prod.item(VProd), "Uni
nstallString", sValue, "REG_SZ")
sValue = Mid(sValue, InStr(sValue, "productsdata ") + 13)
arrVirt2Products(iVCnt,VIRTPROD_CONFIGNAME) = Left(sValue, InStr(sVa
lue, "_") - 1)
'DisplayVersion
If RegReadValue(HKLM,REG_ARP & "\" & VProd, "DisplayVersion", sValue
, "REG_SZ") Then arrVirt2Products(iVCnt,VIRTPROD_PRODUCTVERSION) = sValue
'SP level
If Len(arrVirt2Products(iVCnt, VIRTPROD_PRODUCTVERSION)) > 0 Then
arrVersion = Split(arrVirt2Products(iVCnt, VIRTPROD_PRODUCTVERSI
ON),".")
Select Case arrVersion(2)
Case "3612"
'15.0.3612.1010
arrVirt2Products(iVCnt,VIRTPROD_SPLEVEL) = "Technical Previe
w"
Case "3919"
'15.0.3919.1011
arrVirt2Products(iVCnt,VIRTPROD_SPLEVEL) = "Technical Previe
w Refresh"
Case "4128"
'15.0.4128.1014
arrVirt2Products(iVCnt,VIRTPROD_SPLEVEL) = "Customer Preview
"
Case Else
'unknown version or not yet implemented

End Select
End If
'Architecture (bitness)
RegReadValue HKLM, REG_C2RPROPERTYBAG, "platform", sValue, "REG_SZ"
arrVirt2Products(iVCnt,VIRTPROD_BITNESS) = sValue
'Child Packages
If RegEnumKey(HKLM, REG_C2RACTIVEPRODS, arrConfigProducts) Then
For Each ConfigProd in arrConfigProducts
Select Case ConfigProd
Case "culture", "stream"
' ignore
Case arrVirt2Products(iVCnt,VIRTPROD_CONFIGNAME)
sCurKey = REG_C2RACTIVEPRODS & "\" & ConfigProd
If RegEnumKey(HKLM, REG_C2RACTIVEPRODS & "\" & ConfigPro
d, arrCultures) Then
For Each culture in arrCultures
sCurKey = REG_C2RACTIVEPRODS & "\" & ConfigProd
& "\" & culture
RegReadValue HKLM, sCurKey, "Version", sValue, "
REG_SZ"
arrVirt2Products(iVCnt,VIRTPROD_CHILDPACKAGES) =
arrVirt2Products(iVCnt,VIRTPROD_CHILDPACKAGES) & culture & " - " & sValue & ";"
If RegEnumKey(HKLM, sCurKey, arrChildPackages) T
hen
For Each child in arrChildPackages
sCurKey = REG_C2RACTIVEPRODS & "\" & Con
figProd & "\" & culture & "\" & child
sChild = "" : sPackageGuid = "" : sVersi
on = "" : sFileName = ""
RegReadValue HKLM, sCurKey, "PackageGuid
", sPackageGuid, "REG_SZ"
If Len(sPackageGuid) > 0 Then sChild = "
{" & sPackageGuid & "}" & " - "
RegReadValue HKLM, sCurKey, "Version", s
Version, "REG_SZ"
If Len(sVersion) > 0 Then sChild = sChil
d & sVersion & " - "
RegReadValue HKLM, sCurKey, "FileName",
sFileName, "REG_SZ"
If Len(sFileName) > 0 Then
sFileName = Replace(sFileName, ".zip
", "")
sChild = sChild & sFileName
End If
If NOT sChild = "" Then arrVirt2Products
(iVCnt,VIRTPROD_CHILDPACKAGES) = arrVirt2Products(iVCnt,VIRTPROD_CHILDPACKAGES)
& sChild & ";"
Next 'child
End If
Next 'culture
End If
Case Else
' not the targeted product
End Select
Next 'ConfigProd
End If
iVCnt = iVCnt + 1

Next 'VProd
End If 'dicVirtProd > 0
End Sub 'FindV2VirtualizedProducts
'------------------------------------------------------------------------------' GetConfigName
'
' Get the configuration name from the ARP key name
'------------------------------------------------------------------------------Function GetConfigName(ArpItem)
Dim sCurKey, sValue, sDisplayVersion, sUninstallString
dim sCulture, sConfigName
Dim iLeft, iRight
Dim fSystemComponent0, fDisplayVersion, fUninstallString
sCurKey = REG_ARP & ArpItem & "\"
sValue = ""
sDisplayVersion = ""
fSystemComponent0 = NOT (RegReadValue(HKLM, sCurKey, "SystemComponent", sVal
ue, "REG_DWORD") AND (sValue = "1"))
fDisplayVersion = RegReadValue(HKLM, sCurKey, "DisplayVersion", sValue, "REG
_SZ")
If fDisplayVersion Then
sDisplayVersion = sValue
If Len(sValue) > 1 Then
fDisplayVersion = (Left(sValue, 2) = "15")
Else
fDisplayVersion = False
End If
End If
fUninstallString = RegReadValue(HKLM, sCurKey, "UninstallString", sUninstall
String, "REG_SZ")
'C2R
If (fSystemComponent0 AND fDisplayVersion AND InStr(UCase(sUninstallString),
UCase(OREGREFC2R15)) > 0) Then
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, "2013", "")
sConfigName = Replace(sConfigName, " ", "")
'sConfigName = Replace(sConfigName, "Project", "Prj")
'sConfigName = Replace(sConfigName, "Visio", "Vis")
GetConfigName = sConfigName
Exit Function
End If

'Standalone helper MSI products

Select Case Mid(ArpItem,11,4)
Case "007E", "008F", "008C"
GetConfigName = "Habanero"
Case "24E1", "237A"
GetConfigName = "MSOIDLOGIN"
Case Else
GetConfigName = ""
End Select
End Function 'GetConfigName
'===============================================================================
========================
Sub CopyToMaster (Arr)
Dim i,j,n
On Error Resume Next
For n = 0 To UBound(arrMaster)
If (IsEmpty(arrMaster(n,COL_PRODUCTCODE)) OR Not (Len(arrMaster(n,COL_PR
ODUCTCODE))>0)) Then Exit For
Next 'n
For i = 0 To UBound(Arr,1)
For j = 0 To UBound(Arr,2)
arrMaster(i+n,j) = arr(i,j)
Next 'j
Next 'i
End Sub
'===============================================================================
========================
Function GetObjProductState(ProdX,iContext,sSid,iSource)
Dim iState
On Error Resume Next
Select Case iSource
Case 0 'Registry
iState = GetRegProductState(ProdX,iContext,sSid)
Case 2 'WI 2.x
Case 3 'WI >=3.x
iState = ProdX.State
Case Else
iState = -1
End Select
GetObjProductState = iState
End Function
'===============================================================================
========================
Function TranslateObjProductState(iState)
Dim sState
On Error Resume Next

Select Case iState

Case INSTALLSTATE_ADVERTISED '1
sState = "Advertised"
Case INSTALLSTATE_ABSENT '2
sState = "Absent"
Case INSTALLSTATE_DEFAULT '5
sState = "Installed"
Case INSTALLSTATE_VIRTUALIZED '8
sState = "Virtualized"
Case Else '-1
sState = "Unknown"
End Select
TranslateObjProductState = sState
End Function
'===============================================================================
========================
'Obtain the ProductName for product
Function GetObjProductName(ProdX,sProductCode,iContext,sSid,iSource)
Dim sName
On Error Resume Next
Select Case iSource
Case 0 'Registry
sName = GetRegProductName(ProdX,iContext,sSid)
Case 2 'WI 2.x
Case 3 'WI >=3.x
Err.Clear
sName = ProdX.InstallProperty ("ProductName")
If Not Err = 0 Then
sName = GetRegProductName(GetCompressedGuid(sProductCode),iContext,s
Sid)
End If 'Err
Case Else
End Select
GetObjProductName = sName
End Function
'===============================================================================
========================
'Get the current products UserSID.
Function GetObjUserSid(ProdX,sSid,iSource)
On Error Resume Next
Select Case iSource
Case 0 'Registry
sSid = sSid
Case 2 'WI 2.x
Case 3 'WI >=3.x
sSid = ProdX.UserSid
Case Else
End Select

GetObjUserSid = sSid
End Function
'===============================================================================
========================
Function GetObjContext(ProdX,iContext,iSource)
On Error Resume Next
If iSource = 3 Then iContext = ProdX.Context
GetObjContext = iContext
End Function
'===============================================================================
========================
Function TranslateObjContext(iContext)
Dim sContext
On Error Resume Next
Select Case iContext
Case MSIINSTALLCONTEXT_USERMANAGED '1
sContext = "User Managed"
Case MSIINSTALLCONTEXT_USERUNMANAGED '2
sContext = "User Unmanaged"
Case MSIINSTALLCONTEXT_MACHINE '4
sContext = "Machine"
Case MSIINSTALLCONTEXT_ALL '7
sContext = "All"
Case MSIINSTALLCONTEXT_C2RV2 '8
sContext = "Machine C2Rv2"
Case Else
sContext = "Unknown"
End Select
TranslateObjContext = sContext
End Function
'===============================================================================
========================
Function GetObjGuid(ProdX,iSource)
Dim sGuid
On Error Resume Next
Select Case iSource
Case 0 'Registry
If (IsValidGuid(ProdX,GUID_COMPRESSED) OR fGuidCaseWarningOnly) Then
sGuid = GetExpandedGuid(ProdX)
Else
sGuid = ProdX
End If
Case 2 'WI 2.x
sGuid = ProdX
Case 3 'WI >=3.x
sGuid = ProdX.ProductCode
Case Else

End Select
GetObjGuid = sGuid
End Function
'===============================================================================
========================
Sub WritePLArrayEx(iSource,Arr,Obj,iContext,sSid)
Dim ProdX,Product,sProductCode,sProductName
Dim i, n, iDimCnt,iPosUMP
On Error Resume Next
If CheckObject(Obj) Or CheckArray(Obj) Then
i = 0
If CheckObject(Obj) Then
ReDim Arr(Obj.Count-1, UBOUND_MASTER)
Else
If UBound(Obj)>UBound(Arr) Then ReDim Arr(UBound(Obj), UBOUND_MASTER
)
Do While Not IsEmpty(Arr(i,0))
i=i+1
If i >= UBound(Obj) Then Exit Do
Loop
End If 'CheckObject
For Each ProdX in Obj
' preset Recordset with Default Error
For n = 0 to 4
Arr(i,n) = "Preset Error String"
Next 'n
' ProductCode
Arr(i,COL_PRODUCTCODE) = GetObjGUID(ProdX,iSource)
' ProductContext
Arr(i,COL_CONTEXT) = GetObjContext(ProdX,iContext,iSource)
Arr(i,COL_CONTEXTSTRING) = TranslateObjContext(Arr(i,COL_CONTEXT))
' SID
Arr(i,COL_USERSID) = GetObjUserSid(ProdX,sSid,iSource)
' ProductName
Arr(i,COL_PRODUCTNAME) = GetObjProductName(ProdX,Arr(i,COL_PRODUCTCO
DE),Arr(i,COL_CONTEXT),Arr(i,COL_USERSID),iSource)
' ProductState
Arr(i,COL_STATE) = GetObjProductState(ProdX,Arr(i,COL_CONTEXT),Arr(i
,COL_USERSID),iSource)
Arr(i,COL_STATESTRING) = TranslateObjProductState(Arr(i,COL_STATE))
' write to cache
CacheLog LOGPOS_RAW,LOGHEADING_NONE,Null,Arr(i,COL_PRODUCTCODE) & ",
" & Arr(i,COL_CONTEXT) & "," & Arr(i,COL_USERSID) & "," & _
Arr(i,COL_PRODUCTNAME) & "," & Arr(i,COL_STATE)
' ARP ProductName
Arr(i,COL_ARPPRODUCTNAME) = GetArpProductname(Arr(i,COL_PRODUCTCODE)
)
' Guid validation
If Not IsValidGuid(Arr(i,COL_PRODUCTCODE),GUID_UNCOMPRESSED) Then
If fGuidCaseWarningOnly Then
Arr(i,COL_NOTES) = Arr(i,COL_NOTES) & ERR_CATEGORYNOTE & ERR
_GUIDCASE & CSV
Else
Arr(i,COL_ERROR) = Arr(i,COL_ERROR) & ERR_CATEGORYERROR & sE
rror & CSV
Cachelog LOGPOS_REVITEM,LOGHEADING_NONE,ERR_CATEGORYERROR,sE
rror & DSV & Arr(i,COL_PRODUCTCODE) & DSV & _

Arr(i,COL_PRODUCTNAME)& DSV & BPA_GUID

End If
End If
' Virtual flag
Arr(i, COL_VIRTUALIZED) = 0
If iContext = MSIINSTALLCONTEXT_C2RV2 Then Arr(i, COL_VIRTUALIZED) =
1
' InstallType flag
Arr(i, COL_INSTALLTYPE) = "MSI"
If iContext = MSIINSTALLCONTEXT_C2RV2 Then Arr(i, COL_INSTALLTYPE) =
"C2R"
i = i + 1
Next 'ProdX
End If 'ObjectList.Count > 0
End Sub 'WritePLArrayEx
'===============================================================================
========================
Sub InitPLArrays
On Error Resume Next
ReDim
ReDim
ReDim
ReDim
ReDim
ReDim
ReDim
End Sub

arrAllProducts(-1)
arrVirtProducts(-1)
arrVirt2Products(-1)
arrMProducts(-1)
arrMVProducts(-1)
arrUUProducts(-1)
arrUMProducts(-1)

'===============================================================================
========================
'Module Prerequisites
'===============================================================================
========================
Function CheckPreReq ()
On Error Resume Next
Dim sActiveSub, sErrHnd
Dim sPreReqError, sDebugLogName, sSubKeyName
Dim i, iFoo
Dim hDefKey, lAccPermLevel
Dim oCompItem, oWmiLocal, oItem
sActiveSub = "CheckPreReq" : sErrHnd = "_ErrorHandler"
fIsCriticalError = False
CheckPreReq = True : fIsAdmin = True : fIsElevated = True
sPreReqError = vbNullString
Err.Clear
'Create the WScript Shell Object
Set oShell = CreateObject("WScript.Shell"): CheckError sActiveSub,sErrHnd
sComputerName = oShell.ExpandEnvironmentStrings("%COMPUTERNAME%"): CheckErro
r sActiveSub,sErrHnd
sTemp = oShell.ExpandEnvironmentStrings("%TEMP%"): CheckError sActiveSub,sEr
rHnd
'Create the Windows Installer Object
Set oMsi = CreateObject("WindowsInstaller.Installer"): CheckError sActiveSub
,sErrHnd

iWiVersionMajor = Left(oMsi.Version,Instr(oMsi.Version,".")-1)
If (CheckPreReq = True And iWiVersionMajor < 2) Then CheckPreReq = False
'Create the FileSystemObject
Set oFso = CreateObject("Scripting.FileSystemObject"): CheckError sActiveSub
,sErrHnd
'Connect to WMI Registry Provider
Set oReg = GetObject("winmgmts:\\.\root\default:StdRegProv"): CheckError sAc
tiveSub,sErrHnd
'Needs to be done here already as registry access calls depend on it
Set oWmiLocal = GetObject("winmgmts:\\.\root\cimv2")
Set oCompItem = oWmiLocal.ExecQuery("Select * from Win32_ComputerSystem")
For Each oItem In oCompItem
sSystemType = oItem.SystemType
f64 = Instr(Left(oItem.SystemType,3),"64") > 0
Next
'Check registry access permissions
'Failure will not terminate the scipt but noted in the log
hDefKey = HKEY_LOCAL_MACHINE
sSubKeyName = "SOFTWARE\Microsoft\Windows"
For i = 1 To 4
Select Case i
Case 1 : lAccPermLevel = KEY_QUERY_VALUE
Case 2 : lAccPermLevel = KEY_SET_VALUE
Case 3 : lAccPermLevel = KEY_CREATE_SUB_KEY
Case 4 : lAccPermLevel = DELETE
End Select
If Not RegCheckAccess(hDefKey,sSubKeyName,lAccPermLevel) Then
fIsAdmin = False
Exit for
End If
Next 'i
If fIsAdmin Then
sSubKeyName = "Software\Microsoft\Windows\"
For i = 1 To 4
Select Case i
Case 1 : lAccPermLevel = KEY_QUERY_VALUE
Case 2 : lAccPermLevel = KEY_SET_VALUE
Case 3 : lAccPermLevel = KEY_CREATE_SUB_KEY
Case 4 : lAccPermLevel = DELETE
End Select
If Not RegCheckAccess(hDefKey,sSubKeyName,lAccPermLevel) Then
fIsElevated = False
Exit for
End If
Next 'i
End If 'fIsAdmin
Set ShellApp = CreateObject("Shell.Application")
If Not sPreReqError = vbNullString Then
If fQuiet = False Then
Msgbox "Script execution needs to terminate" & vbCrLf & vbCrLf & sPr

eReqError, vbOkOnly, _
"Critical Error in Script Prerequisite Check"
End If
CheckPreReq = False
End If ' sPreReqError = vbNullString
End Function 'CheckPreReq()
'===============================================================================
========================
Sub CheckPreReq_ErrorHandler
sPreReqError = sPreReqError & _
sDebugErr & " returned:" & vbCrLf &_
"Error Details: " & Err.Source & " " & Hex( Err ) & ": " & Err.Descripti
on & vbCrLf & vbCrLf
End Sub
'===============================================================================
========================
'Module ComputerProperties
'===============================================================================
========================
Sub ComputerProperties
Dim oOS, oWmi, oOsItem
Dim sOSinfo, sOSVersion, sUserInfo, sSubKeyName, sName, sValue, sOsMui, sOsL
cid, sCulture
Dim arrKeys, arrNames, arrTypes,arrVersion
Dim qOS, OsLang, ValueType
Dim iOSVersion, iValueName
Dim hDefKey
Const REG_SZ = 1
On Error Resume Next
sComputerName = oShell.ExpandEnvironmentStrings("%COMPUTERNAME%")
'Note 64 bit OS check was already done in 'Sub Initialize'
'OS
Set
Set
For

info from WMI Win32_OperatingSystem

oWMI = GetObject("winmgmts:\\.\root\cimv2")
qOS = oWmi.ExecQuery("Select * from Win32_OperatingSystem")
Each oOsItem in qOS
sOSinfo = sOSinfo & oOsItem.Caption
sOSinfo = sOSinfo & oOsItem.OtherTypeDescription
sOSinfo = sOSinfo & CSV & "SP " & oOsItem.ServicePackMajorVersion
sOSinfo = sOSinfo & CSV & "Version: " & oOsItem.Version
sOsVersion = oOsItem.Version
sOSinfo = sOSinfo & CSV & "Codepage: " & oOsItem.CodeSet
sOSinfo = sOSinfo & CSV & "Country Code: " & oOsItem.CountryCode
sOSinfo = sOSinfo & CSV & "Language: " & oOsItem.OSLanguage

Next
sOSinfo = sOSinfo & CSV & "System Type: " & sSystemType
'Check for OS MUI languages
'The MUI registry location has been changed with Windows Vista
'Win 2000, XP and Server 2003: HKLM\System\CurrentControlSet\Control\Nls\MUI
Languages
'From Vista on: HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\MUI\UILa
nguages

'Build the VersionNT number

arrVersion = Split(sOsVersion,Delimiter(sOsVersion))
iVersionNt = CInt(arrVersion(0))*100 + CInt(arrVersion(1))
hDefKey = HKEY_LOCAL_MACHINE
If iVersionNt < 600 Then
' "old" reg location
sSubKeyName = "System\CurrentControlSet\Control\Nls\MUILanguages\"
If RegEnumValues (hDefKey,sSubKeyName,arrNames,arrTypes) Then
For iValueName = 0 To UBound(arrNames)
If arrTypes(iValueName) = REG_SZ Then
sName = "": sName = arrNames(iValueName)
sOsMui = sOsMui & GetCultureInfo(CInt("&h"&sName)) & " (" &
CInt("&h"&sName) & ")" & CSV
End If
Next 'ValueName
sOsMui = RTrimComma(sOsMui)
End If 'IsArray
Else
' "new" reg location
sSubKeyName = "SYSTEM\CurrentControlSet\Control\MUI\UILanguages\"
sName = "LCID"
If RegEnumKey(hDefKey,sSubKeyName,arrKeys) Then
For Each OsLang in arrKeys
If Len(sOsMui) > 1 Then sOsMui = sOsMui & CSV
sOsMui = sOsMui & OsLang
If RegReadDWordValue(hDefKey,sSubKeyName&OsLang,sName,sValue) Th
en sOsMui = sOsMui & " (" & sValue & ")"
Next 'OsLang
End If 'RegKeyExists
End If
'User info from WMI Win32_ComputerSystem
Set qOS = oWmi.ExecQuery("Select * from Win32_ComputerSystem")
For Each oOsItem in qOS
sUserInfo = sUserInfo & "Username: " & oOsItem.UserName
Next
sUserInfo = sUserInfo & CSV & "IsAdmin: " & fIsAdmin
sUserInfo = sUserInfo & CSV & "SID: " & sCurUserSid
If NOT fBasicMode Then CacheLog LOGPOS_COMPUTER,LOGHEADING_NONE,"Windows Ins
taller Version",oMsi.Version
CacheLog LOGPOS_COMPUTER,LOGHEADING_NONE,"ComputerName",sComputerName
CacheLog LOGPOS_COMPUTER,LOGHEADING_NONE,"OS Details",sOSinfo
If NOT fBasicMode Then CacheLog LOGPOS_COMPUTER,LOGHEADING_NONE,"OS MUI Lang
uages",sOsMui
If NOT fBasicMode Then CacheLog LOGPOS_COMPUTER,LOGHEADING_NONE,"Current Use
r",sUserInfo
If NOT fBasicMode Then CacheLog LOGPOS_COMPUTER,LOGHEADING_NONE,"Logfile Nam
e",sLogFile
CacheLog LOGPOS_COMPUTER,LOGHEADING_NONE,"ROI Script Build",SCRIPTBUILD
End Sub 'ComputerProperties
'===============================================================================
========================
'Module Logging
'===============================================================================
========================
'===============================================================================

========================
Sub WriteLog
Dim LogOutput
Dim i,n
Dim sScriptSettings
On Error Resume Next
'Add actual values for customizable settings
sScriptSettings = ""
If fListNonOfficeProducts Then sScriptSettings = sScriptSettings & "/All "
If fLogFull Then sScriptSettings = sScriptSettings & "/Full "
If fLogVerbose Then sScriptSettings = sScriptSettings & "/LogVerbose "
If fLogChainedDetails Then sScriptSettings = sScriptSettings & "/LogChainedD
etails "
If fFileInventory Then sScriptSettings = sScriptSettings & "/FileInventory "
If fFeatureTree Then sScriptSettings = sScriptSettings & "/FeatureTree "
If fBasicMode Then sScriptSettings = "/Basic "
If fQuiet Then sScriptSettings = sScriptSettings & "/Quiet "
If Not sPathOutputFolder = "" Then sScriptSettings = sScriptSettings & "/Log
folder: "&sPathOutputFolder
CacheLog LOGPOS_COMPUTER,LOGHEADING_NONE,"Script Settings",sScriptSettings
'Determine total scan time
tEnd = Time()
If NOT fBasicMode Then CacheLog LOGPOS_COMPUTER,LOGHEADING_NONE,"Total scan
time",Int((tEnd - tStart)*1000000 + 0.5)/10 & " s"
Set LogOutput = oFso.OpenTextFile(sLogFile, FOR_WRITING, True, True)
LogOutput.WriteLine "Microsoft Customer Support Services - Robust Office Inv
entory - " & Now
LogOutput.Write vbCrLf & String(160,"*") & vbCrLf
'Flush the prepared output arrays to the log
n = 2
'Enable raw output if an error was encountered
If NOT Len(arrLog(1)) = 32 AND NOT fBasicMode Then n = 3
For i = 0 to n
If i = 1 Then
If NOT Len(arrLog(i)) = 32 Then
LogOutput.Write arrLog(i)
LogOutput.Write vbCrLf & String(160,"*") & vbCrLf
End If
Else
LogOutput.Write arrLog(i)
If NOT (i = 2) Then LogOutput.Write vbCrLf & String(160,"*") & vbCrL
f
End If
Next 'i
LogOutput.Close
Set LogOutput = Nothing
'Copy the log to the fileinventory folder if needed
If fFileInventory Then oFso.CopyFile sLogFile,sPathOutputFolder&"ROIScan\",
TRUE
' write the xml log
WriteXmlLog
End Sub

'===============================================================================
========================
Sub WriteXmlLog
Dim XmlLogStream, mspSeq, key, lic
Dim sXmlLine, sText, sProductCode, sSPLevel, sFamily, sSeq
Dim i, iVPCnt, iItem, iArpCnt, iDummy, iPos, iPosMaster, iChainProd, iPosPat
ch, iColPatch
Dim iColISource, iLogCnt
Dim arrC2RPackages, arrC2RItems, arrTmp, arrTmpInner, arrLicData
Dim dicTmp
Dim fLogProduct
On Error Resume Next
Set dicTmp = CreateObject("Scripting.Dictionary")
Set XmlLogStream = oFso.CreateTextFile(sPathOutputFolder & sComputerName & "
_ROIScan.xml", True, True)
XmlLogStream.WriteLine "<?xml version=""1.0""?>"
XmlLogStream.WriteLine "<OFFICEINVENTORY>"
'c2r v2
If UBound(arrVirt2Products) > -1 Then
For iVPCnt = 0 To UBound(arrVirt2Products, 1)
sXmlLine = ""
sXmlLine = "<SKU "
' ProductName (heading)
sXmlLine = sXmlLine & "ProductName=" & chr(34) & arrVirt2Products(iV
PCnt,COL_PRODUCTNAME) & chr(34)
' ConfigName
sXmlLine = sXmlLine & " ConfigName=" & chr(34) & arrVirt2Products(iV
PCnt,VIRTPROD_CONFIGNAME) & chr(34)
sXmlLine = sXmlLine & " IsChainedChild=" & chr(34) & "FALSE" & chr(3
4)
' ProductCode
sXmlLine = sXmlLine & " ProductCode=" & chr(34) & "" & chr(34)
' ProductVersion
sXmlLine = sXmlLine & " ProductVersion=" & chr(34) & arrVirt2Product
s(iVPCnt,VIRTPROD_PRODUCTVERSION) & chr(34)
' SP Level
sXmlLine = sXmlLine & " ServicePackLevel=" & chr(34) & arrVirt2Produ
cts(iVPCnt,VIRTPROD_SPLEVEL) & chr(34)
' Architecture
sXmlLine = sXmlLine & " Architecture=" & chr(34) & arrVirt2Products(
iVPCnt,VIRTPROD_BITNESS) & chr(34)
' InstallType
sXmlLine = sXmlLine & " InstallType=" & chr(34) & "C2R" & chr(34)
' end line
sXmlLine = sXmlLine & " >"
'flush
XmlLogStream.WriteLine sXmlLine
' Child Packages
XmlLogStream.WriteLine "<ChildPackages>"
arrC2RPackages = Split(arrVirt2Products(iVPCnt,VIRTPROD_CHILDPACKAGE
S), ";")
For i = 0 To UBound(arrC2RPackages) - 1 'strip off last delimiter
arrC2RItems = Split(arrC2RPackages(i), " - ")
If UBound(arrC2RItems) = 1 Then

If NOT i = 0 Then XmlLogStream.WriteLine "</SkuCulture>"

XmlLogStream.WriteLine "<SkuCulture culture=" & chr(34) & ar
rC2RItems(0) & chr(34) & " ProductVersion=" & chr(34) & arrC2RItems(1) & chr(34)
& " >"
Else
XmlLogStream.WriteLine "<ChildPackage ProductCode=" & chr(34
) & arrC2RItems(0) & chr(34) & " ProductVersion=" & chr(34) & arrC2RItems(1) & c
hr(34) & " ProductName=" & chr(34) & arrC2RItems(2) & chr(34) & " />"
End If
Next 'i
XmlLogStream.WriteLine "</SkuCulture>"
XmlLogStream.WriteLine "</ChildPackages>"
'LicenseData
XmlLogStream.WriteLine "<LicenseData>"
XmlLogStream.WriteLine arrVirt2Products(iVPCnt, VIRTPROD_OSPPLICENSE
XML)
XmlLogStream.WriteLine "</LicenseData>"
XmlLogStream.WriteLine "</SKU>"
Next 'iVPCnt
End If 'c2r v2
'c2r v1
If UBound(arrVirtProducts) > -1 Then
For iVPCnt = 0 To UBound(arrVirtProducts, 1)
sXmlLine = ""
sXmlLine = "<SKU "
' ProductName (heading)
sXmlLine = sXmlLine & "ProductName=" & chr(34) & arrVirtProducts(iVP
Cnt, COL_PRODUCTNAME) & chr(34)
' ProductVersion
sXmlLine = sXmlLine & " ProductVersion=" & chr(34) & arrVirtProducts
(iVPCnt, VIRTPROD_PRODUCTVERSION) & chr(34)
' SP Level
sXmlLine = sXmlLine & " ServicePackLevel=" & chr(34) & arrVirtProduc
ts(iVPCnt, VIRTPROD_SPLEVEL) & chr(34)
' ProductCode
sXmlLine = sXmlLine & " ProductCode=" & chr(34) & arrVirtProducts(iV
PCnt, COL_PRODUCTCODE) & chr(34)
' end line
sXmlLine = sXmlLine & " >"
'flush
XmlLogStream.WriteLine sXmlLine
XmlLogStream.WriteLine "</SKU>"
Next 'iVPCnt
End If 'c2r v1
'MSI Office 12, 14, 15 Products
For iArpCnt = 0 To UBound(arrArpProducts)
' extra loop to allow exit out of a bad product
iPos = GetArrayPosition(arrMaster, arrArpProducts(iArpCnt, ARP_CONFIGPRO
DUCTCODE))
sProductCode = "" : sProductCode = arrMaster(iPos, COL_PRODUCTCODE)
sXmlLine = ""
sXmlLine = "<SKU "
' ProductName (heading)
sText = "" : sText = GetArpProductName(arrArpProducts(iArpCnt, COL_CONFI
GNAME))
If (sText = "" AND iPos = -1) Then sText = arrMaster(iPos, COL_ARPPRODUC

TNAME)
sXmlLine = sXmlLine & "ProductName=" & chr(34) & sText & chr(34)
' Configuration ProductName
sText = "" : sText = arrArpProducts(iArpCnt, COL_CONFIGNAME)
If InStr(sText,".") > 0 Then sText = Mid(sText, InStr(sText, ".") + 1)
sXmlLine = sXmlLine & " ConfigName=" & chr(34) & sText & chr(34)
sXmlLine = sXmlLine & " IsChainedChild=" & chr(34) & "FALSE" & chr(34)
' ProductCode
sXmlLine = sXmlLine & " ProductCode=" & chr(34) & "" & chr(34)
' ProductVersion
sXmlLine = sXmlLine & " ProductVersion=" & chr(34) & arrArpProducts(iArp
Cnt, ARP_PRODUCTVERSION) & chr(34)
' ServicePack
sSPLevel = ""
If NOT iPos = -1 AND NOT sProductCode = "" AND Len(arrArpProducts(iArpCn
t, ARP_PRODUCTVERSION)) > 2 Then
sSPLevel = OVersionToSpLevel(sProductCode, GetVersionMajor(sProductC
ode), arrArpProducts(iArpCnt, ARP_PRODUCTVERSION))
End If
sXmlLine = sXmlLine & " ServicePackLevel=" & chr(34) & sSPLevel & chr(3
4)
' Architecture
sXmlLine = sXmlLine & " Architecture=" & chr(34) & arrMaster(iPos, COL_A
RCHITECTURE) & chr(34)
' InstallType
sXmlLine = sXmlLine & " InstallType=" & chr(34) & arrMaster(iPos, COL_IN
STALLTYPE) & chr(34)
' InstallDate
sXmlLine = sXmlLine & " InstallDate=" & chr(34) & Left(Replace(arrMaster
(iPos, COL_INSTALLDATE), " ", ""), 8) & chr(34)
' ProductState
sXmlLine = sXmlLine & " ProductState=" & chr(34) & arrMaster(iPos, COL_S
TATESTRING) & chr(34)
' ConfigMsi
sXmlLine = sXmlLine & " ConfigMsi=" & chr(34) & arrMaster(iPos, COL_ORIG
INALMSI) & chr(34)
' BuildOrigin
sXmlLine = sXmlLine & " BuildOrigin=" & chr(34) & arrMaster(iPos, COL_OR
IGIN) & chr(34)
' end line
sXmlLine = sXmlLine & " >"
'flush
XmlLogStream.WriteLine sXmlLine
' Child Packages
XmlLogStream.WriteLine "<ChildPackages>"
For iChainProd = COL_LBOUNDCHAINLIST To UBound(arrArpProducts, 2)
If IsEmpty(arrArpProducts(iArpCnt, iChainProd)) Then Exit For
iPosMaster = GetArrayPosition(arrMaster,arrArpProducts(iArpCnt,i
ChainProd))
'Only run if iPosMaster has a valid index #
sXmlLine = "<ChildPackage"
'ProductCode
sText = "" : If NOT iPosMaster = -1 Then sText = arrMaster(iPosM
aster, COL_PRODUCTCODE)
sXmlLine = sXmlLine & " ProductCode=" & chr(34) & sText & chr(34
)
'ProductVersion
sText = "" : If NOT iPosMaster = -1 Then sText = arrMaster(iPosM
aster, COL_PRODUCTVERSION)

sXmlLine = sXmlLine & " ProductVersion=" & chr(34) & sText & chr
(34)
'ProductName
sText = "" : If NOT iPosMaster = -1 Then sText = arrMaster(iPosM
aster, COL_PRODUCTNAME)
sXmlLine = sXmlLine & " ProductName=" & chr(34) & sText & chr(34
)
' end line
sXmlLine = sXmlLine & " />"
'flush
XmlLogStream.WriteLine sXmlLine
Next 'iChainProd
XmlLogStream.WriteLine "</ChildPackages>"
'LicenseData
'----------XmlLogStream.WriteLine "<LicenseData>"
If NOT iPos = -1 Then
If arrMaster(iPos, COL_OSPPLICENSE) <> "" Then
XmlLogStream.WriteLine arrMaster(iPos, COL_OSPPLICENSEXML)
End If
End If
XmlLogStream.WriteLine "</LicenseData>"
' Patches
XmlLogStream.WriteLine "<PatchData>"
' PatchBaseLines
XmlLogStream.WriteLine "<PatchBaseline Sequence=" & chr(34) & arrArpProd
ucts(iArpCnt, ARP_PRODUCTVERSION) & chr(34) & " >"
dicTmp.RemoveAll
For iChainProd = COL_LBOUNDCHAINLIST To UBound(arrArpProducts, 2)
If IsEmpty(arrArpProducts(iArpCnt, iChainProd)) Then Exit For
iPosMaster = GetArrayPosition(arrMaster, arrArpProducts(iArpCnt, iCh
ainProd))
'Only run if iPosMaster has a valid index #
If Not iPosMaster = -1 Then
Set arrTmp = Nothing
arrTmp = Split(arrMaster(iPosMaster, COL_PATCHFAMILY), ",")
For Each MspSeq in arrTmp
arrTmpInner = Split(MspSeq, ":")
sFamily = "" : sSeq = ""
sFamily = arrTmpInner(0)
sSeq = arrTmpInner(1)
If (sSeq>arrMaster(iPosMaster,COL_PRODUCTVERSION)) Then
If dicTmp.Exists(sFamily) Then
If (sSeq > dicTmp.Item(sFamily)) Then dicTmp.Item(sF
amily)=sSeq
Else
dicTmp.Add sFamily,sSeq
End If
End If
Next 'MspSeq
End If 'Not iPosMaster = -1
Next 'iChainProd
For Each key in dicTmp.Keys
XmlLogStream.WriteLine "<PostBaseline PatchFamily=" & chr(34) & key
& chr(34) & " Sequence=" & chr(34) & dicTmp.Item(key) & chr(34) & " />"
Next 'key
XmlLogStream.WriteLine "</PatchBaseline>"

' PatchList
For iChainProd = COL_LBOUNDCHAINLIST To UBound(arrArpProducts, 2)
If IsEmpty(arrArpProducts(iArpCnt,iChainProd)) Then Exit For
iPosMaster = GetArrayPosition(arrMaster, arrArpProducts(iArpCnt, iCh
ainProd))
'Only run if iPosMaster has a valid index #
If Not iPosMaster = -1 Then
For iPosPatch = 0 to UBound(arrPatch, 3)
If Not IsEmpty (arrPatch(iPosMaster, PATCH_PATCHCODE, iPosPa
tch)) Then
sXmlLine = "<Patch PatchedProduct=" & chr(34) & arrMaste
r(iPosMaster, COL_PRODUCTCODE) & chr(34)
For iColPatch = PATCH_LOGSTART to PATCH_LOGCHAINEDMAX
If Not IsEmpty(arrPatch(iPosMaster, iColPatch, iPosP
atch)) Then
sXmlLine = sXmlLine & " " & Replace(arrLogForma
t(ARRAY_PATCH,iColPatch), ": ", "") & "=" & chr(34) & arrPatch(iPosMaster,iColPa
tch,iPosPatch) & chr(34)
End If
Next 'iColPatch
sXmlLine = sXmlLine & " />"
XmlLogStream.WriteLine sXmlLine
'
Set arrTmp = Nothing
'
arrTmp = Split(arrMaster(iPosMaster, COL_PATCHFAMIL
Y), ",")
'
For Each MspSeq in arrTmp
'
arrTmpInner = Split(MspSeq, ":")
'
XmlLogStream.WriteLine "<MsiPatchSequence Patch
Family=" & chr(34) & arrTmpInner(0) & chr(34) & " Sequence=" & chr(34) & arrTmpI
nner(1) & chr(34) & " />"
'
Next 'MspSeq
'
XmlLogStream.WriteLine "</Patch>"
End If 'IsEmpty
Next 'iPosPatch
End If ' Not iPosMaster = -1
Next 'iChainProd
XmlLogStream.WriteLine "</PatchData>"
'InstallSource
XmlLogStream.WriteLine "<InstallSource>"
For iColISource = IS_LOG_LBOUND To IS_LOG_UBOUND
If NOT iPos = -1 Then
If Not IsEmpty(arrIS(iPos, iColISource)) Then _
XmlLogStream.WriteLine "<Source " & Replace(arrLogFormat(ARRAY_I
S,iColISource)," ", "") & "=" & chr(34) & arrIS(iPos, iColISource) & chr(34) & "
/>"
End If
Next 'iColISource
XmlLogStream.WriteLine "</InstallSource>"
XmlLogStream.WriteLine "</SKU>"
Next 'iArpCnt
'Other Products
Err.Clear
For iLogCnt = 0 To 10
For iPosMaster = 0 To UBound(arrMaster)
fLogProduct = CheckLogProduct(iLogCnt, iPosMaster)
If fLogProduct Then

'arrMaster contents
sXmlLine = ""
sXmlLine = "<SKU "
' ProductName (heading)
sText = "" : sText = arrMaster(iPosMaster,COL_ARPPRODUCTNAME)
If sText = "" Then sText = arrMaster(iPosMaster,COL_PRODUCTNAME)
sXmlLine = sXmlLine & "ProductName=" & chr(34) & sText & chr(34)
sXmlLine = sXmlLine & " ConfigName=" & chr(34) & "" & chr(34)
Select Case iLogCnt
Case 1, 3, 5
sXmlLine = sXmlLine & " IsChainedChild=" & chr(34) & "TRUE"
& chr(34)
Case Else
sXmlLine = sXmlLine & " IsChainedChild=" & chr(34) & "FALSE"
& chr(34)
End Select
' ProductCode
sXmlLine = sXmlLine & " ProductCode=" & chr(34) & arrMaster(iPos
Master, COL_PRODUCTCODE) & chr(34)
' ProductVersion
sXmlLine = sXmlLine & " ProductVersion=" & chr(34) & arrMaster(i
PosMaster, COL_PRODUCTVERSION) & chr(34)
' ServicePack
sXmlLine = sXmlLine & " ServicePackLevel=" & chr(34) & arrMaster
(iPosMaster, COL_SPLEVEL) & chr(34)
' Architecture
sXmlLine = sXmlLine & " Architecture=" & chr(34) & arrMaster(iPo
sMaster, COL_ARCHITECTURE) & chr(34)
' InstallType
sXmlLine = sXmlLine & " InstallType=" & chr(34) & arrMaster(iPos
Master, COL_INSTALLTYPE) & chr(34)
' InstallDate
sXmlLine = sXmlLine & " InstallDate=" & chr(34) & Left(Replace(a
rrMaster(iPosMaster, COL_INSTALLDATE), " ", ""), 8) & chr(34)
' ProductState
sXmlLine = sXmlLine & " ProductState=" & chr(34) & arrMaster(iPo
sMaster, COL_STATESTRING) & chr(34)
' ConfigMsi
sXmlLine = sXmlLine & " ConfigMsi=" & chr(34) & arrMaster(iPosMa
ster, COL_ORIGINALMSI) & chr(34)
' BuildOrigin
sXmlLine = sXmlLine & " BuildOrigin=" & chr(34) & arrMaster(iPos
Master, COL_ORIGIN) & chr(34)
' end line
sXmlLine = sXmlLine & " >"
'flush
XmlLogStream.WriteLine sXmlLine
' Patches
XmlLogStream.WriteLine "<PatchData>"
' PatchBaseLines
XmlLogStream.WriteLine "<PatchBaseline Sequence=" & chr(34) & ar
rMaster(iPosMaster, COL_PRODUCTVERSION) & chr(34) & " >"
dicTmp.RemoveAll
Set arrTmp = Nothing
arrTmp = Split(arrMaster(iPosMaster, COL_PATCHFAMILY), ",")
For Each MspSeq in arrTmp
arrTmpInner = Split(MspSeq, ":")
sFamily = "" : sSeq = ""

sFamily = arrTmpInner(0)
sSeq = arrTmpInner(1)
If (sSeq>arrMaster(iPosMaster, COL_PRODUCTVERSION)) Then
If dicTmp.Exists(sFamily) Then
If (sSeq > dicTmp.Item(sFamily)) Then dicTmp.Item(sF
amily) = sSeq
Else
dicTmp.Add sFamily, sSeq
End If
End If
Next 'MspSeq
For Each key in dicTmp.Keys
XmlLogStream.WriteLine "<PostBaseline PatchFamily=" & chr(34
) & key & chr(34) & " Sequence=" & chr(34) & dicTmp.Item(key) & chr(34) & " />"
Next 'key
XmlLogStream.WriteLine "</PatchBaseline>"
For iPosPatch = 0 to UBound(arrPatch, 3)
If Not IsEmpty (arrPatch(iPosMaster, PATCH_PATCHCODE, iPosPa
tch)) Then
sXmlLine = "<Patch PatchedProduct=" & chr(34) & arrMaste
r(iPosMaster, COL_PRODUCTCODE) & chr(34)
For iColPatch = PATCH_LOGSTART to PATCH_LOGCHAINEDMAX
If Not IsEmpty(arrPatch(iPosMaster, iColPatch, iPosP
atch)) Then
sXmlLine = sXmlLine & " " & Replace(arrLogForma
t(ARRAY_PATCH, iColPatch), ": ", "") & "=" & chr(34) & arrPatch(iPosMaster, iCol
Patch, iPosPatch) & chr(34)
End If
Next 'iColPatch
sXmlLine = sXmlLine & " />"
XmlLogStream.WriteLine sXmlLine
End If 'IsEmpty
Next 'iPosPatch
XmlLogStream.WriteLine "</PatchData>"
'InstallSource
XmlLogStream.WriteLine "<InstallSource>"
For iColISource = IS_LOG_LBOUND To IS_LOG_UBOUND
If Not IsEmpty(arrIS(iPos, iColISource)) Then _
XmlLogStream.WriteLine "<Source " & Replace(arrLogFormat(ARR
AY_IS,iColISource)," ", "") & "=" & chr(34) & arrIS(iPosMaster, iColISource) & c
hr(34) & " />"
Next 'iColISource
XmlLogStream.WriteLine "</InstallSource>"
XmlLogStream.WriteLine "</SKU>"
End If 'fLogProduct
Next 'iPosMaster
Next 'iLogCnt
XmlLogStream.WriteLine "</OFFICEINVENTORY>"
End Sub 'WriteXmlLog
'===============================================================================
========================
Sub PrepareLog (sLogFormat)

Dim Key,MspSeq,Lic, ScenarioItem

Dim i,j,k,m,iLBound,iUBound,iAip,iPos,iPosMaster,iPosArp,iArpCnt,iChainProd,
iPosOrder,iDummy
Dim iPosPatch,iColPatch,iColISource,iPosISource,iLogCnt,iVPCnt
Dim sTmp,sText,sTextErr,sTextNotes,sCategory,sSeq,sFamily
Dim bCspCondition,fLogProduct,fDataIntegrity
Dim fLoggedVirt, fLoggedMulti, fLoggedSingle
Dim arrOrder(),arrTmp,arrTmpInner,dicTmp,arrLicData, arrC2RPackages
On Error Resume Next
fDataIntegrity = True
fLoggedMulti = False
fLoggedSingle = False
fLoggedVirt = False
'Filter contents for the log
i = -1
Redim arrOrder(18)
i = i + 1 : arrOrder(i) = COL_PRODUCTVERSION
i = i + 1 : arrOrder(i) = COL_SPLEVEL
i = i + 1 : arrOrder(i) = COL_ARCHITECTURE
i = i + 1 : arrOrder(i) = COL_INSTALLTYPE
i = i + 1 : arrOrder(i) = COL_PRODUCTCODE
i = i + 1 : arrOrder(i) = COL_PRODUCTNAME
i = i + 1 : arrOrder(i) = COL_ARPPARENTS
i = i + 1 : arrOrder(i) = COL_INSTALLDATE
i = i + 1 : arrOrder(i) = COL_USERSID
i = i + 1 : arrOrder(i) = COL_CONTEXTSTRING
i = i + 1 : arrOrder(i) = COL_STATESTRING
i = i + 1 : arrOrder(i) = COL_TRANSFORMS
i = i + 1 : arrOrder(i) = COL_ORIGINALMSI
i = i + 1 : arrOrder(i) = COL_CACHEDMSI
i = i + 1 : arrOrder(i) = COL_PRODUCTID
i = i + 1 : arrOrder(i) = COL_ORIGIN
i = i + 1 : arrOrder(i) = COL_PACKAGECODE
i = i + 1 : arrOrder(i) = COL_NOTES
i = i + 1 : arrOrder(i) = COL_ERROR
' trim content fields
For iPosMaster = 0 To UBound(arrMaster)
arrMaster(iPosMaster,COL_NOTES) = Trim(arrMaster(iPosMaster,COL_NOTES))
arrMaster(iPosMaster,COL_ERROR) = Trim(arrMaster(iPosMaster,COL_ERROR))
If Right(arrMaster(iPosMaster,COL_NOTES),1) = "," Then arrMaster(iPosMas
ter,COL_NOTES) = Left(arrMaster(iPosMaster,COL_NOTES),Len(arrMaster(iPosMaster,C
OL_NOTES))-1)
If Right(arrMaster(iPosMaster,COL_ERROR),1) = "," Then arrMaster(iPosMas
ter,COL_ERROR) = Left(arrMaster(iPosMaster,COL_ERROR),Len(arrMaster(iPosMaster,C
OL_ERROR))-1)
If arrMaster(iPosMaster,COL_NOTES) = "" Then arrMaster(iPosMaster,COL_NO
TES) = "-"
If arrMaster(iPosMaster,COL_ERROR) = "" Then arrMaster(iPosMaster,COL_ER
ROR) = "-"
If Left(arrMaster(iPosMaster,COL_ARPPARENTS),1)="," Then arrMaster(iPosM
aster,COL_ARPPARENTS)=Replace(arrMaster(iPosMaster,COL_ARPPARENTS),",","",1,1,1)
Next 'iPosMaster
Set dicTmp = CreateObject("Scripting.Dictionary")
' prepare Virtualized C2R Products
' --------------------------------

If UBound(arrVirtProducts) > -1 OR UBound(arrVirt2Products) > -1 Then

CacheLog LOGPOS_PRODUCT,LOGHEADING_H1,Null,"C2R Products"
fLoggedVirt = True
If UBound(arrVirt2Products) > -1 Then
' Scenario key state
CacheLog LOGPOS_PRODUCT,LOGHEADING_H2,Null, "Scenario Key State
(applicable for all 2013 C2R products)"
For Each ScenarioItem in dicScenario.Keys
CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE, ScenarioItem, dicSc
enario.Item(ScenarioItem)
Next 'ScenarioItem
For iVPCnt = 0 To UBound(arrVirt2Products, 1)
' ProductName (heading)
sText = "" : sText = arrVirt2Products(iVPCnt,COL_PRODUCTNAME)
CacheLog LOGPOS_PRODUCT,LOGHEADING_H2,Null,sText
' ProductVersion
sText = "" : sText = arrVirt2Products(iVPCnt,VIRTPROD_PRODUCTVER
SION)
CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE,arrLogFormat(ARRAY_VIRTP
ROD,VIRTPROD_PRODUCTVERSION),sText
' SP Level
sText = "" : sText = arrVirt2Products(iVPCnt,VIRTPROD_SPLEVEL)
CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE,arrLogFormat(ARRAY_VIRTP
ROD,VIRTPROD_SPLEVEL),sText
' Architecture
sText = "" : sText = arrVirt2Products(iVPCnt,VIRTPROD_BITNESS)
CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE,arrLogFormat(ARRAY_VIRTP
ROD,VIRTPROD_BITNESS),sText
' InstallType
CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE, "InstallType", "C2R"
' ConfigName
sText = "" : sText = arrVirt2Products(iVPCnt,VIRTPROD_CONFIGNAME
)
CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE,arrLogFormat(ARRAY_VIRTP
ROD,VIRTPROD_CONFIGNAME),sText
' Child Packages
arrC2RPackages = Split(arrVirt2Products(iVPCnt,VIRTPROD_CHILDPAC
KAGES), ";")
For i = 0 To UBound(arrC2RPackages)
If i = 0 Then CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE, "Chai
ned Packages", arrC2RPackages(i) _
Else CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE, "", arrC2RPack
ages(i)
Next 'i
'LicenseData
'----------If arrVirt2Products(iVPCnt,VIRTPROD_OSPPLICENSE) <> "" Then
arrLicData = Split(arrVirt2Products(iVPCnt,VIRTPROD_OSPPLICE
NSE), "#;#")
If CheckArray(arrLicData) Then
If NOT fBasicMode Then CacheLog LOGPOS_PRODUCT,LOGHEADIN
G_NONE,"",""
i = 0
For Each Lic in arrLicData
arrTmp = Split(Lic, ";")
If LCase(arrTmp(0)) = "active license" Then i = 1
If i < 2 Then

CacheLog LOGPOS_PRODUCT, LOGHEADING_NONE, arrTmp

(0), arrTmp(1)
Else
If NOT (fBasicMode AND i > 5) Then
CacheLog LOGPOS_PRODUCT, LOGHEADING_NONE, ""
, arrTmp(0) & ":" & Space(25 - Len(arrTmp(0))) & arrTmp(1)
End If
End If
i = i + 1
Next 'Lic
End If 'arrLicData
End If 'arrMaster
Next 'iVPCnt
ElseIf UBound(arrVirtProducts) > -1 Then
For iVPCnt = 0 To UBound(arrVirtProducts, 1)
sText = "" : sText = arrVirtProducts(iVPCnt,COL_PRODUCTNAME)
CacheLog LOGPOS_PRODUCT,LOGHEADING_H2,Null,sText
sText = "" : sText = arrVirtProducts(iVPCnt,VIRTPROD_PRODUCTVERS
ION)
CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE,arrLogFormat(ARRAY_VIRTP
ROD,VIRTPROD_PRODUCTVERSION),sText
sText = "" : sText = arrVirtProducts(iVPCnt,VIRTPROD_SPLEVEL)
CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE,arrLogFormat(ARRAY_VIRTP
ROD,VIRTPROD_SPLEVEL),sText
sText = "" : sText = arrVirtProducts(iVPCnt,COL_PRODUCTCODE)
CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE,arrLogFormat(ARRAY_VIRTP
ROD,COL_PRODUCTCODE),sText
Next 'iVPCnt
End If
CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE,"",vbCrLf & String(160,"*") & vb
CrLf
Else
'No virtualized products found
End If
'Prepare Office 12, 14 & 15 Products
'------------------------------If CheckArray(arrArpProducts) Then
CacheLog LOGPOS_PRODUCT,LOGHEADING_H1,Null,"Chained Products View"
fLoggedMulti = True
For iArpCnt = 0 To UBound(arrArpProducts)
' extra loop to allow exit out of a bad product
For iDummy = 1 To 1
' get the link to the configuration .MSI
iPos = GetArrayPosition(arrMaster,arrArpProducts(iArpCnt,ARP_CONFIGP
RODUCTCODE))
If iPos = -1 Then
If NOT dicMissingChild.Exists(arrArpProducts(iArpCnt,ARP_CONFIGP
RODUCTCODE)) Then Cachelog LOGPOS_REVITEM,LOGHEADING_NONE,ERR_CATEGORYERROR,ERR_
DATAINTEGRITY
End If
'If possible use the entry as shown under ARP as heading for the log
sText = "" : sText = GetArpProductName(arrArpProducts(iArpCnt,COL_CO
NFIGNAME))
If (sText = "" AND iPos=-1) Then sText = arrMaster(iPos,COL_ARPPRODU
CTNAME)
CacheLog LOGPOS_PRODUCT,LOGHEADING_H2,Null,sText

'Contents from master array

'-------------------------For iPosOrder = 0 To UBound(arrOrder)-2 '-2 to exclude Notes and Err
or fields
If fBasicMode AND iPosOrder > 1 Then Exit For
sText = "" : If NOT iPos=-1 Then sText = arrMaster(iPos,arrOrder
(iPosOrder))
'Suppress Configuration SKU for ARP config products. Log all oth
ers
If NOT arrOrder(iPosOrder) = COL_ARPPARENTS Then CacheLog LOGPOS
_PRODUCT,LOGHEADING_NONE,arrLogFormat(ARRAY_MASTER,arrOrder(iPosOrder)),sText
Next 'iPosOrder
If NOT fBasicMode Then
'Add Notes and Errors from chained products to ArpProd column
sTextNotes = "" : sTextErr = ""
For iChainProd = COL_LBOUNDCHAINLIST To UBound(arrArpProducts,2)
If IsEmpty(arrArpProducts(iArpCnt,iChainProd)) Then Exit For
iPosMaster = GetArrayPosition(arrMaster,arrArpProducts(iArpC
nt,iChainProd))
If iPosMaster = -1 AND NOT dicMissingChild.Exists(arrArpProd
ucts(iArpCnt,iChainProd)) Then Cachelog LOGPOS_REVITEM,LOGHEADING_NONE,ERR_CATEG
ORYERROR,ERR_DATAINTEGRITY
'Only run if iPosMaster has a valid index #
If Not iPosMaster = -1 Then
If Not arrMaster(iPosMaster,COL_NOTES) = "-" Then
sTextNotes = sTextNotes & arrMaster(iPosMaster,COL_P
RODUCTCODE) & DSV & arrMaster(iPosMaster,COL_NOTES)
End If 'arrMaster(iPosMaster,COL_NOTES) = "-"
If Not arrMaster(iPosMaster,COL_ERROR) = "-" Then
sTextErr = sTextErr & arrMaster(iPosMaster,COL_PRODU
CTCODE) & DSV & arrMaster(iPosMaster,COL_ERROR)
End If 'arrMaster(iPosMaster,COL_NOTES) = "-"
End If 'Not iPosMaster = -1
Next 'iChainProd
If sTextNotes = "" Then sTextNotes = "-"
If sTextErr = "" Then sTextErr = "-"
CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE,arrLogFormat(ARRAY_MASTE
R,COL_NOTES),sTextNotes
CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE,arrLogFormat(ARRAY_MASTE
R,COL_ERROR),sTextErr
'Configuration ProductName
'------------------------sText = "" : sText = arrArpProducts(iArpCnt,COL_CONFIGNAME)
If InStr(sText,".")>0 Then sText = Mid(sText,InStr(sText,".")+1)
CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE,arrLogFormat(ARRAY_ARP,C
OL_CONFIGNAME),sText
'Configuration PackageID
sText = "" : sText = arrArpProducts(iArpCnt,COL_CONFIGPACKAGEID)
CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE,arrLogFormat(ARRAY_ARP,C
OL_CONFIGPACKAGEID),sText
'Chained packages
'---------------CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE,"",""
sCategory = "Chained Packages"
For iChainProd = COL_LBOUNDCHAINLIST To UBound(arrArpProducts,2)
If IsEmpty(arrArpProducts(iArpCnt,iChainProd)) Then Exit For

iPosMaster = GetArrayPosition(arrMaster,arrArpProducts(iArpC
nt,iChainProd))
If iPosMaster = -1 AND NOT dicMissingChild.Exists(arrArpPro
ducts(iArpCnt,iChainProd)) Then Cachelog LOGPOS_REVITEM,LOGHEADING_NONE,ERR_CATE
GORYERROR,ERR_DATAINTEGRITY
'Only run if iPosMaster has a valid index #
If Not iPosMaster = -1 Then
sText = "" : sText = arrMaster(iPosMaster,COL_PRODUCTCOD
E) & DSV & arrMaster(iPosMaster,COL_PRODUCTVERSION) & DSV & arrMaster(iPosMaster
,COL_PRODUCTNAME)
CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE,sCategory,sText
sCategory = ""
Else
sText = "" : sText = arrArpProducts(iArpCnt,iChainProd)
& DSV & "Error - missing chained product!"
CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE,sCategory,sText
sCategory = ""
End If 'Not iPosMaster = -1
Next 'iChainProd
End If 'fBasicMode
'LicenseData
'----------If NOT iPos = -1 Then
If arrMaster(iPos,COL_OSPPLICENSE) <> "" Then
arrLicData = Split(arrMaster(iPos,COL_OSPPLICENSE),"#;#")
If CheckArray(arrLicData) Then
If NOT fBasicMode Then CacheLog LOGPOS_PRODUCT,LOGHEADIN
G_NONE,"",""
i = 0
For Each Lic in arrLicData
arrTmp = Split(Lic,";")
If LCase(arrTmp(0)) = "active license" Then i = 1
If i < 2 Then
CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE,arrTmp(0
),arrTmp(1)
Else
If NOT (fBasicMode AND i > 5) Then
CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE,"",a
rrTmp(0)&":"& Space(25-Len(arrTmp(0)))&arrTmp(1)
End If
End If
i = i + 1
Next 'Lic
End If 'arrLicData
End If 'arrMaster
End If 'iPos -1
If NOT fBasicMode Then
'Patches
'------CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE,"",""
sCategory = "Patch Baseline"
sText = "" : If NOT iPos = -1 Then sText = arrMaster(iPos,COL_PR
ODUCTVERSION)
CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE,sCategory,sText
sCategory = "Post Baseline Sequences"
dicTmp.RemoveAll
For iChainProd = COL_LBOUNDCHAINLIST To UBound(arrArpProducts,2)

If IsEmpty(arrArpProducts(iArpCnt,iChainProd)) Then Exit For

iPosMaster = GetArrayPosition(arrMaster,arrArpProducts(iArpC
nt,iChainProd))
If iPosMaster = -1 AND NOT dicMissingChild.Exists(arrArpPro
ducts(iArpCnt,iChainProd)) Then Cachelog LOGPOS_REVITEM,LOGHEADING_NONE,ERR_CATE
GORYERROR,ERR_DATAINTEGRITY
'Only run if iPosMaster has a valid index #
If Not iPosMaster = -1 Then
Set arrTmp = Nothing
arrTmp = Split(arrMaster(iPosMaster,COL_PATCHFAMILY),","
)
For Each MspSeq in arrTmp
arrTmpInner = Split(MspSeq,":")
sFamily = "" : sSeq = ""
sFamily = arrTmpInner(0)
sSeq = arrTmpInner(1)
If (sSeq>arrMaster(iPosMaster,COL_PRODUCTVERSION)) T
hen
If dicTmp.Exists(sFamily) Then
If (sSeq > dicTmp.Item(sFamily)) Then dicTmp
.Item(sFamily)=sSeq
Else
dicTmp.Add sFamily,sSeq
End If
End If
Next 'MspSeq
End If 'Not iPosMaster = -1
Next 'iChainProd
For Each Key in dicTmp.Keys
CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE,sCategory,dicTmp.Ite
m(Key)&" - "&Key
sCategory = ""
Next
sCategory = "Patchlist by product"
For iChainProd = COL_LBOUNDCHAINLIST To UBound(arrArpProducts,2)
If IsEmpty(arrArpProducts(iArpCnt,iChainProd)) Then Exit For
iPosMaster = GetArrayPosition(arrMaster,arrArpProducts(iArpC
nt,iChainProd))
If iPosMaster = -1 AND NOT dicMissingChild.Exists(arrArpPro
ducts(iArpCnt,iChainProd)) Then Cachelog LOGPOS_REVITEM,LOGHEADING_NONE,ERR_CATE
GORYERROR,ERR_DATAINTEGRITY
'Only run if iPosMaster has a valid index #
If Not iPosMaster = -1 Then
For iPosPatch = 0 to UBound(arrPatch,3)
If Not IsEmpty (arrPatch(iPosMaster,PATCH_PATCHCODE,
iPosPatch)) Then
If iPosPatch = 0 Then CacheLog LOGPOS_PRODUCT,LO
GHEADING_NONE,"",""
If iPosPatch = 0 Then CacheLog LOGPOS_PRODUCT,LO
GHEADING_NONE,sCategory,arrMaster(iPosMaster,COL_PRODUCTNAME)&" - "&arrMaster(iP
osMaster,COL_PRODUCTCODE)
sCategory = ""
sText = " "
For iColPatch = PATCH_LOGSTART to PATCH_LOGCHAIN
EDMAX
If Not IsEmpty(arrPatch(iPosMaster,iColPatch
,iPosPatch)) Then sText = sText & arrLogFormat(ARRAY_PATCH,iColPatch) & arrPatch
(iPosMaster,iColPatch,iPosPatch) & CSV
Next 'iColPatch

CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE,sCategor
y,RTrimComma(sText)
End If 'IsEmpty
Next 'iPosPatch
End If ' Not iPosMaster = -1
Next 'iChainProd
'InstallSource
'------------CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE,"",""
For iColISource = IS_LOG_LBOUND To IS_LOG_UBOUND
If NOT iPos = -1 Then
If Not IsEmpty(arrIS(iPos,iColISource)) Then _
CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE,arrLogFormat(ARR
AY_IS,iColISource),arrIS(iPos,iColISource)
End If
Next 'iColISource
End If 'fBasicMode
Next 'iDummy
Next 'iArpCnt
If fLoggedMulti Then CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE,"",vbCrLf & Str
ing(160,"*") & vbCrLf
End If 'CheckArray(arrArpProducts)
'Prepare Other Products
'======================
Err.Clear
For iLogCnt = 0 To 10
For iPosMaster = 0 To UBound(arrMaster)
fLogProduct = CheckLogProduct(iLogCnt, iPosMaster)
If fLogProduct Then
If NOT fLoggedSingle Then CacheLog LOGPOS_PRODUCT, LOGHEADING_H1
, Null, "Single .msi Products View"
fLoggedSingle = True
For iDummy = 1 To 1
'arrMaster contents
'-----------------sText = "" : sText = arrMaster(iPosMaster,COL_ARPPRODUCTNAME)
If sText = "" Then sText = arrMaster(iPosMaster,COL_PRODUCTNAME)
CacheLog LOGPOS_PRODUCT,LOGHEADING_H2,Null,sText
If arrMaster(iPosMaster,COL_STATE) = INSTALLSTATE_UNKNOWN Then
sText = arrMaster(iPosMaster,COL_PRODUCTCODE)
CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE,arrLogFormat(ARRAY_M
ASTER,COL_PRODUCTCODE),sText
sText = arrMaster(iPosMaster,COL_USERSID)
CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE,arrLogFormat(ARRAY_M
ASTER,COL_USERSID),sText
sText = arrMaster(iPosMaster,COL_CONTEXTSTRING)
CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE,arrLogFormat(ARRAY_M
ASTER,COL_CONTEXTSTRING),sText
sText = arrMaster(iPosMaster,COL_STATESTRING)
CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE,arrLogFormat(ARRAY_M
ASTER,COL_STATESTRING),sText
Exit For 'Dummy
End If 'arrMaster(iPosMster,COL_STATE) = INSTALLSTATE_UNKNOWN
For iPosOrder = 0 To UBound(arrOrder)
If fBasicMode AND iPosOrder > 1 Then Exit For
sText = "" : sText = arrMaster(iPosMaster,arrOrder(iPosOrder

))
If Not IsEmpty(arrMaster(iPosMaster,arrOrder(iPosOrder))) Th
en
CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE,arrLogFormat(ARR
AY_MASTER,arrOrder(iPosOrder)),sText
If arrMaster(iPosMaster,arrOrder(iPosOrder)) = "Unknown"
Then Exit For
End If
Next 'iPosOrder
If NOT fBasicMode Then
'Patches
'------CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE,"",""
'First loop will take care of client side patches
'Second loop will log patches in the InstallSource
sCategory = "Patch Baseline"
CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE,sCategory,arrMaster(
iPosMaster,COL_PRODUCTVERSION)
sCategory = "Post Baseline Sequences"
dicTmp.RemoveAll
Set arrTmp = Nothing
arrTmp = Split(arrMaster(iPosMaster,COL_PATCHFAMILY),",")
For Each MspSeq in arrTmp
arrTmpInner = Split(MspSeq,":")
dicTmp.Add arrTmpInner(0),arrTmpInner(1)
Next 'MspSeq
For Each Key in dicTmp.Keys
CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE,sCategory,dicTmp
.Item(Key)&" - "&Key
sCategory = ""
Next
sCategory = "Client side patches"
bCspCondition = True
For iAip = 0 To 1
For iPosPatch = 0 to UBound(arrPatch,3)
If Not (IsEmpty (arrPatch(iPosMaster,PATCH_PATCHCODE
,iPosPatch))) AND (arrPatch(iPosMaster,PATCH_CSP,iPosPatch) = bCspCondition) The
n
sText = ""
For iColPatch = PATCH_LOGSTART to PATCH_LOGMAX
If Not IsEmpty(arrPatch(iPosMaster,iColPatch
,iPosPatch)) Then sText = sText & arrLogFormat(ARRAY_PATCH,iColPatch) & arrPatch
(iPosMaster,iColPatch,iPosPatch) & CSV
Next 'iColPatch
CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE,sCategor
y,sText
sCategory = ""
End If 'IsEmpty
Next 'iPosPatch
sCategory = "Patches in InstallSource"
bCspCondition = False
Next 'iAip
'InstallSource
'------------CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE,"",""

For iColISource = IS_LOG_LBOUND To IS_LOG_UBOUND

If Not IsEmpty(arrIS(iPosMaster,iColISource)) Then _
CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE,arrLogFormat(ARR
AY_IS,iColISource),arrIS(iPosMaster,iColISource)
Next 'iColISource
'FeatureStates
'------------CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE,"",""
If fFeatureTree Then
CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE,"FeatureStates",
arrFeature(iPosMaster,FEATURE_TREE)
End If 'fFeatureTree
End If 'fBasicMode
Next 'iDummy
End If 'fLogProduct
Next 'iPosMaster
Next 'iLogCnt
If fLoggedSingle Then CacheLog LOGPOS_PRODUCT,LOGHEADING_NONE,"",vbCrLf & St
ring(160,"*") & vbCrLf
End Sub 'PrepareLog
'===============================================================================
========================
Sub Cachelog (iArrLogPosition,iHeading,sCategory,sText)
On Error Resume Next
If Not iHeading = 0 Then sText = FormatHeading(iHeading,sText)
If Not IsNull(sCategory) Then sCategory = FormatCategory(sCategory)
If iArrLogPosition = LOGPOS_REVITEM Then
If Not InStr(arrLog(iArrLogPosition),sText)>0 Then _
arrLog(iArrLogPosition) = arrLog(iArrLogPosition) & sCategory & sText &
vbCrLf
Else
arrLog(iArrLogPosition) = arrLog(iArrLogPosition) & sCategory & sText &v
bCrLf
End If
End Sub
'===============================================================================
========================
Function CheckLogProduct (iLogCnt, iPosMaster)
Dim fLogProduct
Select Case iLogCnt
Case 0 'Add-Ins
fLogProduct = False
fLogProduct = fLogProduct OR (InStr(POWERPIVOT_2010,arrMaster(iPosMaster
,COL_UPGRADECODE)) > 0 AND Len(arrMaster(iPosMaster,COL_UPGRADECODE)) = 38)
Case 1 'Office 15
fLogProduct = fLogChainedDetails AND arrMaster(iPosMaster,COL_ISOFFICEPR
ODUCT) AND GetVersionMajor(arrMaster(iPosMaster,COL_PRODUCTCODE))=15
Case 2 'Office 15 Single Msi Products
fLogProduct = NOT fLogChainedDetails AND _
arrMaster(iPosMaster,COL_ISOFFICEPRODUCT) AND _
( (NOT arrMaster(iPosMaster,COL_SYSTEMCOMPONENT)=1) OR (
NOT arrMaster(iPosMaster,COL_SYSTEMCOMPONENT)=0 AND arrMaster(iPosMaster,COL_ARP

PARENTCOUNT)=0) ) AND _
IsEmpty(arrMaster(iPosMaster,COL_ARPPARENTCOUNT)) AND _
GetVersionMajor(arrMaster(iPosMaster,COL_PRODUCTCODE))=1
5
Case 3 'Office 14
fLogProduct = fLogChainedDetails AND arrMaster(iPosMaster,COL_ISOFFICEPR
ODUCT) AND GetVersionMajor(arrMaster(iPosMaster,COL_PRODUCTCODE))=14
Case 4 'Office 14 Single Msi Products
fLogProduct = NOT fLogChainedDetails AND _
arrMaster(iPosMaster,COL_ISOFFICEPRODUCT) AND _
( (NOT arrMaster(iPosMaster,COL_SYSTEMCOMPONENT)=1) OR (
NOT arrMaster(iPosMaster,COL_SYSTEMCOMPONENT)=0 AND arrMaster(iPosMaster,COL_ARP
PARENTCOUNT)=0) ) AND _
IsEmpty(arrMaster(iPosMaster,COL_ARPPARENTCOUNT)) AND _
GetVersionMajor(arrMaster(iPosMaster,COL_PRODUCTCODE))=1
4
Case 5 'Office 12
fLogProduct = fLogChainedDetails AND arrMaster(iPosMaster,COL_ISOFFICEPR
ODUCT) AND GetVersionMajor(arrMaster(iPosMaster,COL_PRODUCTCODE))=12
Case 6 'Office 12 Single Msi Products
fLogProduct = NOT fLogChainedDetails AND _
arrMaster(iPosMaster,COL_ISOFFICEPRODUCT) AND _
( (NOT arrMaster(iPosMaster,COL_SYSTEMCOMPONENT)=1) OR (
NOT arrMaster(iPosMaster,COL_SYSTEMCOMPONENT)=0 AND arrMaster(iPosMaster,COL_ARP
PARENTCOUNT)=0) ) AND _
IsEmpty(arrMaster(iPosMaster,COL_ARPPARENTCOUNT)) AND _
GetVersionMajor(arrMaster(iPosMaster,COL_PRODUCTCODE))=1
2
Case 7 'Office 11
fLogProduct = arrMaster(iPosMaster,COL_ISOFFICEPRODUCT) AND GetVersionMa
jor(arrMaster(iPosMaster,COL_PRODUCTCODE))=11
Case 8 'Office 10
fLogProduct = arrMaster(iPosMaster,COL_ISOFFICEPRODUCT) AND GetVersionMa
jor(arrMaster(iPosMaster,COL_PRODUCTCODE))=10
Case 9 'Office 9
fLogProduct = arrMaster(iPosMaster,COL_ISOFFICEPRODUCT) AND GetVersionMa
jor(arrMaster(iPosMaster,COL_PRODUCTCODE))=9
Case 10 'Non Office Products
fLogProduct = fListNonOfficeProducts AND NOT arrMaster(iPosMaster,COL_IS
OFFICEPRODUCT)
Case Else
End Select
CheckLogProduct = fLogProduct
End Function 'CheckLogProduct
'===============================================================================
========================
Function FormatCategory(sCategory)
Dim sTmp : Dim i
On Error Resume Next
Const iCATLEN = 30
sTmp = sTmp & Space(iCATLEN-Len(sCategory)-1)
FormatCategory = sCategory & sTmp
End Function
'===============================================================================
========================

Function FormatHeading(iHeading,sText)
Dim sTmp, sStyle
Dim i
On Error Resume Next
Select Case iHeading
Case LOGHEADING_H1: sStyle = "="
Case LOGHEADING_H2: sStyle = "-"
Case Else: sStyle =" "
End Select
sTmp = sTmp & String(Len(sText),sStyle)
FormatHeading = vbCrLf & vbCrLf & sText & vbCrlf & sTmp
End Function
'===============================================================================
========================
'Module Global Helper Functions
'===============================================================================
========================
'===============================================================================
========================
Sub RelaunchElevated
Dim Argument
Dim sCmdLine
Dim oShell,oWShell
Set oShell = CreateObject("Shell.Application")
Set oWShell = CreateObject("Wscript.Shell")
sCmdLine = Chr(34) & WScript.scriptFullName & Chr(34)
If Wscript.Arguments.Count > 0 Then
For Each Argument in Wscript.Arguments
If Argument = "UAC" Then Exit Sub
sCmdLine = sCmdLine & " " & chr(34) & Argument & chr(34)
Next 'Argument
End If
oShell.ShellExecute oWShell.ExpandEnvironmentStrings("%windir%") & "\system3
2\cscript.exe",sCmdLine & " UAC", "", "runas", 1
Wscript.Quit
End Sub 'RelaunchElevated
'===============================================================================
========================
Sub RelaunchAsCScript
Dim Argument
Dim sCmdLine
sCmdLine = oShell.ExpandEnvironmentStrings("%windir%") & "\system32\cscript.
exe " & 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
oShell.Run sCmdLine,1,False

Wscript.Quit
End Sub 'RelaunchAsCScript
'===============================================================================
========================
'Launch a Shell command, wait for the task to complete and return the result
Function Command(sCommand)
Dim oExec
Dim sCmdOut
Set oExec = oShell.Exec(sCommand)
sCmdOut = oExec.StdOut.ReadAll()
Do While oExec.Status = 0
WScript.Sleep 100
Loop
Command = oExec.ExitCode & " - " & sCmdOut
End Function
'===============================================================================
========================
Sub CopyToZip (ShellNameSpace, fsoFile)
Dim fCopyComplete
Dim item,ShellFolder
Dim i
Set ShellFolder = ShellNameSpace
fCopyComplete = False
ShellNameSpace.CopyHere fsoFile.Path,COPY_OVERWRITE
For Each item in ShellFolder.Items
If item.Name = fsoFile.Name Then fCopyComplete = True
Next 'item
i = 0
While NOT fCopyComplete
WScript.Sleep 500
i = i + 1
For Each item in ShellFolder.Items
If item.Name = fsoFile.Name Then fCopyComplete = True
Next 'item
' hang protection
If i > 12 Then
fCopyComplete = True
fZipError = True
End If
Wend
End Sub
'===============================================================================
========================
'Function to compare to numbers of unspecified format
Function CompareVersion(sFile1, sFile2, bAllowBlanks)
'Return values:
'Left file version is lower than right file version
'Left file version is identical to right file version
'Left file version is higher than right file version
'Invalid comparison
Dim file1, file2
Dim sDelimiter
Dim iCnt, iAsc, iMax, iF1, iF2

-1
0
1
2

Dim bLEmpty,bREmpty
CompareVersion = 0
bLEmpty = False
bREmpty = False
'Ensure valid inputs values
On Error Resume Next
If IsEmpty(sFile1) Then bLEmpty = True
If IsEmpty(sFile2) Then bREmpty = True
If sFile1 = "" Then bLEmpty = True
If sFile2 = "" Then bREmpty = True
' don't allow alpha characters
If Not bLEmpty Then
For iCnt = 1 To Len(sFile1)
iAsc = Asc(UCase(Mid(sFile1,iCnt,1)))
If (iAsc>64) AND (iAsc<91) Then
CompareVersion = 2
Exit Function
End If
Next 'iCnt
End If
If Not bREmpty Then
For iCnt = 1 To Len(sFile2)
iAsc = Asc(UCase(Mid(sFile2,iCnt,1)))
If (iAsc>64) AND (iAsc<91) Then
CompareVersion = 2
Exit Function
End If
Next 'iCnt
End If
If bLEmpty AND (NOT bREmpty) Then
If bAllowBlanks Then CompareVersion = -1 Else CompareVersion = 2
Exit Function
End If
If (NOT bLEmpty) AND bREmpty Then
If bAllowBlanks Then CompareVersion = 1 Else CompareVersion = 2
Exit Function
End If
If bLEmpty AND bREmpty Then
CompareVersion = 2
Exit Function
End If
' if Files are identical we're already done
If sFile1 = sFile2 Then Exit Function
' split the VersionString
file1 = Split(sFile1,Delimiter(sFile1))
file2 = Split(sFile2,Delimiter(sFile2))
' ensure we get the lower count
iMax = UBound(file1)
CompareVersion = -1
If iMax > UBound(file2) Then
iMax = UBound(file2)
CompareVersion = 1
End If
' compare the file versions

For iCnt = 0 To iMax

iF1 = CLng(file1(iCnt))
iF2 = CLng(file2(iCnt))
If iF1 > iF2 Then
CompareVersion = 1
Exit For
ElseIf iF1 < iF2 Then
CompareVersion = -1
Exit For
End If
Next 'iCnt
End Function
'===============================================================================
========================
'hexArraytoString
Function hAtS(arrHex)
Dim c,s
On Error Resume Next
hAtS = "" : s = ""
If NOT IsArray(arrHex) Then Exit Function
For Each c in arrHex
s = s & Chr(CInt("&h" & c))
Next 'c
hAts = s
End Function
'===============================================================================
========================
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
'===============================================================================
========================
'Get the culture info tag from LCID
Function GetCultureInfo (sLcid)
Dim sLang
Select Case UCase(Hex(CInt(sLcid)))
Case "7F" : sLang = ""
'Invariant culture
Case "36" : sLang = "af"
' Afrikaans
Case "436" : sLang = "af-ZA"
' Afrikaans (South Africa)
Case "1C" : sLang = "sq"
' Albanian
Case "41C" : sLang = "sq-AL"
' Albanian (Albania)
Case "1" : sLang = "ar" ' Arabic
Case "1401" : sLang = "ar-DZ"
' Arabic (Algeria)
Case "3C01" : sLang = "ar-BH"
' Arabic (Bahrain)
Case "C01" : sLang = "ar-EG"
' Arabic (Egypt)

Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case

"801" : sLang = "ar-IQ"

' Arabic (Iraq)
"2C01" : sLang = "ar-JO"
' Arabic (Jordan)
"3401" : sLang = "ar-KW"
' Arabic (Kuwait)
"3001" : sLang = "ar-LB"
' Arabic (Lebanon)
"1001" : sLang = "ar-LY"
' Arabic (Libya)
"1801" : sLang = "ar-MA"
' Arabic (Morocco)
"2001" : sLang = "ar-OM"
' Arabic (Oman)
"4001" : sLang = "ar-QA"
' Arabic (Qatar)
"401" : sLang = "ar-SA"
' Arabic (Saudi Arabia)
"2801" : sLang = "ar-SY"
' Arabic (Syria)
"1C01" : sLang = "ar-TN"
' Arabic (Tunisia)
"3801" : sLang = "ar-AE"
' Arabic (U.A.E.)
"2401" : sLang = "ar-YE"
' Arabic (Yemen)
"2B" : sLang = "hy"
' Armenian
"42B" : sLang = "hy-AM"
' Armenian (Armenia)
"2C" : sLang = "az"
' Azeri
"82C" : sLang = "az-Cyrl-AZ"
' Azeri (Azerbaijan, Cyrillic)
"42C" : sLang = "az-Latn-AZ"
' Azeri (Azerbaijan, Latin)
"2D" : sLang = "eu"
' Basque
"42D" : sLang = "eu-ES"
' Basque (Basque)
"23" : sLang = "be"
' Belarusian
"423" : sLang = "be-BY"
' Belarusian (Belarus)
"2" : sLang = "bg" ' Bulgarian
"402" : sLang = "bg-BG"
' Bulgarian (Bulgaria)
"3" : sLang = "ca" ' Catalan
"403" : sLang = "ca-ES"
' Catalan (Catalan)
"C04" : sLang = "zh-HK"
' Chinese (Hong Kong SAR, PRC)
"1404" : sLang = "zh-MO"
' Chinese (Macao SAR)
"804" : sLang = "zh-CN"
' Chinese (PRC)
"4" : sLang = "zh-Hans"
' Chinese (Simplified)
"1004" : sLang = "zh-SG"
' Chinese (Singapore)
"404" : sLang = "zh-TW"
' Chinese (Taiwan)
"7C04" : sLang = "zh-Hant" ' Chinese (Traditional)
"1A" : sLang = "hr"
' Croatian
"41A" : sLang = "hr-HR"
' Croatian (Croatia)
"5" : sLang = "cs" ' Czech
"405" : sLang = "cs-CZ"
' Czech (Czech Republic)
"6" : sLang = "da" ' Danish
"406" : sLang = "da-DK"
' Danish (Denmark)
"65" : sLang = "dv"
' Divehi
"465" : sLang = "dv-MV"
' Divehi (Maldives)
"13" : sLang = "nl"
' Dutch
"813" : sLang = "nl-BE"
' Dutch (Belgium)
"413" : sLang = "nl-NL"
' Dutch (Netherlands)
"9" : sLang = "en" ' English
"C09" : sLang = "en-AU"
' English (Australia)
"2809" : sLang = "en-BZ"
' English (Belize)
"1009" : sLang = "en-CA"
' English (Canada)
"2409" : sLang = "en-029" ' English (Caribbean)
"1809" : sLang = "en-IE"
' English (Ireland)
"2009" : sLang = "en-JM"
' English (Jamaica)
"1409" : sLang = "en-NZ"
' English (New Zealand)
"3409" : sLang = "en-PH"
' English (Philippines)
"1C09" : sLang = "en-ZA"
' English (South Africa
"2C09" : sLang = "en-TT"
' English (Trinidad and Tobago)
"809" : sLang = "en-GB"
' English (United Kingdom)
"409" : sLang = "en-US"
' English (United States)
"3009" : sLang = "en-ZW"
' English (Zimbabwe)
"25" : sLang = "et"
' Estonian
"425" : sLang = "et-EE"
' Estonian (Estonia)

Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case

"38" : sLang = "fo"

' Faroese
"438" : sLang = "fo-FO"
' Faroese (Faroe Islands)
"29" : sLang = "fa"
' Farsi
"429" : sLang = "fa-IR"
' Farsi (Iran)
"B" : sLang = "fi" ' Finnish
"40B" : sLang = "fi-FI"
' Finnish (Finland)
"C" : sLang = "fr" ' French
"80C" : sLang = "fr-BE"
' French (Belgium)
"C0C" : sLang = "fr-CA"
' French (Canada)
"40C" : sLang = "fr-FR"
' French (France)
"140C" : sLang = "fr-LU"
' French (Luxembourg)
"180C" : sLang = "fr-MC"
' French (Monaco)
"100C" : sLang = "fr-CH"
' French (Switzerland)
"56" : sLang = "gl"
' Galician
"456" : sLang = "gl-ES"
' Galician (Spain)
"37" : sLang = "ka"
' Georgian
"437" : sLang = "ka-GE"
' Georgian (Georgia)
"7" : sLang = "de" ' German
"C07" : sLang = "de-AT"
' German (Austria)
"407" : sLang = "de-DE"
' German (Germany)
"1407" : sLang = "de-LI"
' German (Liechtenstein)
"1007" : sLang = "de-LU"
' German (Luxembourg)
"807" : sLang = "de-CH"
' German (Switzerland)
"8" : sLang = "el" ' Greek
"408" : sLang = "el-GR"
' Greek (Greece)
"47" : sLang = "gu"
' Gujarati
"447" : sLang = "gu-IN"
' Gujarati (India)
"D" : sLang = "he" ' Hebrew
"40D" : sLang = "he-IL"
' Hebrew (Israel)
"39" : sLang = "hi"
' Hindi
"439" : sLang = "hi-IN"
' Hindi (India)
"E" : sLang = "hu" ' Hungarian
"40E" : sLang = "hu-HU"
' Hungarian (Hungary)
"F" : sLang = "is" ' Icelandic
"40F" : sLang = "is-IS"
' Icelandic (Iceland)
"21" : sLang = "id"
' Indonesian
"421" : sLang = "id-ID"
' Indonesian (Indonesia)
"10" : sLang = "it"
' Italian
"410" : sLang = "it-IT"
' Italian (Italy)
"810" : sLang = "it-CH"
' Italian (Switzerland)
"11" : sLang = "ja"
' Japanese
"411" : sLang = "ja-JP"
' Japanese (Japan)
"4B" : sLang = "kn"
' Kannada
"44B" : sLang = "kn-IN"
' Kannada (India)
"3F" : sLang = "kk"
' Kazakh
"43F" : sLang = "kk-KZ"
' Kazakh (Kazakhstan)
"57" : sLang = "kok"
' Konkani
"457" : sLang = "kok-IN"
' Konkani (India)
"12" : sLang = "ko"
' Korean
"412" : sLang = "ko-KR"
' Korean (Korea)
"40" : sLang = "ky"
' Kyrgyz
"440" : sLang = "ky-KG"
' Kyrgyz (Kyrgyzstan)
"26" : sLang = "lv"
' Latvian
"426" : sLang = "lv-LV"
' Latvian (Latvia)
"27" : sLang = "lt"
' Lithuanian
"427" : sLang = "lt-LT"
' Lithuanian (Lithuania)
"2F" : sLang = "mk"
' Macedonian
"42F" : sLang = "mk-MK"
' Macedonian (Macedonia, FYROM)
"3E" : sLang = "ms"
' Malay
"83E" : sLang = "ms-BN"
' Malay (Brunei Darussalam)

Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case
Case

"43E" : sLang = "ms-MY"

'
"4E" : sLang = "mr"
'
"44E" : sLang = "mr-IN"
'
"50" : sLang = "mn"
'
"450" : sLang = "mn-MN"
'
"14" : sLang = "no"
'
"414" : sLang = "nb-NO"
'
"814" : sLang = "nn-NO"
'
"15" : sLang = "pl"
'
"415" : sLang = "pl-PL"
'
"16" : sLang = "pt"
'
"416" : sLang = "pt-BR"
'
"816" : sLang = "pt-PT"
'
"46" : sLang = "pa"
'
"446" : sLang = "pa-IN"
'
"18" : sLang = "ro"
'
"418" : sLang = "ro-RO"
'
"19" : sLang = "ru"
'
"419" : sLang = "ru-RU"
'
"4F" : sLang = "sa"
'
"44F" : sLang = "sa-IN"
'
"C1A" : sLang = "sr-Cyrl-CS"
"81A" : sLang = "sr-Latn-CS"
"1B" : sLang = "sk"
'
"41B" : sLang = "sk-SK"
'
"24" : sLang = "sl"
'
"424" : sLang = "sl-SI"
'
"A" : sLang = "es" ' Spanish
"2C0A" : sLang = "es-AR"
'
"400A" : sLang = "es-BO"
'
"340A" : sLang = "es-CL"
'
"240A" : sLang = "es-CO"
'
"140A" : sLang = "es-CR"
'
"1C0A" : sLang = "es-DO"
'
"300A" : sLang = "es-EC"
'
"440A" : sLang = "es-SV"
'
"100A" : sLang = "es-GT"
'
"480A" : sLang = "es-HN"
'
"80A" : sLang = "es-MX"
'
"4C0A" : sLang = "es-NI"
'
"180A" : sLang = "es-PA"
'
"3C0A" : sLang = "es-PY"
'
"280A" : sLang = "es-PE"
'
"500A" : sLang = "es-PR"
'
"C0A" : sLang = "es-ES"
'
"380A" : sLang = "es-UY"
'
"200A" : sLang = "es-VE"
'
"41" : sLang = "sw"
'
"441" : sLang = "sw-KE"
'
"1D" : sLang = "sv"
'
"81D" : sLang = "sv-FI"
'
"41D" : sLang = "sv-SE"
'
"5A" : sLang = "syr"
'
"45A" : sLang = "syr-SY"
'
"49" : sLang = "ta"
'
"449" : sLang = "ta-IN"
'
"44" : sLang = "tt"
'
"444" : sLang = "tt-RU"
'
"4A" : sLang = "te"
'
"44A" : sLang = "te-IN"
'

Malay (Malaysia)
Marathi
Marathi (India)
Mongolian
Mongolian (Mongolia)
Norwegian
Norwegian (Bokml, Norway)
Norwegian (Nynorsk, Norway)
Polish
Polish (Poland)
Portuguese
Portuguese (Brazil)
Portuguese (Portugal)
Punjabi
Punjabi (India)
Romanian
Romanian (Romania)
Russian
Russian (Russia)
Sanskrit
Sanskrit (India)
' Serbian (Serbia, Cyrillic)
' Serbian (Serbia, Latin)
Slovak
Slovak (Slovakia)
Slovenian
Slovenian (Slovenia)
Spanish (Argentina)
Spanish (Bolivia)
Spanish (Chile)
Spanish (Colombia)
Spanish (Costa Rica)
Spanish (Dominican Republic)
Spanish (Ecuador)
Spanish (El Salvador)
Spanish (Guatemala)
Spanish (Honduras)
Spanish (Mexico)
Spanish (Nicaragua)
Spanish (Panama)
Spanish (Paraguay)
Spanish (Peru)
Spanish (Puerto Rico)
Spanish (Spain)
Spanish (Uruguay)
Spanish (Venezuela)
Swahili
Swahili (Kenya)
Swedish
Swedish (Finland)
Swedish (Sweden)
Syriac
Syriac (Syria)
Tamil
Tamil (India)
Tatar
Tatar (Russia)
Telugu
Telugu (India)

Case "1E" : sLang = "th"

' Thai
Case "41E" : sLang = "th-TH"
' Thai (Thailand)
Case "1F" : sLang = "tr"
' Turkish
Case "41F" : sLang = "tr-TR"
' Turkish (Turkey)
Case "22" : sLang = "uk"
' Ukrainian
Case "422" : sLang = "uk-UA"
' Ukrainian (Ukraine)
Case "20" : sLang = "ur"
' Urdu
Case "420" : sLang = "ur-PK"
' Urdu (Pakistan)
Case "43" : sLang = "uz"
' Uzbek
Case "843" : sLang = "uz-Cyrl-UZ"
' Uzbek (Uzbekistan, Cyrillic)
Case "443" : sLang = "uz-Latn-UZ"
' Uzbek (Uzbekistan, Latin)
Case "2A" : sLang = "vi"
' Vietnamese
Case "42A" : sLang = "vi-VN"
' Vietnamese (Vietnam)
Case Else : sLang = ""
End Select
GetCultureInfo = sLang
End Function
'===============================================================================
========================
'Trim away trailing comma from string
Function RTrimComma (sString)
sString = RTrim (sString)
If Right(sString,1) = "," Then sString = Left(sString,Len(sString)-1)
RTrimComma = sString
End Function
'===============================================================================
========================
'Return the primary keys of a table by using the PrimaryKeys property of the dat
abase object
'in SQL ready syntax
Function GetPrimaryTableKeys(MsiDb,sTable)
Dim iKeyCnt
Dim sPrimaryTmp
Dim PrimaryKeys
On Error Resume Next
sPrimaryTmp = ""
Set PrimaryKeys = MsiDb.PrimaryKeys(sTable)
For iKeyCnt = 1 To PrimaryKeys.FieldCount
sPrimaryTmp = sPrimaryTmp & "`"&PrimaryKeys.StringData(iKeyCnt)&"`, "
Next 'iKeyCnt
GetPrimaryTableKeys = Left(sPrimaryTmp,Len(sPrimaryTmp)-2)
End Function 'GetPrimaryTableKeys
'===============================================================================
========================
'Return the Column schema definition of a table in SQL ready syntax
Function GetTableColumnDef(MsiDb,sTable)
On Error Resume Next
Dim sQuery,sColDefTmp
Dim View,ColumnNames,ColumnTypes
Dim iColCnt
'Get the ColumnInfo details
sColDefTmp = ""
sQuery = "SELECT * FROM " & sTable
Set View = MsiDb.OpenView(sQuery)
View.Execute

Set ColumnNames = View.ColumnInfo(MSICOLUMNINFONAMES)

Set ColumnTypes = View.ColumnInfo(MSICOLUMNINFOTYPES)
For iColCnt = 1 To ColumnNames.FieldCount
sColDefTmp = sColDefTmp & ColDefToSql(ColumnNames.StringData(iColCnt),Co
lumnTypes.StringData(iColCnt)) & ", "
Next 'iColCnt
View.Close
GetTableColumnDef = Left(sColDefTmp,Len(sColDefTmp)-2)
End Function 'GetTableColumnDef
'===============================================================================
========================
'Translate the column definition fields into SQL syntax
Function ColDefToSql(sColName,sColType)
On Error Resume Next
Dim iLen
Dim sRight,sLeft, sSqlTmp
iLen = Len(sColType)
sRight = Right(sColType,iLen-1)
sLeft = Left(sColType,1)
sSqlTmp = "`"&sColName&"`"
Select Case sLeft
Case "s","S"
's? String, variable length (?=1-255) -> CHAR(#) or CHARACTER(#)
's0 String, variable length -> LONGCHAR
If sRight="0" Then sSqlTmp = sSqlTmp & " LONGCHAR" Else sSqlTmp = sSqlTm
p & " CHAR("&sRight&")"
If sLeft = "s" Then sSqlTmp = sSqlTmp & " NOT NULL"
Case "l","L"
'CHAR(#) LOCALIZABLE or CHARACTER(#) LOCALIZABLE
If sRight="0" Then sSqlTmp = sSqlTmp & " LONGCHAR" Else sSqlTmp = sSqlTm
p & " CHAR("&sRight&")"
If sLeft = "l" Then sSqlTmp = sSqlTmp & " NOT NULL"
If sRight="0" Then sSqlTmp = sSqlTmp & " LOCALIZABLE" Else sSqlTmp = sS
qlTmp & " LOCALIZABLE"
Case "i","I"
'i2 Short integer
'i4 Long integer
If sRight="2" Then sSqlTmp = sSqlTmp & " SHORT" Else sSqlTmp = sSqlTmp &
" LONG"
If sLeft = "i" Then sSqlTmp = sSqlTmp & " NOT NULL"
Case "v","V"
'v0 Binary Stream
sSqlTmp = sSqlTmp & " OBJECT"
If sLeft = "v" Then sSqlTmp = sSqlTmp & " NOT NULL"
Case "g","G"
'g? Temporary string (?=0-255)
Case "j","J"
'j? Temporary integer (?=0,1,2,4))
Case "o","O"
'O0 Temporary object
Case Else
End Select
ColDefToSql = sSqlTmp

End Function 'ColDefToSql

'===============================================================================
========================
'Checks if a productcode belongs to a Office family
Function IsOfficeProduct (sProductCode)
On Error Resume Next
IsOfficeProduct = False
If InStr(OFFICE_ALL, UCase(Right(sProductCode,28))) > 0 OR _
InStr(OFFICEID, UCase(Right(sProductCode,17))) > 0 Then
IsOfficeProduct = True
End If
End Function
'===============================================================================
========================
Function GetExpandedGuid (sGuid)
Dim sExpandGuid
Dim i
On Error Resume Next
sExpandGuid = "{" & 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
sExpandGuid = sExpandGuid & mid(sGuid,(i
Else
sExpandGuid = sExpandGuid & mid(sGuid,(i
End If
Next
sExpandGuid = sExpandGuid & "-"
For i = 21 To 32
If i Mod 2 Then
sExpandGuid = sExpandGuid & mid(sGuid,(i
Else
sExpandGuid = sExpandGuid & mid(sGuid,(i
End If
Next
sExpandGuid = sExpandGuid & "}"
GetExpandedGuid = sExpandGuid

+ 1),1)
- 1),1)

+ 1),1)
- 1),1)

End Function
'===============================================================================
========================
Function GetCompressedGuid (sGuid)
'Converts the GUID / ProductCode into the compressed format
Dim sCompGUID
Dim i
On Error Resume Next
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
'===============================================================================
========================
'Get Version Major from GUID
Function GetVersionMajor(sProductCode)
Dim iVersionMajor
On Error Resume Next

jor
jor
jor
jor
jor
jor
jor
jor
jor
jor

iVersionMajor = 0
iVersionMajor = oMsi.ProductInfo(sProductCode,"VersionMajor")
If Not Err = 0 OR iVersionMajor = 0 Then
If InStr(OFFICE_2000, UCase(Right(sProductCode,28))) > 0 Then
= 9
If InStr(ORK_2000,
UCase(Right(sProductCode,28))) > 0 Then
= 9
If InStr(PRJ_2000,
UCase(Right(sProductCode,28))) > 0 Then
= 9
If InStr(VIS_2002,
UCase(Right(sProductCode,28))) > 0 Then
= 10
If InStr(OFFICE_2002, UCase(Right(sProductCode,28))) > 0 Then
= 10
If InStr(OFFICE_2003, UCase(Right(sProductCode,28))) > 0 Then
= 11
If InStr(WSS_2,
UCase(Right(sProductCode,28))) > 0 Then
= 11
If InStr(SPS_2003,
UCase(Right(sProductCode,28))) > 0 Then
= 11
If InStr(PPS_2007,
UCase(Right(sProductCode,28))) > 0 Then
= 12
If InStr(OFFICEID,
UCase(Right(sProductCode,17))) > 0 Then
= Mid(sProductCode,4,2)
End If 'Err

iVersionMa
iVersionMa
iVersionMa
iVersionMa
iVersionMa
iVersionMa
iVersionMa
iVersionMa
iVersionMa
iVersionMa

GetVersionMajor = iVersionMajor
End Function
'===============================================================================
========================
'Obtain the ProductVersion from a .msi package
Function GetMsiProductVersion(sMsiFile)
Dim MsiDb,Record
Dim qView
On Error Resume Next
GetMsiProductVersion = ""
Set Record = Nothing
Set MsiDb = oMsi.OpenDatabase(sMsiFile,MSIOPENDATABASEMODE_READONLY)

Set qView = MsiDb.OpenView("SELECT `Value` FROM Property WHERE `Property` =

'ProductVersion'")
qView.Execute
Set Record = qView.Fetch
If NOT Record Is Nothing Then GetMsiProductVersion = Record.StringData(1)
qView.Close
End Function 'GetMsiProductVersion
'===============================================================================
========================
'Get the reference name that is used to reference the product under add / remove
programs
'Alternatively this could be taken from the cached .msi by reading the 'SetupExe
ArpId' value from the 'Property' table
Function GetArpProductname (sUninstallSubkey)
Dim hDefKey
Dim sSubKeyName,sName,sValue
On Error Resume Next
GetArpProductname = sUninstallSubkey
hDefKey = HKEY_LOCAL_MACHINE
sSubKeyName = REG_ARP & sUninstallSubkey & "\"
sName = "DisplayName"
If RegReadExpStringValue(hDefKey,sSubKeyName,sName,sValue) Then
If NOT IsNull(sValue) OR sValue = "" Then GetArpProductname = sValue
Else
'Try C2Rv2 location
sSubKeyName = REG_C2RVIRT_HKLM & sSubKeyName
If RegReadExpStringValue(hDefKey,sSubKeyName,sName,sValue) Then
If NOT IsNull(sValue) OR sValue = "" Then GetArpProductname = sValue
End If
End If
End Function
'===============================================================================
========================
'Get the original .msi name (Package Name) by direct read from registry
Function GetRegOriginalMsiName(sProductCodeCompressed,iContext,sSid)
Dim hDefKey
Dim sSubKeyName,sName,sValue, sFallBackName
On Error Resume Next
'PackageName is only available for per-machine, current user and managed use
r - not for other (unmanaged) user!
sFallBackName = ""
If sSid = sCurUserSid Or iContext = MSIINSTALLCONTEXT_MACHINE Or iContext =
MSIINSTALLCONTEXT_C2RV2 Then
hDefKey = GetRegHive(iContext,sSid,False)
sSubKeyName = GetRegConfigKey(sProductCodeCompressed,iContext,sSid,False
) & "SourceList\"
Else
'PackageName not available for other (unmanaged) user
GetRegProductName = "n/a"
Exit Function
End If 'sSid = sCurUserSid
sName = "PackageName"

If RegReadExpStringValue(hDefKey,sSubKeyName,sName,sValue) Then GetRegOrigin

alMsiName = sValue & sFallBackName Else GetRegOriginalMsiName = "-"
End Function 'GetRegOriginalMsiName
'===============================================================================
========================
'Get the registered transform(s) by direct read from registry metadata
Function GetRegTransforms(sProductCodeCompressed,iContext,sSid)
Dim hDefKey
Dim sSubKeyName,sName,sValue
On Error Resume Next
'Transforms is only available for per-machine and current user - not for oth
er user!
If sSid = sCurUserSid Or iContext = MSIINSTALLCONTEXT_MACHINE Or iContext =
MSIINSTALLCONTEXT_C2RV2 Then
hDefKey = GetRegHive(iContext,sSid,False)
sSubKeyName = GetRegConfigKey(sProductCodeCompressed,iContext,sSid,False
)
sName = "Transforms"
Else
'Transforms not available for other user
GetRegTransforms = "n/a"
Exit Function
End If 'sSid = sCurUserSid
If RegReadExpStringValue(hDefKey,sSubKeyName,sName,sValue) Then GetRegTransf
orms = sValue Else GetRegTransforms = "-"
End Function 'GetRegTransforms
'===============================================================================
========================
'Get the product PackageCode by direct read from registry metadata
Function GetRegPackageCode(sProductCodeCompressed,iContext,sSid)
Dim hDefKey
Dim sSubKeyName,sName,sValue
On Error Resume Next
'PackageCode is only available for per-machine and current user - not for ot
her user!
If sSid = sCurUserSid Or iContext = MSIINSTALLCONTEXT_MACHINE Or iContext =
MSIINSTALLCONTEXT_C2RV2 Then
hDefKey = GetRegHive(iContext,sSid,False)
sSubKeyName = GetRegConfigKey(sProductCodeCompressed,iContext,sSid,False
)
sName = "PackageCode"
Else
'PackageCode not available for other user
GetRegPackageCode = "n/a"
Exit Function
End If 'sSid = sCurUserSid
If RegReadExpStringValue(hDefKey,sSubKeyName,sName,sValue) Then GetRegPackag
eCode = sValue Else GetRegPackageCode = "-"

End Function 'GetRegPackageCode

'===============================================================================
========================
'Get the ProductName by direct read from registry metadata
Function GetRegProductName(sProductCodeCompressed,iContext,sSid)
Dim hDefKey
Dim sSubKeyName,sName,sValue,sFallBackName
Dim i
On Error Resume Next
'ProductName is only available for per-machine, current user and managed use
r - not for other (unmanaged) user!
'If not per-machine, managed or SID not sCurUserSid tweak to 'DisplayName' f
rom GlobalConfig key
sFallBackName = ""
If sSid = sCurUserSid Or iContext = MSIINSTALLCONTEXT_USERMANAGED Or iContex
t = MSIINSTALLCONTEXT_MACHINE Or iContext = MSIINSTALLCONTEXT_C2RV2 Then
If Not iContext = MSIINSTALLCONTEXT_USERMANAGED Then
hDefKey = GetRegHive(iContext,sSid,False)
sSubKeyName = GetRegConfigKey(sProductCodeCompressed,iContext,sSid,F
alse)
Else
hDefKey = GetRegHive(iContext,sSid,True)
sSubKeyName = GetRegConfigKey(sProductCodeCompressed,iContext,sSid,T
rue)
End If
sName = "ProductName"
Else
'Use GlobalConfig key to avoid conflict with per-user installs
hDefKey = HKEY_LOCAL_MACHINE
sSubKeyName = GetRegConfigKey(sProductCodeCompressed,iContext,sSid,True)
& "InstallProperties\"
sName = "DisplayName"
sFallBackName = " (DisplayName)"
End If 'sSid = sCurUserSid
If RegReadExpStringValue(hDefKey,sSubKeyName,sName,sValue) Then GetRegProduc
tName = sValue & sFallBackName Else GetRegProductName = ERR_CATEGORYERROR & "No
DislpayName registered"
End Function
'===============================================================================
========================
Function GetRegProductState(sProductCodeCompressed,iContext,sSid)
Dim hDefKey
Dim sSubKeyName,sName,sValue
Dim iTmpContext
On Error Resume Next
GetRegProductState = "Unknown"
hDefKey = HKEY_LOCAL_MACHINE
If iContext = MSIINSTALLCONTEXT_USERMANAGED Then
iTmpContext = MSIINSTALLCONTEXT_USERUNMANAGED
sName = "ManagedLocalPackage"
Else
iTmpContext = iContext

sName = "LocalPackage"
End If 'iContext = MSIINSTALLCONTEXT_USERMANAGED
sSubKeyName = GetRegConfigKey(sProductCodeCompressed,iTmpContext,sSid,True)
& "InstallProperties\"
If RegKeyExists (hDefKey,sSubKeyName) Then
If RegValExists(hDefKey,sSubKeyName,sName) Then
GetRegProductState = 5 '"Installed"
Else
If InStr(sSubKeyName, REG_C2RVIRT_HKLM) > 0 Then
GetRegProductState = 8 '"Virtualized"
Else
GetRegProductState = 1 '"Advertised"
End If
End If 'RegValExists
Else
GetRegProductState = -1 '"Broken/Unknown"
End If 'RegKeyExists
End Function 'GetRegProductState
'===============================================================================
========================
'Check if the GUID has a valid structure
Function IsValidGuid(sGuid,iGuidType)
Dim i, n
Dim c
Dim bValidGuidLength, bValidGuidChar, bValidGuidCase
On Error Resume Next
'Set defaults
IsValidGuid = False
fGuidCaseWarningOnly = False
sError = "" : sErrBpa = ""
bValidGuidLength = True
bValidGuidChar = True
Select Case iGuidType
Case GUID_UNCOMPRESSED 'UnCompressed
If Len(sGuid) = 38 Then
IsValidGuid = True
For i = 1 To 38
bValidGuidCase = True
c = Mid(sGuid,i,1)
Select Case i
Case 1
If Not c = "{" Then
IsValidGuid = False
bValidGuidChar = False
Exit For
End If
Case 10, 15, 20, 25
If not c = "-" Then
IsValidGuid = False
bValidGuidChar = False
Exit For
End If
Case 38
If not c = "}" Then
IsValidGuid = False

bValidGuidChar = False
Exit For
End If
Case Else
n = Asc(c)
If Not IsValidGuidChar(n) Then
bValidGuidCase = False
fGuidCaseWarningOnly = True
IsValidGuid = False
n = Asc(UCase(c))
If Not IsValidGuidChar(n) Then
fGuidCaseWarningOnly = False
bValidGuidChar = False
Exit For
End If 'IsValidGuidChar (inner)
End If 'IsValidGuidChar (outer)
End Select
Next 'i
Else
'Invalid length for this GUID type
'Suppress error if passed in GUID matches 'compressed' length
If NOT (Len(sGuid)=32) Then bValidGuidLength = False
End If 'Len(sGuid)
Case GUID_COMPRESSED
If Len(sGuid)=32 Then
IsValidGuid = True
For i = 1 to 32
c = Mid(sGuid,i,1)
bValidGuidCase = True
n = Asc(c)
If Not IsValidGuidChar(n) Then
bValidGuidCase = False
fGuidCaseWarningOnly = True
IsValidGuid = False
n = Asc(UCase(c))
If Not IsValidGuidChar(n) Then
fGuidCaseWarningOnly = False
bValidGuidChar = False
Exit For
End If 'IsValidGuidChar (inner)
End If 'IsValidGuidChar (outer)
Next 'i
Else
'Invalid length for this GUID type
bValidGuidLength = False
End If 'Len
Case GUID_SQUISHED '"Squished"
'Not implemented
Case Else
'IsValidGuid = False
End Select
'Log errors
If (NOT bValidGuidLength) OR (NOT bValidGuidChar) OR (fGuidCaseWarningOnly)
Then
sError = ERR_INVALIDGUID & DOT
sErrBpa = BPA_GUID
End If

If fGuidCaseWarningOnly Then
sError = sError & ERR_GUIDCASE
End If 'fGuidCaseWarningOnly
If bValidGuidLength = False Then
sError = sError & ERR_INVALIDGUIDLENGTH
End If 'bValidGuidLength
If bValidGuidChar = False Then
sError = sError & ERR_INVALIDGUIDCHAR
End If 'bValidGuidChar
End Function 'IsValidGuid
'===============================================================================
========================
'Check if the character is in a valid range for a GUID
Function IsValidGuidChar (iAsc)
If ((iAsc >= 48 AND iAsc <= 57) OR (iAsc >= 65 AND iAsc <= 70)) Then
IsValidGuidChar = True
Else
IsValidGuidChar = False
End If
End Function
'===============================================================================
========================
Function GetContextString(iContext)
On Error Resume Next
Select Case iContext
Case MSIINSTALLCONTEXT_USERMANAGED
: GetContextString = "MSIINSTALL
CONTEXT_USERMANAGED"
Case MSIINSTALLCONTEXT_USERUNMANAGED
: GetContextString = "MSIINSTALL
CONTEXT_USERUNMANAGED"
Case MSIINSTALLCONTEXT_MACHINE
: GetContextString = "MSIINSTALL
CONTEXT_MACHINE"
Case MSIINSTALLCONTEXT_ALL
: GetContextString = "MSIINSTALL
CONTEXT_ALL"
Case MSIINSTALLCONTEXT_C2RV2
: GetContextString = "MSIINSTALL
CONTEXT_C2RV2"
Case Else
: GetContextString = iContext
End Select
End Function
'===============================================================================
========================
Function GetHiveString(hDefKey)
On Error Resume Next
Select Case hDefKey
Case HKEY_CLASSES_ROOT : GetHiveString = "HKEY_CLASSES_ROOT"
Case HKEY_CURRENT_USER : GetHiveString = "HKEY_CURRENT_USER"
Case HKEY_LOCAL_MACHINE : GetHiveString = "HKEY_LOCAL_MACHINE"
Case HKEY_USERS : GetHiveString = "HKEY_USERS"
Case Else : GetHiveString = hDefKey
End Select
End Function 'GetHiveString
'===============================================================================
========================

Function GetRegConfigPatchesKey(iContext,sSid,bGlobal)
Dim sTmpProductCode,sSubKeyName
On Error Resume Next
sSubKeyName = ""
Select Case iContext
Case MSIINSTALLCONTEXT_USERMANAGED
sSubKeyName = REG_CONTEXTUSERMANAGED
Case MSIINSTALLCONTEXT_USERUNMANAGED
If bGlobal OR NOT sSid = sCurUserSid
sSubKeyName = REG_GLOBALCONFIG &
Else
sSubKeyName = REG_CONTEXTUSER
End If
Case MSIINSTALLCONTEXT_MACHINE
If bGlobal Then
sSubKeyName = REG_GLOBALCONFIG &
Else
sSubKeyName = REG_CONTEXTMACHINE
End If
Case MSIINSTALLCONTEXT_C2RV2
If bGlobal Then
sSubKeyName = REG_C2RVIRT_HKLM &

& sSid & "\Installer\Patches\"

Then
sSid & "\Patches\"

"S-1-5-18\Patches\"
& "\Patches\"

REG_GLOBALCONFIG & "S-1-5-18\Patche

s\"
Else
sSubKeyName = REG_C2RVIRT_HKLM & REG_CONTEXTMACHINE & "Patches\"
End If
Case Else
End Select
GetRegConfigPatchesKey = Replace(sSubKeyName,"\\","\")
End Function 'GetRegConfigPatchesKey
'===============================================================================
========================
Function GetRegConfigKey(sProductCode, iContext, sSid, bGlobal)
Dim sTmpProductCode,sSubKeyName
On Error Resume Next
sTmpProductCode = sProductCode
sSubKeyName = ""
If NOT sTmpProductCode = "" Then
If IsValidGuid(sTmpProductCode,GUID_UNCOMPRESSED) Then sTmpProductCode =
GetCompressedGuid(sTmpProductCode)
End If 'NOT sTmpProductCode = ""
Select Case iContext
Case MSIINSTALLCONTEXT_USERMANAGED
sSubKeyName = REG_CONTEXTUSERMANAGED & sSid & "\Installer\Products\" & s
TmpProductCode & "\"
Case MSIINSTALLCONTEXT_USERUNMANAGED
If bGlobal OR NOT sSid = sCurUserSid Then
sSubKeyName = REG_GLOBALCONFIG & sSid & "\Products\" & sTmpProductCo
de & "\"
Else
sSubKeyName = REG_CONTEXTUSER & "Products\" & sTmpProductCode & "\"
End If
Case MSIINSTALLCONTEXT_MACHINE
If bGlobal Then
sSubKeyName = REG_GLOBALCONFIG & "S-1-5-18\Products\" & sTmpProductC

ode & "\"

Else
sSubKeyName = REG_CONTEXTMACHINE & "Products\" & sTmpProductCode & "
\"
End If
Case MSIINSTALLCONTEXT_C2RV2
If bGlobal Then
sSubKeyName = REG_C2RVIRT_HKLM & REG_GLOBALCONFIG & "S-1-5-18\Produc
ts\" & sTmpProductCode & "\"
Else
sSubKeyName = REG_C2RVIRT_HKLM & "Software\Classes\" & REG_CONTEXTMA
CHINE & "Products\" & sTmpProductCode & "\"
End If
Case Else
End Select
GetRegConfigKey = Replace(sSubKeyName,"\\","\")
End Function 'GetRegConfigKey
'===============================================================================
========================
Function GetRegHive(iContext, sSid, bGlobal)
On Error Resume Next
Select Case iContext
Case MSIINSTALLCONTEXT_USERMANAGED
GetRegHive = HKEY_LOCAL_MACHINE
Case MSIINSTALLCONTEXT_USERUNMANAGED
If bGlobal OR NOT sSid = sCurUserSid Then
GetRegHive = HKEY_LOCAL_MACHINE
Else
GetRegHive = HKEY_CURRENT_USER
End If
Case MSIINSTALLCONTEXT_MACHINE
If bGlobal Then
GetRegHive = HKEY_LOCAL_MACHINE
Else
GetRegHive = HKEY_CLASSES_ROOT
End If
Case MSIINSTALLCONTEXT_C2RV2
GetRegHive = HKEY_LOCAL_MACHINE
Case Else
End Select
End Function 'GetRegHive
'===============================================================================
========================
Function RegKeyExists(hDefKey,sSubKeyName)
Dim arrKeys
RegKeyExists = (oReg.EnumKey(hDefKey,sSubKeyName,arrKeys) = 0)
End Function
'===============================================================================
========================
Function RegValExists(hDefKey,sSubKeyName,sName)
Dim arrValueTypes, arrValueNames, i
On Error Resume Next

RegValExists = False
If Not RegKeyExists(hDefKey,sSubKeyName) Then
Exit Function
End If
If oReg.EnumValues(hDefKey,sSubKeyName,arrValueNames,arrValueTypes) = 0 AND
CheckArray(arrValueNames) Then
For i = 0 To UBound(arrValueNames)
If LCase(arrValueNames(i)) = Trim(LCase(sName)) Then RegValExists =
True
Next
Else
Exit Function
End If 'oReg.EnumValues
End Function
'===============================================================================
========================
'Check access to a registry key
Function RegCheckAccess(hDefKey, sSubKeyName, lAccPermLevel)
Dim RetVal
Dim arrValues
RetVal = RegKeyExists(hDefKey,sSubKeyName)
RetVal = oReg.CheckAccess(hDefKey,sSubKeyName,lAccPermLevel)
If Not RetVal = 0 AND f64 Then RetVal = oReg.CheckAccess(hDefKey,Wow64Key(hD
efKey, sSubKeyName),lAccPermLevel)
RegCheckAccess = (RetVal = 0)
End Function 'RegReadValue
'===============================================================================
========================
'Read the value of a given registry entry
Function RegReadValue(hDefKey, sSubKeyName, sName, sValue, sType)
Dim RetVal
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,sValu
e)
If Not RetVal = 0 AND f64 Then RetVal = oReg.GetExpandedStringValue(
hDefKey,Wow64Key(hDefKey, sSubKeyName),sName,sValue)
Case "7","REG_MULTI_SZ"
RetVal = oReg.GetMultiStringValue(hDefKey,sSubKeyName,sName,arrValue
s)
If Not RetVal = 0 AND f64 Then RetVal = oReg.GetMultiStringValue(hDe
fKey,Wow64Key(hDefKey, sSubKeyName),sName,arrValues)
If RetVal = 0 Then sValue = Join(arrValues,chr(34))
Case "4","REG_DWORD"
RetVal = oReg.GetDWORDValue(hDefKey,sSubKeyName,sName,sValue)
If Not RetVal = 0 AND f64 Then
RetVal = oReg.GetDWORDValue(hDefKey,Wow64Key(hDefKey, sSubKeyNam
e),sName,sValue)
End If
Case "3","REG_BINARY"
RetVal = oReg.GetBinaryValue(hDefKey,sSubKeyName,sName,sValue)

If Not RetVal = 0 AND f64 Then RetVal = oReg.GetBinaryValue(hDefKey,

Wow64Key(hDefKey, sSubKeyName),sName,sValue)
Case "11","REG_QWORD"
RetVal = oReg.GetQWORDValue(hDefKey,sSubKeyName,sName,sValue)
If Not RetVal = 0 AND f64 Then RetVal = oReg.GetQWORDValue(hDefKey,W
ow64Key(hDefKey, sSubKeyName),sName,sValue)
Case Else
RetVal = -1
End Select 'sValue
RegReadValue = (RetVal = 0)
End Function 'RegReadValue
'===============================================================================
========================
Function RegReadStringValue(hDefKey,sSubKeyName,sName,sValue)
Dim RetVal
RetVal = oReg.GetStringValue(hDefKey,sSubKeyName,sName,sValue)
If Not RetVal = 0 AND f64 Then RetVal = oReg.GetStringValue(hDefKey,Wow64Key
(hDefKey, sSubKeyName),sName,sValue)
RegReadStringValue = (RetVal = 0)
End Function 'RegReadStringValue
'===============================================================================
========================
Function RegReadExpStringValue(hDefKey,sSubKeyName,sName,sValue)
Dim RetVal
RetVal = oReg.GetExpandedStringValue(hDefKey,sSubKeyName,sName,sValue)
If Not RetVal = 0 AND f64 Then RetVal = oReg.GetExpandedStringValue(hDefKey,
Wow64Key(hDefKey, sSubKeyName),sName,sValue)
RegReadExpStringValue = (RetVal = 0)
End Function 'RegReadExpStringValue
'===============================================================================
========================
Function RegReadMultiStringValue(hDefKey,sSubKeyName,sName,arrValues)
Dim RetVal
RetVal = oReg.GetMultiStringValue(hDefKey,sSubKeyName,sName,arrValues)
If Not RetVal = 0 AND f64 Then RetVal = oReg.GetMultiStringValue(hDefKey,Wow
64Key(hDefKey, sSubKeyName),sName,arrValues)
RegReadMultiStringValue = (RetVal = 0 AND IsArray(arrValues))
End Function 'RegReadMultiStringValue
'===============================================================================
========================
Function RegReadDWordValue(hDefKey,sSubKeyName,sName,sValue)
Dim RetVal
RetVal = oReg.GetDWORDValue(hDefKey,sSubKeyName,sName,sValue)
If Not RetVal = 0 AND f64 Then RetVal = oReg.GetDWORDValue(hDefKey,Wow64Key(
hDefKey, sSubKeyName),sName,sValue)
RegReadDWordValue = (RetVal = 0)
End Function 'RegReadDWordValue
'===============================================================================
========================
Function RegReadBinaryValue(hDefKey,sSubKeyName,sName,sValue)
Dim RetVal

RetVal = oReg.GetBinaryValue(hDefKey,sSubKeyName,sName,sValue)
If Not RetVal = 0 AND f64 Then RetVal = oReg.GetBinaryValue(hDefKey,Wow64Key
(hDefKey, sSubKeyName),sName,sValue)
RegReadBinaryValue = (RetVal = 0)
End Function 'RegReadBinaryValue
'===============================================================================
========================
Function RegReadQWordValue(hDefKey,sSubKeyName,sName,sValue)
Dim RetVal
RetVal = oReg.GetQWORDValue(hDefKey,sSubKeyName,sName,sValue)
If Not RetVal = 0 AND f64 Then RetVal = oReg.GetQWORDValue(hDefKey,Wow64Key(
hDefKey, sSubKeyName),sName,sValue)
RegReadQWordValue = (RetVal = 0)
End Function 'RegReadQWordValue
'===============================================================================
========================
'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),arrNam
es64,arrTypes64)
If (RetVal = 0) AND (Not RetVal64 = 0) AND IsArray(arrNames32) AND IsArr
ay(arrTypes32) Then
arrNames = arrNames32
arrTypes = arrTypes32
End If
If (Not RetVal = 0) AND (RetVal64 = 0) AND IsArray(arrNames64) AND IsArr
ay(arrTypes64) Then
arrNames = arrNames64
arrTypes = arrTypes64
End If
If (RetVal = 0) AND (RetVal64 = 0) AND IsArray(arrNames32) AND IsArray(a
rrNames64) 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 I
sArray(arrTypes)
End Function 'RegEnumValues
'===============================================================================
========================
'Enumerate a registry key to return all subkeys
Function RegEnumKey(hDefKey,sSubKeyName,arrKeys)
Dim RetVal, RetVal64
Dim arrKeys32, arrKeys64

If f64 Then
RetVal = oReg.EnumKey(hDefKey,sSubKeyName,arrKeys32)
RetVal64 = oReg.EnumKey(hDefKey,Wow64Key(hDefKey, sSubKeyName),arrKeys64
)
If (RetVal = 0) AND (Not RetVal64 = 0) AND IsArray(arrKeys32) Then arrKe
ys = arrKeys32
If (Not RetVal = 0) AND (RetVal64 = 0) AND IsArray(arrKeys64) Then arrKe
ys = arrKeys64
If (RetVal = 0) AND (RetVal64 = 0) Then
If IsArray(arrKeys32) AND IsArray (arrKeys64) Then
arrKeys = RemoveDuplicates(Split((Join(arrKeys32,"\") & "\" & Jo
in(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
'===============================================================================
========================
'Return the alternate regkey location on 64bit environment
Function Wow64Key(hDefKey, sSubKeyName)
Dim iPos
Dim fReplaced
fReplaced = False
If InStr(sSubKeyName, REG_C2RVIRT_HKLM) > 0 Then
sSubKeyName = Replace(sSubKeyName, REG_C2RVIRT_HKLM, "")
fReplaced = True
End If
Select Case hDefKey
Case HKCU
If Left(sSubKeyName,17) = "Software\Classes\" Then
Wow64Key = Left(sSubKeyName,17) & "Wow6432Node\" &
Name,Len(sSubKeyName)-17)
Else
iPos = InStr(sSubKeyName,"\")
Wow64Key = Left(sSubKeyName,iPos) & "Wow6432Node\"
eyName,Len(sSubKeyName)-iPos)
End If
Case HKLM
If Left(sSubKeyName,17) = "Software\Classes\" Then
Wow64Key = Left(sSubKeyName,17) & "Wow6432Node\" &
Name,Len(sSubKeyName)-17)
Else
iPos = InStr(sSubKeyName,"\")
Wow64Key = Left(sSubKeyName,iPos) & "Wow6432Node\"
eyName,Len(sSubKeyName)-iPos)
End If
Case Else
Wow64Key = "Wow6432Node\" & sSubKeyName
End Select 'hDefKey
If fReplaced Then
sSubKeyName = REG_C2RVIRT_HKLM & sSubKeyName

Right(sSubKey

& Right(sSubK

Right(sSubKey

& Right(sSubK

Wow64Key = REG_C2RVIRT_HKLM & Wow64Key

End If
End Function 'Wow64Key
'===============================================================================
========================
'64 bit aware wrapper to return the requested folder
Function GetFolderPath(sPath)
GetFolderPath = True
If oFso.FolderExists(sPath) Then Exit Function
If f64 AND oFso.FolderExists(Wow64Folder(sPath)) Then
sPath = Wow64Folder(sPath)
Exit Function
End If
GetFolderPath = False
End Function 'GetFolderPath
'===============================================================================
========================
'Enumerates subfolder names of a folder and returns True if subfolders exist
Function EnumFolderNames (sFolder, arrSubFolders)
Dim Folder, Subfolder
Dim sSubFolders
If oFso.FolderExists(sFolder) Then
Set Folder = oFso.GetFolder(sFolder)
For Each Subfolder in Folder.Subfolders
sSubFolders = sSubFolders & Subfolder.Name & ","
Next 'Subfolder
End If
If f64 AND oFso.FolderExists(Wow64Folder(sFolder)) Then
Set Folder = oFso.GetFolder(Wow64Folder(sFolder))
For Each Subfolder in Folder.Subfolders
sSubFolders = sSubFolders & Subfolder.Name & ","
Next 'Subfolder
End If
If Len(sSubFolders)>0 Then arrSubFolders = RemoveDuplicates(Split(Left(sSubF
olders,Len(sSubFolders)-1),","))
EnumFolderNames = Len(sSubFolders)>0
End Function 'EnumFolderNames
'===============================================================================
========================
'Enumerates subfolders of a folder and returns True if subfolders exist
Function EnumFolders (sFolder, arrSubFolders)
Dim Folder, Subfolder
Dim sSubFolders
If oFso.FolderExists(sFolder) Then
Set Folder = oFso.GetFolder(sFolder)
For Each Subfolder in Folder.Subfolders
sSubFolders = sSubFolders & Subfolder.Path & ","
Next 'Subfolder
End If
If f64 AND oFso.FolderExists(Wow64Folder(sFolder)) Then
Set Folder = oFso.GetFolder(Wow64Folder(sFolder))
For Each Subfolder in Folder.Subfolders
sSubFolders = sSubFolders & Subfolder.Path & ","
Next 'Subfolder
End If

If Len(sSubFolders)>0 Then arrSubFolders = RemoveDuplicates(Split(Left(sSubF

olders,Len(sSubFolders)-1),","))
EnumFolders = Len(sSubFolders)>0
End Function 'EnumFolders
'===============================================================================
========================
Sub GetFolderStructure (Folder)
Dim SubFolder
For Each SubFolder in Folder.SubFolders
ReDim Preserve arrMseFolders(UBound(arrMseFolders)+1)
arrMseFolders(UBound(arrMseFolders)) = SubFolder.Path
GetFolderStructure SubFolder
Next 'SubFolder
End Sub 'GetFolderStructure
'===============================================================================
========================
'Remove duplicate entries from a one dimensional array
Function RemoveDuplicates(Array)
Dim Item
Dim oDic
Set oDic = CreateObject("Scripting.Dictionary")
For Each Item in Array
If Not oDic.Exists(Item) Then oDic.Add Item,Item
Next 'Item
RemoveDuplicates = oDic.Keys
End Function 'RemoveDuplicates
'===============================================================================
========================
'Identify user SID's on the system
Function GetUserSids(sContext)
Dim i, n, iRetVal
Dim arrKeys
On Error Resume Next
ReDim arrKeys(-1)
Select Case sContext
Case "Current"
If RegEnumKey(HKCU,"Software\Microsoft\Protected Storage System Provider
\",arrKeys) Then
sCurUserSid = arrKeys(0)
End If 'RegEnumKey
'Add SID's that are not "S-1-5-18" (Len("S-1-5-18") = 8
Case "UserUnmanaged"
If RegEnumKey(HKLM,REG_GLOBALCONFIG,arrKeys) Then
n = 0
For i = 0 To UBound(arrKeys)
If Len(arrKeys(i)) > 8 Then
Redim Preserve arrUUSids(n)
arrUUSids(n) = arrKeys(i)
n = n + 1
End If 'Len(arrKeys)
Next 'i
End If 'RegEnumKey
Case "UserManaged"

If RegEnumKey(HKLM,REG_CONTEXTUSERMANAGED,arrKeys) Then
n = 0
For i = 0 To UBound(arrKeys)
If Len(arrKeys(i)) > 8 Then
Redim Preserve arrUMSids(n)
arrUMSids(n) = arrKeys(i)
n = n + 1
End If 'Len(arrKeys)
Next 'i
End If 'RegEnumKey
Case Else
End Select
End Function
'===============================================================================
========================
Function GetArrayPosition (Arr,sProductCode)
Dim iPos
On Error Resume Next
GetArrayPosition = -1
'Need to allow exception for lower case only violations 'fGuidCaseWarningOnl
y'
If CheckArray(Arr) And (IsValidGuid(sProductCode,GUID_UNCOMPRESSED) OR fGuid
CaseWarningOnly) Then
For iPos = 0 To UBound(Arr)
If Arr(iPos,COL_PRODUCTCODE) = sProductCode Then
GetArrayPosition = iPos
Exit For
End If
Next 'iPos
End If 'CheckArray
End Function
'===============================================================================
========================
Function GetArrayPositionFromPattern (Arr, sProductCodePattern)
Dim iPos
On Error Resume Next
GetArrayPositionFromPattern = -1
'Need to allow exception for lower case only violations 'fGuidCaseWarningOnl
y'
If CheckArray(Arr) Then
For iPos = 0 To UBound(Arr)
If InStr(Arr(iPos,COL_PRODUCTCODE), sProductCodePattern) > 0 Then
GetArrayPositionFromPattern = iPos
Exit For
End If
Next 'iPos
End If 'CheckArray
End Function
'===============================================================================
========================
Sub InitMasterArray
On Error Resume Next
'Since ReDim cannot preserve the data on the first dimension determine the n

eeded total first.

If CheckArray(arrAllProducts) Then iPCount = iPCount + (UBound(arrAllProduct
s) + 1)
If CheckArray(arrMProducts) Then iPCount = iPCount + (UBound(arrMProducts) +
1)
If CheckArray(arrUUProducts) Then iPCount = iPCount + (UBound(arrUUProducts)
+ 1)
If CheckArray(arrUMProducts) Then iPCount = iPCount + (UBound(arrUMProducts)
+ 1)
If CheckArray(arrMVProducts) Then iPCount = iPCount + (UBound(arrMVProducts)
+ 1 )
ReDim arrMaster(iPCount-1,UBOUND_MASTER)
If CheckArray(arrAllProducts) Then CopyToMaster arrAllProducts
If CheckArray(arrMProducts) Then CopyToMaster arrMProducts
If CheckArray(arrUUProducts) Then CopyToMaster arrUUProducts
If CheckArray(arrUMProducts) Then CopyToMaster arrUMProducts
If CheckArray(arrMVProducts) Then CopyToMaster arrMVProducts
End Sub
'===============================================================================
========================
Function CheckArray(Arr)
Dim sTmp
Dim iRetVal
On Error Resume Next
CheckArray = True
If Not IsArray(Arr) Then
CheckArray = False
Exit Function
End If
If IsNull(Arr) Then
CheckArray = False
Exit Function
End If
If IsEmpty(Arr) Then
CheckArray = False
Exit Function
End If
If UBound(Arr) = -1 Then
If Not Err = 0 Then
Err.Clear
Redim Arr(-1)
End If 'Err
CheckArray = False
Exit Function
End If
End Function
'===============================================================================
========================
Function CheckObject(Obj)
On Error Resume Next
CheckObject = True
If Not IsObject(Obj) Then
CheckObject = False

Exit Function
End If
If IsNull(Obj) Then
CheckObject = False
Exit Function
End If
If IsEmpty(Obj) Then
CheckObject = False
Exit Function
End If
If Not Obj.Count > 0 Then
If Not Err = 0 Then
Err.Clear
Set Obj = Nothing
End If 'Err
CheckObject = False
Exit Function
End If
End Function
'===============================================================================
========================
Sub CheckError(sModule,sErrorHandler)
Dim sErr
If Not Err = 0 Then
sErr = GetErrorDescription(Err)
If Not sErrorHandler = "" Then
sErrorHandler = sModule & sErrorHandler
ErrorRelay(sErrorHandler)
End If
End If 'Err = 0
Err.Clear
End Sub
'===============================================================================
========================
Sub ErrorRelay(sErrorHandler)
Select Case (sErrorHandler)
Case "CheckPreReq_ErrorHandler" : CheckPreReq_ErrorHandler
Case "FindAllProducts_ErrorHandler3x" : FindAllProducts_ErrorHandler3x
Case "FindProducts1","FindProducts2","FindProducts4" : FindProducts_Erro
rHandler Int(Right(sErrorHandler,1))
Case Else
End Select
End Sub
'===============================================================================
========================
Function GetErrorDescription (Err)
If Not Err = 0 Then
GetErrorDescription = "Source: " & Err.Source & "; Err# (Hex): " & Hex(
Err ) & _
"; Err# (Dec): " & Err & "; Description : " & Err.
Description & _
"; Stack: " & sStack
End If 'Err = 0
End Function
'===============================================================================
========================

Sub ParseCmdLine
Dim iCnt, iArgCnt
Dim oFso
'Handle settings from the .ini section
If fLogFull Then
fLogChainedDetails = True
fFileInventory = True
fFeatureTree = True
End If 'fLogFull
If Not sPathOutputFolder = "" Then
Set oFso = CreateObject("Scripting.FileSystemObject")
If Not oFso.FolderExists(sPathOutputFolder) Then sPathOutputFolder = ""
Set oFso = Nothing
End If 'Not sPathOutputFolder
If fLogVerbose Then
fLogChainedDetails = True
fFeatureTree = True
End If 'fLogVerbose
iArgCnt = Wscript.Arguments.Count
If iArgCnt>0 Then
For iCnt = 0 To iArgCnt-1
Select Case UCase(Wscript.Arguments(iCnt))
Case "/A","-A","/ALL","-ALL","ALL"
fListNonOfficeProducts = True
Case "/BASIC","-BASIC","BASIC"
fBasicMode = True
Case "/DCS","-DCS","/DISALLOWCSCRIPT","-DISALLOWCSCRIPT","DISALLOWCS
CRIPT"
fDisallowCScript = True
Case "/F","-F","/FULL","-FULL","FULL"
fLogFull = True
fLogChainedDetails = True
fFileInventory = True
fFeatureTree = True
Case "/FI","-FI","/FILEINVENTORY","-FILEINVENTORY","FILEINVENTORY"
fFileInventory = True
Case "/FT","-FT","/FEATURETREE","-FEATURETREE","FEATURETREE"
fFeatureTree = True
Case "/L","-L","/LOGFOLDER","-LOGFOLDER","LOGFOLDER"
If iArgCnt > iCnt Then
Set oFso = CreateObject("Scripting.FileSystemObject")
If oFso.FolderExists(Wscript.Arguments(iCnt+1)) Then sPathOu
tputFolder = Wscript.Arguments(iCnt+1)
Set oFso = Nothing
End If 'iArgCnt
Case "/LD","-LD","/LOGCHAINEDDETAILS","-LOGCHAINEDDETAILS"
fLogChainedDetails = True
Case "/LV","-LV","/L*V","-L*V","/LOGVERBOSE","-LOGVERBOSE","/VERBOSE
","-VERBOSE"
fLogVerbose = True
fLogChainedDetails = True
fFeatureTree = True
Case "/Q","-Q","/QUIET","-QUIET","QUIET"
fQuiet = True
Case "/?","-?","?"

Wscript.Echo vbCrLf & _

"ROIScan (Robust Office Inventory Scan) - Version " & SCRIPTBUI
LD & vbCrLf & _
"Copyright (c) 2008,2009,2010 Microsoft Corporation. All Rights
Reserved." & vbCrLf & vbCrLf & _
"Inventory tool for to create a log of " & vbCrLf & "installed
Microsoft Office applications." & vbCrLf & _
"Supports Office 2000, XP, 2003, 2007, 2010 " & vbCrLf & vbCrLf
& _
"Usage:" & vbTab & "ROIScan.vbs [Options]" & vbCrLf & vbCrLf &
_
" /?" & vbTab & vbTab & vbTab & "Display this help"& vbCrLf &_
" /All" & vbTab & vbTab & vbTab & "Include non Office products"
& vbCrLf &_
" /Basic" & vbTab & vbTab & vbTab & "Log less product details"
& vbCrLf & _
" /Full" & vbTab & vbTab & vbTab & "Log all additional product
details" & vbCrLf & _
" /LogVerbose" & vbTab & vbTab & "Log additional product detail
s" & vbCrLf & _
" /LogChainedDetails" & vbTab & "Log details for chained .msi p
ackages" & vbCrLf & _
" /FeatureTree" & vbTab & vbTab & "Include treeview like featur
e listing" & vbCrLf & _
" /FileInventory" & vbTab & vbTab & "Scan all file version" & v
bCrLf & _
" /Logfolder <Path>" & vbTab & "Custom directory for log file"
& vbCrLf &_
" /Quiet" & vbTab & vbTab & vbTab & "Don't open log when done"
Wscript.Quit
Case Else
End Select
Next 'iCnt
End If 'iArgCnt>0
End Sub
'===============================================================================
========================
Sub CleanUp
On Error Resume Next
Set oReg = Nothing
TextStream.Close
Set TextStream = Nothing
Set oFso = Nothing
Set oMsi = Nothing
Set oShell = Nothing
End Sub
'===============================================================================
========================