Option Explicit

On Error Resume Next

Dim strComputer, strNamespace, strAppname, strAppPath, objLib, strNewGuid
Dim objSWbemServices, objSWbemObject, objNewSWbemObject

' Check all arguments required have been passed
If Wscript.Arguments.Count < 2 Then
Wscript.Echo "Arguments <App Name> <App Path> required. For example:" & vbCrLf _
& "cscript xpcompatpubapp.vbs appname c:\path\app.exe"
Wscript.Quit(0)
End If

strAppName = Wscript.Arguments(0)
strAppPath = Wscript.Arguments(1)


strComputer = "." 
strNamespace = "\root\cimv2\TerminalServices" 

'******************************************************* 
'Create a unique ID for the app entry in the allow list. 
'******************************************************* 
set objLib = createobject("Scriptlet.TypeLib") 
strNewGuid=Mid(objLib.GUID,2,8) 

Set objSWbemServices = GetObject("winmgmts:\\" & strComputer & strNamespace) 
Set objSWbemObject = objSWbemServices.Get("Win32_TSPublishedApplication") 
Set objNewSWbemObject = objSWbemObject.SpawnInstance_() 

'*************************************************************************************** 
'Set the various properties for the application to be added 
'*************************************************************************************** 
objNewSWbemObject.Properties_.Item("Name") = strAppName 
objNewSWbemObject.Properties_.Item("Alias") = strNewGuid 
objNewSWbemObject.Properties_.Item("Path") = strAppPath 
objNewSWbemObject.Properties_.Item("PathExists") = "true" 
objNewSWbemObject.Properties_.Item("CommandLineSetting") = "1" 
objNewSWbemObject.Properties_.Item("RequiredCommandLine") = "" 
objNewSWbemObject.Properties_.Item("IconIndex") = "0" 
objNewSWbemObject.Properties_.Item("IconPath") = strAppPath 
objNewSWbemObject.Properties_.Item("VPath") = strAppPath 
objNewSWbemObject.Properties_.Item("ShowInPortal") = "0" 

'******************************************* 
'Add the application entry 
'******************************************* 
objNewSWbemObject.Put_