Finding A Memory Leak In My Code...
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
Answers (7)
Please log in to answer
Posted by:
bkelly
11 years ago
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
Posted by:
Ifan
11 years ago
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!
Posted by:
anonymous_9363
11 years ago
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.
Posted by:
Superfreak3
11 years ago
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!
Comments:
-
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! - gromret 10 years ago-
He could use debuggers, something like valgrind, purify or deleaker. These debuggers can specify the reason for the problem - MastAvalons 10 years ago
Posted by:
anonymous_9363
11 years ago
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
Posted by:
olditguy
11 years ago
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?
Comments:
-
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. - Ben M 11 years ago
