Hi all,

I have an install widget the basically checks the ProductCode of an .msi, checks the registry to see if the product is installed, if not, it monitors msiexec processes and will fire the checked installer when the parent install process has finished.

When I watch this runnning with TaskManager, it seems that it is eating a ton of the CPU.

Is there any glaring memoryleak in the following code? I'm no expert, and just know enough to get by so any tips would be appreciated...

 

Imports Microsoft.Win32
Imports System.Diagnostics

Public Class Form1

    Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
        Me.Close()
    End Sub

    Private Sub Form1_Load(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Load

        Dim strFlag As String = Environment.GetCommandLineArgs.ElementAt(1) '0 element is path to .exe
        Dim strCode As String

        If strFlag = "/I" Then

            Dim strPath As String = Environment.GetCommandLineArgs.ElementAt(2) '0 element is path to .exe

            If Microsoft.VisualBasic.Right(strPath, 1) <> "\" Then
                strPath = strPath & "\"
            End If

            'Get the Product Code and determine if installed...
            strCode = GetProductCode(strPath & "Client\AdeptDWG\Install\RealDWGx64.msi")

            If Not FindRelatedProduct(strCode) Then
                'If not installed, no need to worry about removing earlier versions (different ProductCode) in code.
                'Removal will be taken care of with Major Upgrade of new RealDWG installer.

                'System.Threading.Thread.Sleep(30000)
                Call CheckMSIExec()

                Shell("msiexec /qb! /i """ & strPath & "Client\AdeptDWG\Install\RealDWGx64.msi""", AppWinStyle.NormalFocus, False)
            End If

            End
        Else 'Uninstall RealDWG
            Call RemoveRealDWG()
            End
        End If


    End Sub

    Public Function GetProductCode(ByVal msiFile As String) As String

        Dim oInstaller As WindowsInstaller.Installer
        Dim oDatabase As WindowsInstaller.Database
        Dim oView As WindowsInstaller.View = Nothing
        Dim oRecord As WindowsInstaller.Record
        Dim strSQL As String
        Dim strCode As String

        Try
            oInstaller = CType(CreateObject("WindowsInstaller.Installer"), WindowsInstaller.Installer)
            oDatabase = oInstaller.OpenDatabase(msiFile, 0) 'Open Read-Only
            strSQL = "SELECT * FROM `Property` WHERE `Property`='ProductCode'"

            oView = oDatabase.OpenView(strSQL)
            oView.Execute()

            oRecord = oView.Fetch

            strCode = oRecord.StringData(2)

            Return strCode

        Catch ex As Exception
            'Do Nothing
            MsgBox("[1]: " & ex.Message, MsgBoxStyle.OkOnly, "RealDWGx64 Product Code...")
            End
        Finally
            oRecord = Nothing
            If Not (oView Is Nothing) Then
                oView.Close()
            End If
            oView = Nothing
            oDatabase = Nothing
            oInstaller = Nothing
        End Try
    End Function

    Public Function FindRelatedProduct(ByVal strCode As String) As Boolean
        Dim regKey As RegistryKey
        Dim blnFound As Boolean = False

        regKey = Registry.LocalMachine.OpenSubKey("Software\Microsoft\Windows\CurrentVersion\Uninstall")

        For Each key In regKey.GetSubKeyNames
            If key = strCode Then
                blnFound = True
            End If
        Next

        Return blnFound
    End Function

    Public Sub RemoveRealDWG()
        Dim regKey, _
            regKeySub As RegistryKey
        Dim strValue As String

        regKey = Registry.LocalMachine.OpenSubKey("Software\Microsoft\Windows\CurrentVersion\Uninstall")

        For Each key In regKey.GetSubKeyNames
            regKeySub = Registry.LocalMachine.OpenSubKey("Software\Microsoft\Windows\CurrentVersion\Uninstall\" & key)
            strValue = regKeySub.GetValue("Comments")
            If strValue = "RealDWG for x64 Adept Client" Then

                'System.Threading.Thread.Sleep(30000)
                Call CheckMSIExec()

                Shell("msiexec /qb! /x " & key, AppWinStyle.NormalFocus, False)
                End

            End If
        Next
    End Sub

    Public Sub CheckMSIExec()

        'Cycle through running processes and see if MSI engine ready to start RealDWG installer...
        Dim procList() As Process = Process.GetProcesses
        Dim i As Integer
        Dim intCount As Integer = 0

        For i = 0 To procList.Count - 1
            If InStr(UCase(procList(i).ProcessName), "MSIEXEC") > 0 Then
                intCount = intCount + 1
            End If
        Next

        If intCount > 1 Then
            Call CheckMSIExec()
        End If

    End Sub
End Class

 

Everything works as I would like as coded, but there is a delay so something seems to have the need to be streamlined.

Again, any help is Greatly Appreciated!

0 Comments   [ + ] Show Comments

Comments

Please log in to comment

Answers

3

Could it be that what you have written is replicated by the built-in AppSearch feature? Check out http://www.itninja.com/blog/view/appdeploy-com-gt-training-videos-gt-windows-installer-appsearch-wise-system-search

Answered 07/10/2012 by: bkelly
Red Belt

Please log in to comment
3

As far as i can see your for loop in the CheckMSIExec sub will loop as fast as it can. This will eat a ton of CPU. What about building in some sort of throttling in there?

Also, is it really necessary that most of your functions and subs are public? This is not best practice!

Answered 07/11/2012 by: Ifan
Second Degree Green Belt

Please log in to comment
2

You're aware, of course, that the engine will occasionally be left running, even if an installation isn't happening?

You should kick off MSIExec and then get the process ID. IIRC, the Shell object allows you to do that. Then the code should check when that process ID is no longer present.

Answered 07/11/2012 by: VBScab
Red Belt

Please log in to comment
2

The CheckMSIExec code was the problem.  I changed that to a boolean function that returns True (still running) or false (OK to start other msi process).

I call this from a Do loop that contains a sleep for a second or two then a call to the function.  It seems to have remedied the problem.

Thanks!

Answered 07/11/2012 by: Superfreak3
Black Belt

  • Superfreak3, how you solved the problem? How defined where was the problem??
    I have a similar problem. Task Manager shows the leak. But I can not find it!
    • He could use debuggers, something like valgrind, purify or deleaker. These debuggers can specify the reason for the problem
Please log in to comment
1

Here's some VBS I dug up from a really old project I was involved in. Perhaps you can adapt it to suit...

 	Option Explicit

Dim blnResult
Dim blnIsCustomAction
Dim intIndex
Dim blnIsError
Dim strMsg
Dim objFSO
Dim objWSHShell
Dim objWSHShellApp
Dim objWMIService
Dim objEventSink
Dim strScriptFullName
Dim strScriptName
Dim strScriptRoot
Dim strScriptPath
Dim strScriptAppDrive

Dim dicArguments
Dim intWaitCounter
Dim intMaxTime
Dim blnProcessTerminated

Const intFSOForReading = 1
Const intFSOForWriting = 2
Const intFSOForAppending = 8
Const intFSOTristateFalse = 0

'Const strProcessToStart = "SETUP.EXE"
'Const strProcessToWatch = "JAVAW.EXE"
Const strProcessToStart = "NOTEPAD.EXE"
Const strProcessToWatch = "WORDPAD.EXE"

Call Main
Call CleanUp

Sub Main
Dim blnMainResult
Dim strPrimaryProcess
Dim strPrimaryProcessPath
Dim strSecondaryProcess
Dim lngProcessID

intMaxTime = 900 '// 15 minutes!
intMaxTime = 10

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objWSHShell = CreateObject("Wscript.Shell")
Set objWSHShellApp = CreateObject("Shell.Application")
Set dicArguments = CreateObject("Scripting.Dictionary")
Set objWMIService = GetObject("WINMGMTS:{impersonationLevel=impersonate,(Security)}!\\.\ROOT\CIMV2")

dicArguments.CompareMode = vbTextcompare '// Ignore case in command-line arguments

'//------------------------------------------------------------------------------------------------------------//
'// Set some variables for script usage
'//------------------------------------------------------------------------------------------------------------//
With objFSO
strScriptFullName = WScript.ScriptFullName
strScriptName = WScript.ScriptName
strScriptRoot = .GetFile(strScriptFullName).ParentFolder.ParentFolder
strScriptPath = .GetFile(strScriptFullName).ParentFolder
strScriptAppDrive = .GetFile(strScriptFullName).Drive
End With

'//------------------------------------------------------------------------------------------------------------//
'// Force use of CScript
'//------------------------------------------------------------------------------------------------------------//
Call ForceCScriptExecution(True)

blnIsCustomAction = False

On Error Resume Next
If IsObject(Session) Then
'// We may have arrived here because error-trapping is off
If Err.Number = 0 Then
blnIsCustomAction = True
End If
End If
On Error Goto 0

'// Get the folder you want to process and the target folder
If WScript.Arguments.Count < 2 Then
strMsg = "Enter the name of the process you want to "

Select Case WScript.Arguments.Count
Case 0
strPrimaryProcess = InputBox(strMsg & "launch", "Process Name", strProcessToStart)
If Len(strPrimaryProcess) = 0 Then
blnIsError = True
strMsg = "You must specify " & strMsg
Call Say(strMsg, blnIsError, blnIsCustomAction)
Exit Sub
End If

strSecondaryProcess = InputBox(strMsg & "monitor", "Process Name", strProcessToWatch)
If Len(strPrimaryProcess) = 0 Then
blnIsError = True
strMsg = "You must specify " & strMsg
Call Say(strMsg, blnIsError, blnIsCustomAction)
Exit Sub
End If

Case 1
strSecondaryProcess = InputBox(strMsg & "monitor", "Process Name", strProcessToWatch)
If Len(strPrimaryProcess) = 0 Then
blnIsError = True
strMsg = "You must specify " & strMsg
Call Say(strMsg, blnIsError, blnIsCustomAction)
Exit Sub
End If

Case Else
strSecondaryProcess = InputBox(strMsg & "monitor", "Process Name", strProcessToWatch)
If Len(strPrimaryProcess) = 0 Then
blnIsError = True
strMsg = "You must specify " & strMsg
Call Say(strMsg, blnIsError, blnIsCustomAction)
Exit Sub
End If
End Select
Else
strPrimaryProcess = WScript.Arguments(0)
strSecondaryProcess = WScript.Arguments(1)
End If

'// Create the Event Notification sink
Set objEventSink = CreateObject("WbemScripting.SWbemSink")

WScript.ConnectObject objEventSink,"EVENTSINK_"

'// If the Primary Process name contains a backslash, then we need to parse the path.
'// If it doesn't, we can use the script's path
intIndex = InStrRev(strPrimaryProcess, "\")
If intIndex > 0 Then
strPrimaryProcessPath = Mid(strPrimaryProcess, 1, intIndex - 1)
strPrimaryProcess = Mid(strPrimaryProcess, intIndex+1, Len(strPrimaryProcess) - intIndex)
Else
strPrimaryProcessPath = strScriptPath
End If

blnMainResult = ProcessLaunch(strPrimaryProcess, strPrimaryProcessPath)

If Not blnMainResult Then
'// Failed to start process
Exit Sub
End If

'// Wait for a short delay, find the secondary process and get its process ID, ready to watch that process
Call Sleep(10)

blnMainResult = FindProcess(".", strSecondaryProcess, lngProcessID)
If Not blnMainResult Then
'// Failed to find secondary process
Exit Sub
End If

Call WatchProcess(lngProcessID)

Do While blnProcessTerminated = False
intWaitCounter = intWaitCounter + 1
Wscript.Sleep(1000)
'wscript.echo "Waiting..." & intWaitCounter & ", " & intMaxTime
If intWaitCounter > intMaxTime Then
blnIsError = True
strMsg = String(3, vbCRLF) & "Process ID:" & lngProcessID & " timed out at " & Now()
Call Say(strMsg, blnIsError, blnIsCustomAction)
blnMainResult = KillProcessByID(lngProcessID)
'blnMainResult = KillProcessByName(strSecondaryProcess)
End If
Loop

End Sub

Function BrowseForFolder(ByVal strPrompt)
'// Uses "Shell.Application" (only present in Win98 and newer)
'// to bring up a file/folder selection window. Falls back to an
'// ugly input box under Win95.

'Shell32.Shell SpecialFolder constants
Const ssfPERSONAL = 5 '// My Documents
Const ssfDRIVES = 17 '// My Computer
Const ssfWINDOWS = 36 '// Windows
Const SFVVO_SHOWALLOBJECTS = 1
Const SFVVO_SHOWEXTENSIONS = 2

Const BIF_RETURNONLYFSDIRS = &H0001
Const BIF_EDITBOX = &H0010
Const BIF_VALIDATE = &H0020
Const BIF_NEWDIALOGSTYLE = &H0040

Dim objFolder
Dim lngView
Dim strPath

If Instr(TypeName(objWSHShellApp), "Shell") = 0 Then
BrowseForFolder = InputBox(strPrompt, "Select Folder", CreateObject("Scripting.FileSystemObject").GetParentFolderName(strScriptFullName))
Exit Function
End If

lngView = SFVVO_SHOWALLOBJECTS Or SFVVO_SHOWEXTENSIONS
lngView = lngView + BIF_NEWDIALOGSTYLE + BIF_VALIDATE + BIF_EDITBOX + BIF_RETURNONLYFSDIRS

strPath = ""

Set objFolder = objWSHShellApp.BrowseForFolder(&0, strPrompt, lngView, ssfDRIVES)
Err.Clear

On Error Resume Next
strPath = objFolder.ParentFolder.ParseName(objFolder.Title).Path

'// An error occurs if the user selects a drive instead of a folder
'// so handle it here
Select Case Err.Number
Case 0
BrowseForFolder = strPath
Case 424
'// User probably selected a drive. Let's see.
'// First, have a fall-back option
BrowseForFolder = objFolder.Title

strPath = objFolder.Title
If Len(strPath) > 0 Then
intIndex = InStr(strPath, ":")
If intIndex > 0 Then
strPath = Mid(strPath, intIndex - 1, 2) & "\"
End If
End If
Case Else
End Select

'// If the user *types (or pastes) in* an incorrect path, no error is raised
'// so handle it here
If Len(strPath) > 0 Then
'// Only process if something was entered/selected.
'// However, ignore '.' (use current folder) or '..' (use parent folder)
If strPath = "." Or strPath = ".." Then

BrowseForFolder = strPath
Exit Function
End If

If objFSO.FolderExists(strPath) Then
BrowseForFolder = strPath
Exit Function
End If

blnIsError = True
strMsg = "The folder '" & strPath & "' does not exist."

Call Say(strMsg, blnIsError, blnIsCustomAction)

BrowseForFolder = ""
End If
On Error Goto 0
End Function

Sub ForceCScriptExecution(ByVal blnQuoteArguments)
Dim objShellRun
Dim strArgument
Dim strArguments
Dim strCmdLine
Dim intIndex

'// If running in CScript, do nothing
If UCase(Right(WScript.FullName, 11)) = "CSCRIPT.EXE" Then
Exit Sub
End If

If WScript.Arguments.Count > 0 Then
strArguments = ""
For intIndex = 0 To (WScript.Arguments.Count - 1)
If Len(strArguments) = 0 Then
strArguments = WScript.Arguments(intIndex)
Else
strArguments = strArguments & " " & WScript.Arguments(intIndex)
End If
Next

If blnQuoteArguments Then
strArguments = Chr(34) & strArguments & Chr(34)
End If
End If

'// If running in WScript, execute the script using CScript
'// and then quit this script
If UCase(Right(WScript.FullName, 11)) = "WSCRIPT.EXE" Then
Set objShellRun = CreateObject("WScript.Shell")
'objShellRun.Run "CSCRIPT.EXE """ & WScript.ScriptFullName & """", 1, False

strCmdLine = "CSCRIPT.EXE "

If InStr(WScript.ScriptFullName, " ") > 0 Then
strCmdLine = strCmdLine & Chr(34)
End If

strCmdLine = strCmdLine & WScript.ScriptFullName

If InStr(WScript.ScriptFullName, " ") > 0 Then
strCmdLine = strCmdLine & Chr(34)
End If

If Len(strArguments) > 0 Then
strCmdLine = strCmdLine & " "
strCmdLine = strCmdLine & strArguments
End If

objShellRun.Run strCmdLine, 1, False

Set objShellRun = Nothing
WScript.Quit
End If

'// If script engine is anything else, quit with an error
WScript.Echo "Unknown scripting engine."
WScript.Quit
End Sub

'/////////////////////////////////////////////////////////////////////
'//
'// Name: ParseArgs
'// Purpose: Parse the arguments using Split function and return as a dictionary object
'// Allows simple existence and value checks throughout the rest of the script.
'// The order that the switches are used on the command line does not matter.
'//
'// Syntax: You can use switches formatted in the following ways:
'// SWITCH=<VALUE>
'// SWITCH="<value with spaces>"
'// /SWITCH=<VALUE>
'// /SWITCH
'// SWITCH=value1;value2;value3
'//
'// Usage and notes: If a switch is present more than once, the *last* value is used
'//
'// Limitations: You cannot use "/switch value" syntax: "=" is required
'//
'/////////////////////////////////////////////////////////////////////
Sub ParseArgs
Dim arrArgument
Dim strArgument

On Error Resume Next
For Each strArgument In WScript.Arguments
If InStr(strArgument, "=") > 0 Then
arrArgument = Split(strArgument, "=", 2)

'/ If value is specified multiple times, last one wins
If dicArguments.Exists(Trim(arrArgument(0))) Then
dicArguments.Remove(Trim(arrArgument(0)))
End If

If UBound(arrArgument) >= 1 Then
dicArguments.Add Trim(arrArgument(0)), Trim(arrArgument(1))
Else
dicArguments.Add Trim(arrArgument(0)),""
End If
Else
dicArguments.Add strArgument
End If
Next
On Error Goto 0
End Sub

Function ProcessLaunch(ByVal strProcessName, ByVal strProcessPath)
Dim objProcess
Dim objStartup
Dim objConfig
Dim lngReturn
Dim lngID

Const intSW_HIDE = 0 '// Hides the window and activates another window.
Const intSW_NORMAL = 1 '// Activates and displays a window.
'// If the window is minimised or maximised, the system restores it to the original size and position.
'// An application specifies this flag when displaying the window for the first time.
Const intSW_SHOWMINIMIZED = 2 '// Activates the window, and displays it as a minimised window.
Const intSW_SHOWMAXIMIZED = 3 '// Activates the window, and displays it as a maximised window.
Const intSW_SHOWNOACTIVATE = 4 '// Displays a window in its most recent size and position.
'// This value is similar to SW_SHOWNORMAL, except that the window is not activated.
Const intSW_SHOW = 5 '// Activates the window, and displays it at the current size and position.
Const intSW_MINIMIZE = 6 '// Minimises the specified window, and activates the next top level window in the Z order.
Const intSW_SHOWMINNOACTIVE = 7 '// Displays the window as a minimised window. This value is similar to SW_SHOWMINIMZED,
'// except that the window is not activated.
Const intSW_SHOWNA = 8 '// Displays the window at the current size and position. This value is similar to SW_SHOW,
'// except that the window is not activated.
Const intSW_RESTORE = 9 '// Activates and displays the window. If the window is minimised or maximised, the system
'// restores it to the=original size and position. An application specifies this flag when
'// restoring a minimised window.
Const intSW_SHOWDEFAULT = 10 '// Sets the show state based on the SW_ value that is specified in the STARTUPINFO structure
'// passed to the CreateProcess function by the program that starts the application.
Const intSW_FORCEMINIMIZE = 11 '// Windows Server 2003, Windows 2000, and Windows XP:
'// Minimises a window, even when the thread that owns the window is hung.
'// Only use this flag when minimising windows from a different thread.

ProcessLaunch = False

Set objStartup = objWMIService.Get("Win32_ProcessStartup")
Set objConfig = objStartup.SpawnInstance_
objConfig.ShowWindow = intSW_NORMAL

Set objProcess = objWMIService.Get("Win32_Process")

'Err.Clear
lngReturn = objProcess.Create(strProcessName, strProcessPath, objConfig, lngID)

If lngReturn = 0 Then
blnIsError = False
strMsg = String(3, vbCRLF) & "Process " & strProcessName & ", ID:" & lngID & ", started at " & Now()

Call Say(strMsg, blnIsError, blnIsCustomAction)
Else
blnIsError = True
strMsg = "Failed to launch " & strProcessName & vbCRLF
strMsg = strMsg & "Error " & lngReturn & ":"
Select Case lngReturn
Case 2
strMsg = strMsg & "Access denied."
Case 3
strMsg = strMsg & "Insufficient privilege."
Case 8
strMsg = strMsg & "Unknown failure."
Case 9
strMsg = strMsg & "Path not found."
Case 21
strMsg = strMsg & "Invalid parameter."
End Select

Call Say(strMsg, blnIsError, blnIsCustomAction)
Exit Function
End If

blnProcessTerminated = False
intWaitCounter = 0

ProcessLaunch = True
End Function

Function KillProcessByName(ByVal strName)

Dim strQuery
Dim objProcess
Dim colProcess

KillProcessByName = False

strQuery = ""
strQuery = strQuery & "SELECT "
strQuery = strQuery & "* "
strQuery = strQuery & "FROM "
strQuery = strQuery & "Win32_Process "
strQuery = strQuery & "WHERE "
strQuery = strQuery & "NAME='"
strQuery = strQuery & strName
strQuery = strQuery & "'"

On Error Resume Next
Set colProcess = objWMIService.ExecQuery(strQuery)

If Err.Number = 0 Then
If colProcess.Count <> 0 Then
For Each objProcess In colProcess
objProcess.Terminate()
If Err.Number = 0 Then
blnIsError = False
strMsg = String(3, vbCRLF) & "Process ID:" & lngID & " terminated at " & Now()
objEventSink.Cancel()
blnProcessTerminated = True
KillProcessByName = True
Else
blnIsError = True
strMsg = String(3, vbCRLF) & "Failed to terminate process ID:" & lngID
End If

Call Say(strMsg, blnIsError, blnIsCustomAction)
Next
End If
End If

On Error Goto 0
End Function

Function KillProcessByID(ByVal lngID)

Dim strQuery
Dim objProcess
Dim colProcess

KillProcessByID = False

strQuery = ""
strQuery = strQuery & "SELECT "
strQuery = strQuery & "* "
strQuery = strQuery & "FROM "
strQuery = strQuery & "Win32_Process "
strQuery = strQuery & "WHERE "
strQuery = strQuery & "ProcessID="
strQuery = strQuery & lngID

On Error Resume Next
Set colProcess = objWMIService.ExecQuery(strQuery)

If Err.Number = 0 Then
If colProcess.Count <> 0 Then
For Each objProcess In colProcess
objProcess.Terminate()
If Err.Number = 0 Then
blnIsError = False
strMsg = String(3, vbCRLF) & "Process ID:" & lngID & " terminated at " & Now()
objEventSink.Cancel()
blnProcessTerminated = True
KillProcessByID = True
Else
blnIsError = True
strMsg = String(3, vbCRLF) & "Failed to terminate process ID:" & lngID
End If

Call Say(strMsg, blnIsError, blnIsCustomAction)
Next
End If
End If

On Error Goto 0
End Function

Function FindProcess(ByVal strMachine, ByVal strProcessName, ByRef lngID)
Dim objProcess
Dim colProcess
Dim strName
Dim lngProcID

FindProcess = False
Set colProcess = objWMIService.ExecQuery ("Select * from Win32_Process")

For Each objProcess in colProcess
strName = objProcess.Name
lngProcID = objProcess.ProcessID
If UCase(strName) = UCase(strProcessName) Then
Exit For
End If
Next

If IsEmpty(lngProcID) Then
strMsg = ""
strMsg = strMsg & "Cannot find process '" & strProcessName & "'"
Else
strMsg = ""
strMsg = strMsg & "Process to watch '" & strProcessName & "' has ID: " & lngProcID
FindProcess = True
lngID = lngProcID
End If

Call Say(strMsg, blnIsError, blnIsCustomAction)

Set colProcess = Nothing

End Function

Sub WatchProcess(ByVal lngID)
Dim strQuery

strQuery = ""
strQuery = strQuery & "SELECT "
strQuery = strQuery & "* "
strQuery = strQuery & "FROM "
strQuery = strQuery & "__InstanceOperationEvent "
strQuery = strQuery & "WITHIN 1 "
strQuery = strQuery & "WHERE "
strQuery = strQuery & "TargetInstance "
strQuery = strQuery & "ISA "
strQuery = strQuery & "'Win32_Process' "
strQuery = strQuery & "AND "
strQuery = strQuery & "TargetInstance.ProcessID='"
strQuery = strQuery & lngID & "'"

objWMIService.ExecNotificationQueryAsync objEventSink, strQuery

strMsg = ""
strMsg = strMsg & "Setting watch on process ID: " & lngID

Call Say(strMsg, blnIsError, blnIsCustomAction)

End Sub

Sub EVENTSINK_OnObjectReady(ByVal objInstance, ByVal objAsyncContext)

If objInstance.Path_.Class = "__InstanceDeletionEvent" Then
blnIsError = False
strMsg = String(3, vbCRLF) & "Process ID:" & objInstance.TargetInstance.ProcessID & " completed at " & Now()
Call Say(strMsg, blnIsError, blnIsCustomAction)

objEventSink.Cancel()
blnProcessTerminated = True
End If

End Sub

Sub EVENTSINK_OnCompleted(ByVal objInstance, ByVal objAsyncContext)

blnIsError = False
strMsg = "ExecQueryAsync completed"
Call Say(strMsg, blnIsError, blnIsCustomAction)
blnProcessTerminated = True

End Sub

Sub Say(ByVal strMsgText, ByVal blnError, ByVal blnCustomAction)
Dim intMSILogMsgType
Dim intEventLogMsgType
Dim objMSIRecord

Const intLogEventSuccess = 0
Const intLogEventError = 1
Const intLogEventWarning = 2
Const intLogEventInformation = 4
Const intLogEventAuditSuccess = 8
Const intLogEventAuditFailure = 16

Const msiMessageTypeFatalExit = &H00000000 '// Premature termination, possibly fatal out of memory.
Const msiMessageTypeError = &H01000000 '// Formatted error message, [1] is message number in Error table.
Const msiMessageTypeWarning = &H02000000 '// Formatted warning message, [1] is message number in Error table.
Const msiMessageTypeUser = &H03000000 '// User request message, [1] is message number in Error table.
Const msiMessageTypeInfo = &H04000000 '// Informative message for log, not to be displayed.
Const msiMessageTypeFilesInUse = &H05000000 '// List of files in use that need to be replaced.
Const msiMessageTypeResolveSource = &H06000000 '// Request to determine a valid source location.
Const msiMessageTypeOutOfDiskSpace = &H07000000 '// Insufficient disk space message.
Const msiMessageTypeActionStart = &H08000000 '// Start of action,
'// [1] action name,
'// [2] description,
'// [3] template for ACTIONDATA messages.
Const msiMessageTypeActionData = &H09000000 '// Action data. Record fields correspond to the template of ACTIONSTART message.
Const msiMessageTypeProgress = &H0A000000 '// Progress bar information. See the description of record fields below.
Const msiMessageTypeCommonData = &H0B000000 '// To enable the Cancel button set [1] to 2 and [2] to 1.
'// To disable the Cancel button set [1] to 2 and [2] to 0

If blnError Then
intMSILogMsgType = msiMessageTypeError
intEventLogMsgType = intLogEventError
Else
intMSILogMsgType = msiMessageTypeInfo
intEventLogMsgType = intLogEventSuccess
End If

If blnCustomAction Then
Set objMSIRecord = Session.Installer.CreateRecord(0)
objMSIRecord.StringData(0) = strMsgText
Session.Message intMSILogMsgType, objMSIRecord
Set objMSIRecord = Nothing
Else
'// Make an entry in Event Log
objWSHShell.LogEvent intEventLogMsgType, strMsg

WScript.Echo strMsgText
End If
End Sub

Sub Sleep(ByVal intSleepPeriod)
'// Timer returns the number of seconds that have elapsed since midnight.

Dim intStartTime
Dim intEndTime
Dim intCurrentTime

On Error Resume Next

intStartTime = Timer
intEndTime = intStartTime + intSleepPeriod

Do While Timer <= intEndTime
Loop

On Error Goto 0

End Sub

Sub CleanUp
Set objWMIService = Nothing
Set objFSO = Nothing
Set objWSHShellApp = Nothing
Set objWSHShell = Nothing
Set dicArguments = Nothing
End Sub

Answered 07/11/2012 by: VBScab
Red Belt

Please log in to comment
-2

Hi Superfreak3

I don't think your program has a memory leak as such (i.e. allocates but doesn't free memory) but I'm puzzled by the Sub CheckMSIExec.

If i'm reading it right (forgive me if I've misunderstood your logic)

checkMSIExec checks to see if msiexec is a running process and if so increments a flag. Then if the flag is greater than 1 it calls CheckMSIExec which checks to see if MSIExec is running, and, if so, increments a flag then calls CheckMSIExec ....

What causes CheckMSIExec to be exited?

Answered 07/10/2012 by: olditguy
Second Degree Blue Belt

  • CheckMSIExec will run until the msiexe process is not running. As long as the msiexec process is running the sub will loop. Once the process is gone the sub will stop looping and the script will move on.
Please log in to comment
-2

I don't see any memory leak in your code..

Answered 07/10/2012 by: jagadeish
Red Belt

Please log in to comment
Answer this question or Comment on this question for clarity