[RESOLVED] Memory usage information about my application
How can i get the current memory usage of my program (like the memory usage shown in task manager)?
I'm thinking that the GlobalMemoryStatusEx API may be involved? But this seems to be more about the system memory than info specific to my app.
Another option is GetProcessMemoryInfo()?
TIA
Last edited by AAraya; May 19th, 2018 at 11:13 AM.
I've found some VB6 code which uses the GetProcessMemoryInfo API to get memory usage but the value returned by the API does not match what Task Manager shows me. It's using the WorkingSetSize member of the PROCESS_MEMORY_COUNTERS structure as the process memory value. But again, that value doesn't match up with Task Manager. For example - this code is showing that my app running within the VB6 IDE is using 143MB of memory while Task Manager shows private working memory of 73MB.
Here's the code:
Code:
Private Type PROCESS_MEMORY_COUNTERS
cb As Long
PageFaultCount As Long
PeakWorkingSetSize As Long
WorkingSetSize As Long
QuotaPeakPagedPoolUsage As Long
QuotaPagedPoolUsage As Long
QuotaPeakNonPagedPoolUsage As Long
QuotaNonPagedPoolUsage As Long
PagefileUsage As Long
PeakPagefileUsage As Long
End Type
Private Const PROCESS_QUERY_INFORMATION = 1024
Private Const PROCESS_VM_READ = 16
Private Declare Function GetCurrentProcessId Lib "kernel32.dll" () As Long
Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccessas As Long, ByVal bInheritHandle As Long, ByVal dwProcId As Long) As Long
Private Declare Function GetProcessMemoryInfo Lib "PSAPI.DLL" (ByVal hProcess As Long, ppsmemCounters As PROCESS_MEMORY_COUNTERS, ByVal cb As Long) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal handle As Long) As Long
'Only supported by NT systems
Public Function GetProcessMemoryUsage() As Long
On Error Resume Next
Dim ProcId As Long
Dim pmc As PROCESS_MEMORY_COUNTERS
Dim HwndProcess As Long, lRet As Long
ProcId = GetCurrentProcessId()
HwndProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, ProcId)
If HwndProcess = 0 Then Exit Function
pmc.cb = LenB(pmc)
lRet = GetProcessMemoryInfo(HwndProcess, pmc, pmc.cb)
If lRet = 0 Then Exit Function
GetMemory = pmc.WorkingSetSize
lRet = CloseHandle(HwndProcess)
End Function
Last edited by AAraya; May 19th, 2018 at 02:31 PM.
It turns out that the code I posted above returns the "Working Set" memory size. But what Task Manager shows, and what I want, is the "Private Working Set" memory size. There's a difference between the two:
Working set actually tells you how many virtual pages for the process are mapped into physical memory. Working set memory is the amount of memory in the private working set plus the amount of memory the process is using that can be shared by other running processes. So basically private working set is the subset of working set that specifically describes the amount of memory a process is using that cannot be shared by other processes.
So I'm still in search of VB6 code to give me the memory size of the private working set for my program.
Last edited by AAraya; May 19th, 2018 at 03:33 PM.
You'll probably have to use QueryWorkingSet() instead.
Thanks. That looks like a pain from what I can see and there's no sample VB6 code out there for this...
There does seem to be a pretty painless way to get this value using WMI which I've had no luck running. I have no experience with WMI. Is there an easy way to get this VBA code snippet to run in VB6?
Set objWMI = GetObject("winmgmts:\\.\root\cimv2")
Set colProcesses = objWMI.ExecQuery( "Select * from Win32_PerfRawData_PerfProc_Process" )
For Each objProcess in colProcesses
Wscript.Echo objProcess.Name & " => " & CLng(objProcess.WorkingSetPrivate/1024) & "K"
Next
For anyone following this thread now or in the future, I've figured out how to use WMI to get Process Raw Performance Data. Here's the code:
Code:
Option Explicit
Private Declare Function GetCurrentProcessId Lib "kernel32.dll" () As Long
Sub Main()
Dim lngCurrentProcessID As Long
lngCurrentProcessID = GetCurrentProcessId
Dim lngErrCode As Long
Call GetProcessRawPerformanceData(lngCurrentProcessID, lngErrCode)
End Sub
Private Sub GetProcessRawPerformanceData(ByVal plngProcessID As Long, ByRef plngErrCode As Long)
On Error GoTo PROC_ERROR
'// Purpose: Get Process Raw Performance data for given process
'// using Windows Management Instrumentation (WMI)
'
'//requires a reference be set to Microsoft WMI Scripting Library (c:\windows\syswow64\wbemdisp.tlp)
Dim objLocator As WbemScripting.SWbemLocator
Dim objService As WbemScripting.SWbemServices
Dim objProcesses As WbemScripting.SWbemObjectSet
Dim objProcess As WbemScripting.SWbemObject
Dim objProp As WbemScripting.SWbemProperty
'' '//requires no reference to be set (is slower than above)
'' Dim objLocator As Object
'' Dim objService As Object
'' Dim objProcesses As Object
'' Dim objProcess As Object
'' Dim objProp As Object
'--Retrieve a locator object
Dim strObjectName As String
strObjectName = "WbemScripting.SWbemLocator"
Set objLocator = CreateObject(strObjectName)
If objLocator Is Nothing Then
plngErrCode = vbObjectError
GoTo PROC_EXIT
End If
'--Log on to the namespace
'If you do not specify a computer in the call to ConnectServer,
'then WMI connects to the local computer. If you do not specify a namespace,
'then WMI connects to the namespace specified in the registry key.
Dim strServer As String
Dim strNamespace As String
strServer = "."
strNamespace = "root\cimv2"
Set objService = objLocator.ConnectServer(strServer, strNamespace)
If objService Is Nothing Then
plngErrCode = vbObjectError
GoTo PROC_EXIT
End If
'-- query for the desired data
Dim strProcessID As String
Dim strQuery As String
strProcessID = CStr(plngProcessID)
strQuery = "Select * from Win32_PerfRawData_PerfProc_Process Where IDProcess = " & strProcessID
Set objProcesses = objService.ExecQuery(strQuery)
If objProcesses Is Nothing Then
plngErrCode = vbObjectError
GoTo PROC_EXIT
End If
'should be only one process matching the given process ID
If objProcesses.Count <> 1 Then
GoTo PROC_EXIT
End If
'get a reference to the process
Set objProcess = objProcesses.ItemIndex(0) '0-based collection
If objProcess Is Nothing Then
plngErrCode = vbObjectError
GoTo PROC_EXIT
End If
'iterate through the process info, getting each Property Name and Value
Const COLON_SPACE As String = ": "
Dim strPropName As String
Dim strPropValue As String
Dim strPropNameAndValue As String
With objProcess
For Each objProp In .Properties_
With objProp
'...property name
strPropName = .Name
'...property value
If .CIMType = wbemCimtypeString Then
'handle Null value case
If IsNull(.Value) Then
strPropValue = .Value & ""
Else
strPropValue = .Value
End If
Else
strPropValue = CStr(.Value)
End If
End With
strPropNameAndValue = strPropName & COLON_SPACE & strPropValue
Debug.Print strPropNameAndValue
Next
End With
PROC_EXIT:
If Not (objProp Is Nothing) Then Set objProp = Nothing
If Not (objProcess Is Nothing) Then Set objProcess = Nothing
If Not (objProcesses Is Nothing) Then Set objProcesses = Nothing
If Not (objService Is Nothing) Then Set objService = Nothing
If Not (objLocator Is Nothing) Then Set objLocator = Nothing
Exit Sub
PROC_ERROR:
plngErrCode = Err.Number
Resume PROC_EXIT
Resume
End Sub
Last edited by AAraya; May 23rd, 2018 at 02:26 PM.
Reason: improved WMI code
It turns out that WMI can provide the WorkingSetPrivate mem size. The documentation on the MS web site for the Win32_PerfRawData_PerfProc_Process class was incomplete and did not include the WorkingSetPrivate property but it's there and returns the correct value. I've corrected the WMI code above with this additional property.
So this works. It's slow however. I'd love to find a more performant way of obtaining this - like API for instance.
Here's an example of using the Performance Counters API to obtain the current process' Private Working Set:
Code:
Option Explicit
Private Const ERROR_SUCCESS As Long = &H0
Private Const PDH_MAX_COUNTER_PATH As Long = 2048
Private Const PERF_DETAIL_NOVICE As Long = 100
Private Const PERF_DETAIL_ADVANCED As Long = 200
Private Const PERF_DETAIL_EXPERT As Long = 300
Private Const PERF_DETAIL_WIZARD As Long = 400
Private Declare Function PdhCloseQuery Lib "pdh.dll" (ByVal QueryHandle As Long) As Long
Private Declare Function PdhCollectQueryData Lib "pdh.dll" (ByVal QueryHandle As Long) As Long
Private Declare Function PdhVbAddCounter Lib "pdh.dll" (ByVal QueryHandle As Long, ByVal CounterPath As String, ByRef CounterHandle As Long) As Long
Private Declare Function PdhVbGetDoubleCounterValue Lib "pdh.dll" (ByVal CounterHandle As Long, ByRef CounterStatus As Long) As Double
Private Declare Function PdhVbGetOneCounterPath Lib "pdh.dll" (ByVal PathString As String, ByVal PathLength As Long, ByVal DetailLevel As Long, ByVal CaptionString As String) As Long
Private Declare Function PdhVbIsGoodStatus Lib "pdh.dll" (ByVal StatusValue As Long) As Long
Private Declare Function PdhVbOpenQuery Lib "pdh.dll" (ByRef QueryHandle As Long) As Long
Private Declare Function SysReAllocStringLen Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long, Optional ByVal Length As Long) As Long
Private m_hQuery As Long
Private m_hCounter As Long
Private m_sCounterPath As String
Private Sub Form_Click()
Dim RV As Long, sCounterPath As String
If m_hQuery Then
Timer1 = False
RV = PdhCloseQuery(m_hQuery): Debug.Assert RV = ERROR_SUCCESS
If RV = ERROR_SUCCESS Then
m_hCounter = 0&
m_hQuery = 0&
End If
End If
RV = PdhVbOpenQuery(m_hQuery): Debug.Assert RV = ERROR_SUCCESS
If RV = ERROR_SUCCESS Then
'#Const BrowseforPerformanceCounter = True
#If BrowseforPerformanceCounter Then
SysReAllocStringLen VarPtr(m_sCounterPath), , PDH_MAX_COUNTER_PATH
RV = PdhVbGetOneCounterPath(m_sCounterPath, PDH_MAX_COUNTER_PATH, PERF_DETAIL_WIZARD, "Browse Performance Counters")
m_sCounterPath = Left$(m_sCounterPath, RV)
If LenB(m_sCounterPath) Then
#Else
If App.LogMode Then
m_sCounterPath = "\Process(Project1)\Working Set - Private"
Else
m_sCounterPath = "\Process(VB6)\Working Set - Private"
End If
#End If
RV = PdhVbAddCounter(m_hQuery, m_sCounterPath, m_hCounter): Debug.Assert RV = ERROR_SUCCESS
If RV = ERROR_SUCCESS Then Timer1 = True
#If BrowseforPerformanceCounter Then
End If
#End If
End If
End Sub
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyEscape Then Unload Me
End Sub
Private Sub Form_Unload(Cancel As Integer)
Dim RV As Long
If m_hQuery Then RV = PdhCloseQuery(m_hQuery): Debug.Assert RV = ERROR_SUCCESS
End Sub
Private Sub Timer1_Timer()
Dim RV As Long, CtrStatus As Long, CtrValue As Double
RV = PdhCollectQueryData(m_hQuery): Debug.Assert RV = ERROR_SUCCESS
If RV = ERROR_SUCCESS Then
CtrValue = PdhVbGetDoubleCounterValue(m_hCounter, CtrStatus)
If PdhVbIsGoodStatus(CtrStatus) Then
Caption = m_sCounterPath & " = " & FormatNumber(CtrValue / &H100000, 2&) & " MB [" & Timer & "]" '<-- The Timer is proof the Pdh* APIs are working as fast as they can
End If
End If
End Sub
'Visual Basic 4.0 definitions file for use with PDH.DLL the Peformance Data Helper DLL
'http://ftp.scana.com.ua/pub/ntreskit/PerfTool/LogTools/PDHDEFS.TXT
According to MSDN, "Applications such as the Windows Task Manager, the Reliability and Performance Monitor, and the Process Explorer tool use performance counters to display memory information for the system and for individual processes."
Your implementation works great. I wish I understood it better however - you seem to be using a generic memory buffer rather than a PSAPI_WORKING_SET_INFORMATION structure like the function description in MSDN calls for and you're moving about it to get the values you want. There are many calculations I don't understand the purpose of in there too. It's wizardry to me!
If I have couple of vb6.exe/project1.exe started which one's Private WS gets counted in your implementation?
Great question! As written, the demo above will always display the Private WS of the first instance of VB6.EXE/Project1.exe.
The Specifying a Counter Path topic describes how to construct a counter path that specifies a particular instance of an object (Process, Thread, etc.). Basically, the instance is identified via an index number. For example, if there are 2 or more Project1.exes, the 2nd instance can be specified like so:
Code:
'Instance indexes are 0-based. The index isn't required when specifying the 1st one.
m_sCounterPath = "\Process(Project1#1)\Working Set - Private"
Based on my limited testing, instance indexes appear to be in the order that they are enumerated by Process32First/Process32Next.
The PDH example is interesting and I'm able to make it work on my desktop but I think that there's a gotcha in here for which I've not found a workaround. The counter path string passed to PdhVbAddCounter must be localized or else it will fail in non-English locales. (See note in here: https://msdn.microsoft.com/en-us/lib...v=vs.85).aspx)
There is a language neutral version of this function called PdhAddEnglishCounter. But attempts to declare and call this routine rather than PdhVbAddCounter produce errors of Dll Entry Point not found. There doesn't seem to be a language-neutral version function among the PDH functions offered to VB developers? https://msdn.microsoft.com/en-us/lib...(v=vs.85).aspx
I need a solution which is language-neutral.
Last edited by AAraya; May 21st, 2018 at 11:23 AM.
The PDH example is interesting and I'm able to make it work on my desktop but I think that there's a gotcha in here for which I've not found a workaround. The counter path string passed to PdhVbAddCounter must be localized or else it will fail in non-English locales. (See note in here: https://msdn.microsoft.com/en-us/lib...v=vs.85).aspx)
There is a language neutral version of this function called PdhAddEnglishCounter. But attempts to declare and call this routine rather than PdhVbAddCounter produce errors of Dll Entry Point not found.
You're probably calling it in an OS prior to Vista. As stated in the Requirements section of the PdhAddEnglishCounter function, the "Minimum supported client" is "Windows Vista". I've checked the exports of pdh.dll (via Dependency Walker) in both Windows XP and 7 and I can confirm that PdhAddEnglishCounter is indeed not available in XP.
Originally Posted by AAraya
There doesn't seem to be a language-neutral version function among the PDH functions offered to VB developers?
Unfortunately, yes. The good news though, is that PdhAddEnglishCounter plays nicely with the VB PDH* functions, so there's really no need for a VB version.
Originally Posted by AAraya
I need a solution which is language-neutral.
I'm guessing you also need a solution that works in XP and later OSs. In that case, the approach I've shown might not be the best choice. Sorry.
You're probably calling it in an OS prior to Vista.
I'm on Win10
The problem was that there is no function exported by the pdh.dll with the name " PdhAddEnglishCounter". Using Dependency Walker as you suggested I was able to see that the correct name is either PdhAddEnglishCounterA or PdhAddEnglishCounterW. Once I made this change, all worked great! Thanks for your help.
Last edited by AAraya; May 21st, 2018 at 01:38 PM.
I was able to get the Private Working Set memory size for the currently running process using the PDH API. This can be tweaked to return any performance counter defined on a system. Here's the code:
Code:
Option Explicit
'//PDH related declares
Private Const ERROR_SUCCESS As Long = &H0
Private Declare Function PdhVbOpenQuery Lib "pdh.dll" (ByRef QueryHandle As Long) As Long
Private Declare Function PdhAddEnglishCounterW Lib "pdh.dll" (ByVal QueryHandle As Long, ByVal lpCounterPath As Long, ByVal dwUserData As Long, ByRef CounterHandle As Long) As Long
Private Declare Function PdhValidatePathW Lib "pdh.dll" (ByVal lpCounterPath As Long) As Long
Private Declare Function PdhCollectQueryData Lib "pdh.dll" (ByVal QueryHandle As Long) As Long
Private Declare Function PdhVbGetDoubleCounterValue Lib "pdh.dll" (ByVal CounterHandle As Long, ByRef CounterStatus As Long) As Double
Private Declare Function PdhVbIsGoodStatus Lib "pdh.dll" (ByVal StatusValue As Long) As Long
Private Declare Function PdhCloseQuery Lib "pdh.dll" (ByVal QueryHandle As Long) As Long
'//Process related declares
Private Declare Function GetCurrentProcessId Lib "kernel32.dll" () As Long
Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal Handle As Long) As Long
Private Declare Function GetModuleBaseName Lib "psapi" Alias "GetModuleBaseNameW" (ByVal hProcess As Long, ByVal hModule As Long, ByVal lpBaseName As Long, ByVal nSize As Long) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As Long) As Long
Private Const API_NULL As Long = 0
Private Const PROCESS_QUERY_INFORMATION As Long = 1024 'Required to retrieve certain information about a process,
Private Const PROCESS_VM_READ As Long = 16 'Required to read memory in a process using OpenProcess or ReadProcessMemory
Private Sub Form_Load()
Dim dblWorkingSetPrivateMem As Double
dblWorkingSetPrivateMem = GetWorkingSetPrivateMemUsePDH
If dblWorkingSetPrivateMem <> 0 Then
Dim strWorkingSetPrivateMemFormatted As String
strWorkingSetPrivateMemFormatted = FormatNumber(dblWorkingSetPrivateMem / &H100000, 2&) & " MB"
MsgBox "Private Working Set: " & strWorkingSetPrivateMemFormatted
End If
End Sub
Private Function GetWorkingSetPrivateMemUsePDH() As Double
'//Purpose: Get the Private Working Set memory size using the PDH API
'// Private Working Set memory is the value shown by Task Manager for a process
'
'To collect performance data using the PDH functions, perform the following steps.
'
'1. Create a query
'2. Add counters to the query
'3. Collect the performance data
'4. Display the performance data
'5. Close the query
Dim lngRetVal As Long
Dim lngQueryHandle As Long
Dim strCounterPath As String
Dim lngCounterHandle As Long
Dim lngCounterStatus As Long
Dim dblCounterValue As Double
'init
lngQueryHandle = 0
lngCounterHandle = 0
'create and initializes a query object that is used to manage the collection of performance data
lngRetVal = PdhVbOpenQuery(lngQueryHandle)
'...check return code
If lngRetVal <> ERROR_SUCCESS Then
GoTo PROC_EXIT
End If
'specify a counter path
'format used is: "\"Process"(process name w/out extension)\counter name"
Dim strProcessName As String
Dim strProcessNameNoExt As String
Dim strProcessNameNoExtInParens As String
Const PROCESS_TEXT As String = "Process"
Const BACKSLASH As String = "\"
Const COUNTER_NAME As String = "Working Set - Private"
strProcessName = GetCurrentProcessName()
strProcessNameNoExt = RemoveExtension(strProcessName)
strProcessNameNoExtInParens = EncloseInParenthesis(strProcessNameNoExt)
strCounterPath = BACKSLASH & PROCESS_TEXT & strProcessNameNoExtInParens & BACKSLASH & COUNTER_NAME
'validate that the counter exists on this computer
lngRetVal = PdhValidatePathW(StrPtr(strCounterPath))
'...check return code
If lngRetVal <> ERROR_SUCCESS Then
GoTo PROC_EXIT
End If
'create a locale-neutral counter entry in the query object
lngRetVal = PdhAddEnglishCounterW(lngQueryHandle, StrPtr(strCounterPath), 0&, lngCounterHandle)
'...check return code
If lngRetVal <> ERROR_SUCCESS Then
GoTo PROC_EXIT
End If
'Collect the current raw data value for all counters in the specified query
'and update the status code of each counter.
lngRetVal = PdhCollectQueryData(lngQueryHandle)
'...check return code
If lngRetVal <> ERROR_SUCCESS Then
GoTo PROC_EXIT
End If
'Get the current value of the specified counter as a double-precision floating point value.
dblCounterValue = PdhVbGetDoubleCounterValue(lngCounterHandle, lngCounterStatus)
'...check Counter status
lngRetVal = PdhVbIsGoodStatus(lngCounterStatus)
If lngRetVal = 0 Then
dblCounterValue = 0
End If
PROC_EXIT:
If lngQueryHandle <> 0 Then
PdhCloseQuery lngQueryHandle
End If
GetWorkingSetPrivateMemUsePDH = dblCounterValue
Exit Function
End Function
Private Function GetCurrentProcessName() As String
Dim lngCurrentProcessID As Long
Dim lngAccessRights As Long
Dim lngHwndProcess As Long
Dim strProcessName As String
Dim lngModuleHandle As Long
Dim lngRetVal As Long
Const MAX_COMPONENT_LEN As Long = 255
'get the ID of the current process (this program)
lngCurrentProcessID = GetCurrentProcessId()
'open process object
lngAccessRights = PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ
lngHwndProcess = OpenProcess(lngAccessRights, 0, lngCurrentProcessID)
'...check the return code
If lngHwndProcess = 0 Then
strProcessName = vbNullString
GoTo PROC_EXIT
End If
'get the name of the process
'...get a module handle needed for GetModuleBaseName
'...('If parameter is NULL, GetModuleHandle returns a handle to the file used to create the calling process (.exe file).)
lngModuleHandle = GetModuleHandle(API_NULL)
'...create a buffer to hold the name
Dim strBuffer As String
strBuffer = String$(MAX_COMPONENT_LEN, vbNullChar)
lngRetVal = GetModuleBaseName(lngHwndProcess, lngModuleHandle, StrPtr(strBuffer), MAX_COMPONENT_LEN)
'...check the return code
If lngRetVal = 0 Then
strProcessName = vbNullString
GoTo PROC_EXIT
End If
strProcessName = Left$(strBuffer, lngRetVal)
PROC_EXIT:
'close the process handle
If lngHwndProcess <> 0 Then
lngRetVal = CloseHandle(lngHwndProcess)
End If
GetCurrentProcessName = strProcessName
End Function
Private Function RemoveExtension(ByVal pstrString As String) As String
Const DOT_CHAR As String = "."
Dim lngDotPosition As Long
lngDotPosition = InStrRev(pstrString, DOT_CHAR, -1, vbBinaryCompare)
If lngDotPosition <> 0 Then
RemoveExtension = Left$(pstrString, lngDotPosition - 1)
Else
RemoveExtension = pstrString
End If
End Function
Private Function EncloseInParenthesis(ByVal pstrString As String) As String
EncloseInParenthesis = "(" & pstrString & ")"
End Function
Last edited by AAraya; May 21st, 2018 at 03:00 PM.
Re: [RESOLVED] Memory usage information about my application
Don't forget the caveat above regarding multiple instances! If your program ensures that there can be only 1 instance running, then there's nothing to modify. Otherwise, if your application allows multiple instances, then you'll have to explicitly specify the instance index of the current process. You can figure out the index by enumerating processes through Process32First/Process32Next.
Re: [RESOLVED] Memory usage information about my application
I needed something like this, so I smartened it up so that it actually works.
It could be streamlined a bit more, as I call GetCurrentProcessName twice, but it works for my purposes.
Personally, I'd be curious to note how much of my 2GB address allowance (without LAA turned on) that I'm using. I'm hoping the following is a close approximation of how much of that I'm using.
Code:
Option Explicit
'
Private Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As Long
th32DefaultHeapID As Long
th32ModuleID As Long
cntThreads As Long
th32ParentProcessID As Long
pcPriClassBase As Long
dwFlags As Long
szExeFile As String * 260&
End Type
'
Private Declare Function PdhVbOpenQuery Lib "pdh.dll" (ByRef QueryHandle As Long) As Long
Private Declare Function PdhAddEnglishCounterW Lib "pdh.dll" (ByVal QueryHandle As Long, ByVal lpCounterPath As Long, ByVal dwUserData As Long, ByRef CounterHandle As Long) As Long
Private Declare Function PdhValidatePathW Lib "pdh.dll" (ByVal lpCounterPath As Long) As Long
Private Declare Function PdhCollectQueryData Lib "pdh.dll" (ByVal QueryHandle As Long) As Long
Private Declare Function PdhVbGetDoubleCounterValue Lib "pdh.dll" (ByVal CounterHandle As Long, ByRef CounterStatus As Long) As Double
Private Declare Function PdhVbIsGoodStatus Lib "pdh.dll" (ByVal StatusValue As Long) As Long
Private Declare Function PdhCloseQuery Lib "pdh.dll" (ByVal QueryHandle As Long) As Long
'
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal Handle As Long) As Long
Private Declare Function GetModuleBaseName Lib "psapi" Alias "GetModuleBaseNameW" (ByVal hProcess As Long, ByVal hModule As Long, ByVal lpBaseName As Long, ByVal nSize As Long) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As Long) As Long
Private Declare Function ProcessFirst Lib "kernel32" Alias "Process32First" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function ProcessNext Lib "kernel32" Alias "Process32Next" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function CreateToolhelp32Snapshot Lib "kernel32" (ByVal lFlags As Long, ByVal lProcessID As Long) As Long
'
Private Sub Form_Load()
Dim dWorkingSetPrivateMem As Double
dWorkingSetPrivateMem = GetPrivateWorkingSetMemUsed
If dWorkingSetPrivateMem <> 0# Then MsgBox "Private Working Set: " & FormatNumber(dWorkingSetPrivateMem / &H100000, 2&) & " MB"
End Sub
Private Function GetPrivateWorkingSetMemUsed() As Double
' Get the Private Working Set memory size using the PDH API.
' Private Working Set memory is the value shown by Task Manager for a process.
'
Dim iRet As Long
Dim hQuery As Long
Dim sPath As String
Dim iHandle As Long
Dim iStatus As Long
'
iRet = PdhVbOpenQuery(hQuery) ' Create and initializes a query object that is used to manage the collection of performance data.
If iRet <> 0& Then GoTo GetOut
'
sPath = "\Process(" & RemoveExtension(GetCurrentProcessName()) & "#" & Format$(GetCurrentProcessIndex) & ")\Working Set - Private"
iRet = PdhValidatePathW(StrPtr(sPath)) ' Validate that the counter exists on this computer.
If iRet <> 0& Then GoTo GetOut
'
iRet = PdhAddEnglishCounterW(hQuery, StrPtr(sPath), 0&, iHandle) ' Create a locale-neutral counter entry in the query object.
If iRet <> 0& Then GoTo GetOut
'
iRet = PdhCollectQueryData(hQuery) ' Collect the current raw data value for all counters in the specified query and update the status code of each counter.
If iRet <> 0& Then GoTo GetOut
'
GetPrivateWorkingSetMemUsed = PdhVbGetDoubleCounterValue(iHandle, iStatus) ' Get the current value of the specified counter as a double-precision floating point value.
iRet = PdhVbIsGoodStatus(iStatus)
If iRet = 0& Then GetPrivateWorkingSetMemUsed = 0#
'
GetOut:
If hQuery <> 0& Then PdhCloseQuery hQuery
End Function
Private Function GetCurrentProcessName() As String
Dim iProcessID As Long
Dim iRights As Long
Dim hProcess As Long
Dim sName As String
Dim hModule As Long
Dim iRet As Long
Dim sBuf As String
'
Const MAX_COMPONENT_LEN As Long = 255&
Const PROCESS_QUERY_INFORMATION As Long = 1024& ' Required to retrieve certain information about a process,
Const PROCESS_VM_READ As Long = 16& ' Required to read memory in a process using OpenProcess or ReadProcessMemory
'
iProcessID = GetCurrentProcessId() ' Get the ID of the current process (this program).
iRights = PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ ' Open process object.
hProcess = OpenProcess(iRights, 0, iProcessID)
If hProcess = 0& Then GoTo GetOut
'
hModule = GetModuleHandle(0&) ' If parameter is 0, GetModuleHandle returns a handle to the file used to create the calling process (.exe file).
sBuf = String$(MAX_COMPONENT_LEN, vbNullChar) ' Create a buffer to hold the name.
iRet = GetModuleBaseName(hProcess, hModule, StrPtr(sBuf), MAX_COMPONENT_LEN)
If iRet = 0& Then GoTo GetOut
'
GetCurrentProcessName = Left$(sBuf, iRet)
'
GetOut:
If hProcess <> 0& Then iRet = CloseHandle(hProcess)
End Function
Private Function GetCurrentProcessIndex() As Long
Dim iProcessID As Long
Dim sProcessName As String
Dim iIndex As Long
Dim iRet As Long
'
Dim hSnapShot As Long
Dim uProcess As PROCESSENTRY32
'
Const TH32CS_SNAPPROCESS As Long = 2&
'
GetCurrentProcessIndex = -1&
iProcessID = GetCurrentProcessId() ' Get the ID of the current process (this program).
sProcessName = LCase$(GetCurrentProcessName())
'
hSnapShot = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0&)
If hSnapShot = -1& Then GoTo GetOut
'
uProcess.dwSize = Len(uProcess)
iRet = ProcessFirst(hSnapShot, uProcess)
If iRet <> 1& Then GoTo GetOut
'
Do
If LCase$(Left$(uProcess.szExeFile, InStr(uProcess.szExeFile, Chr$(0&)) - 1&)) = sProcessName Then
GetCurrentProcessIndex = GetCurrentProcessIndex + 1&
If uProcess.th32ProcessID = iProcessID Then Exit Do
End If
iRet = ProcessNext(hSnapShot, uProcess)
If iRet = 0& Then
GetCurrentProcessIndex = -1&
Exit Do
End If
Loop
'
GetOut:
If hSnapShot <> 0& Then iRet = CloseHandle(hSnapShot)
End Function
Private Function RemoveExtension(ByVal s As String) As String
Dim iPos As Long
iPos = InStrRev(s, ".")
If iPos <> 0& Then RemoveExtension = Left$(s, iPos - 1&) Else RemoveExtension = s
End Function
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
Re: [RESOLVED] Memory usage information about my application
Originally Posted by Elroy
It could be streamlined a bit more, as I call GetCurrentProcessName twice, but it works for my purposes.
You don't have to make function calls to get the EXE file name. It's in App.EXEName. In the IDE, it returns the project name. In an EXE, it returns the base EXE file name without ".exe", like "Project1".
Re: [RESOLVED] Memory usage information about my application
Originally Posted by qvb6
You don't have to make function calls to get the EXE file name. It's in App.EXEName. In the IDE, it returns the project name. In an EXE, it returns the base EXE file name without ".exe", like "Project1".
Yeah, once compiled, you're right.
However, to do this from the IDE, you've got to get the VB6.exe name, not the project's name.
Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.
Re: [RESOLVED] Memory usage information about my application
It could be great to find a way to track memory leaks.
I have 2 applications where I know there is at least 1 memory leak, but I tried to find it, and no way
I spent hundred of hours, but no way to find the memory leak
I have some doubt on one control, but not sure
Re: [RESOLVED] Memory usage information about my application
Originally Posted by Thierry69
It could be great to find a way to track memory leaks.
I have 2 applications where I know there is at least 1 memory leak, but I tried to find it, and no way
I spent hundred of hours, but no way to find the memory leak
I have some doubt on one control, but not sure
You are actually after private bytes. Working set is just the portion of the memory of your process that is currently resident. You will need to get your current process id. Leaks will show up in private bytes.
This will get you started and is very simple. Returns handle count and private bytes which are the two common leaks. Wont tell you where a leak is but it will help.
Code:
Public Function tcpAgentgetPerfmonHandles(handleCount As Long, privateBytes As Double)
10 On Error GoTo errorHandler
Dim myProcessId As Long
Dim objWmiProcess As Object
Dim wmiQuery As String
Dim Process As Object
Dim colProcesses As Object
20 myProcessId = GetCurrentProcessId
30 Set objWmiProcess = CreateObject("winmgmts:\\" & ".")
40 wmiQuery = "Select * from Win32_PerfRawData_PerfProc_Process where IDProcess = " + CStr(myProcessId)
50 Set colProcesses = objWmiProcess.ExecQuery(wmiQuery, , 48)
60 For Each Process In colProcesses
70 handleCount = Process.handleCount
80 privateBytes = Process.privateBytes
90 Next Process
100 Set colProcesses = Nothing
110 Set objWmiProcess = Nothing
120 Exit Function
errorHandler:
130 errorDisplay Err.description, "tcpAgentGetPermonHandles", Erl
140 Set colProcesses = Nothing
150 Set objWmiProcess = Nothing
160 Resume endofitall
endofitall:
End Function
Re: [RESOLVED] Memory usage information about my application
Originally Posted by Thierry69
It could be great to find a way to track memory leaks.
I have 2 applications where I know there is at least 1 memory leak, but I tried to find it, and no way
I spent hundred of hours, but no way to find the memory leak
I have some doubt on one control, but not sure
I've used two different tools to help with this problem: C++ Memory Validator and GlowCode.
Re: [RESOLVED] Memory usage information about my application
Originally Posted by Thierry69
Thanks, I'll give a look.
I should have changed up the order of those two suggestions as I've found GlowCode to be much more effective for me. I was also able to get a large discount from them since they longer actively support VB6. Can't guarantee that they'll offer you the same but no harm asking them.
Re: [RESOLVED] Memory usage information about my application
I'm having a problem with PdhVbGetOneCounterPath, it always returns zero and m_sCounterPath is always filled with char(0) instead of what I selected. (I'm using Windows 10)
I tried PdhCreateCounterPathList, but the dialog won't go away when I click OK
Last edited by neotechni; Jul 17th, 2021 at 02:22 PM.