[RESOLVED] Memory usage information about my application

[AAraya]

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

[Victor Bravo VI]

See Memory Performance Information and Performance Counters.

[AAraya]

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:

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

[AAraya]

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.

[dilettante]

You'll probably have to use QueryWorkingSet() instead.

[AAraya]

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

[AAraya]

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:

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

[AAraya]

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.

[wqweto]

Here is an impl using QueryWorkingSet API

Option Explicit
 
Private Declare Function QueryWorkingSet Lib "psapi" (ByVal hProcess As Long, pv As Any, ByVal cb As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
 
Private Function GetWorkingSetInfo(ByVal hProcess As Long, lTotal As Long, lPrivate As Long, lShared As Long, lSharable As Long) As Boolean
    Const FLAG_SHARED   As Long = 2 ^ 8                         ' 0x100
    Const MASK_SHARE_COUNT As Long = 2 ^ 7 Or 2 ^ 6 Or 2 ^ 5    ' 0xE0
    Const ERR_BAD_LENGTH As Long = 24
    Dim lIdx            As Long
    Dim laBuffer()      As Long
        
    Call QueryWorkingSet(hProcess, lIdx, 4)
    lIdx = (lIdx + 1023) And -1024
    Do
        ReDim laBuffer(0 To lIdx)
        If QueryWorkingSet(hProcess, laBuffer(0), (UBound(laBuffer) + 1) * 4) <> 0 Then
            Exit Do
        ElseIf Err.LastDllError <> ERR_BAD_LENGTH Then
            Exit Function
        End If
        lIdx = lIdx + 1024
    Loop
    lTotal = laBuffer(0)
    lPrivate = 0
    lShared = 0
    lSharable = 0
    For lIdx = 1 To laBuffer(0)
        If (laBuffer(lIdx) And FLAG_SHARED) = 0 Then
            lPrivate = lPrivate + 1
        Else
            lSharable = lSharable + 1
            '-- count only if shared more than once
            If (laBuffer(lIdx) And MASK_SHARE_COUNT) > 2 ^ 5 Then
                lShared = lShared + 1
            End If
        End If
    Next
    '--- success
    GetWorkingSetInfo = True
End Function
 
Private Sub Form_Load()
    Dim lTotal          As Long
    Dim lPrivate        As Long
    Dim lShared         As Long
    Dim lSharable       As Long
    
    If GetWorkingSetInfo(GetCurrentProcess(), lTotal, lPrivate, lShared, lSharable) Then
        Debug.Print "Working Set: " & Format$((lTotal * 4096) / 1024# / 1024#, "#,#.00 MB")
        Debug.Print "Private WS:  " & Format$((lPrivate * 4096) / 1024# / 1024#, "#,#.00 MB")
        Debug.Print "Shared WS:   " & Format$((lShared * 4096) / 1024# / 1024#, "#,#.00 MB")
        Debug.Print "Sharable WS: " & Format$((lSharable * 4096) / 1024# / 1024#, "#,#.00 MB")
    End If
End Sub

cheers,
</wqw>

[Victor Bravo VI]

Here's an example of using the Performance Counters API to obtain the current process' Private Working Set:

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."

[wqweto]

@Victor Bravo VI: If I have couple of vb6.exe/project1.exe started which one's Private WS gets counted in your implementation?

cheers,
</wqw>

[AAraya]

@wqweto - Thank you.

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!

[Victor Bravo VI]

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:

'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.

[AAraya]

@ Victor Bravo VI - thank you.

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.

[Victor Bravo VI]

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.

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.

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.

[AAraya]

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.

[AAraya]

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:

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

[Victor Bravo VI]

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.

[Elroy]

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.

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

[qvb6]

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".

[Elroy]

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.

[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

[vbwins]

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.

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

[Thierry69]

Good to test.
Just tried it, but I think it should be compiled
I'll compile and test it

[vb6forever]

vbwins:
I tried to implement your example;
Fails with:

ActiveX Component Can't Create Object

30        Set objWmiProcess = CreateObject("winmgmts:\\" & ".")

Always used GetObject for WMI.
But so far searching for the moniker to run SQL after line 30 hasn't yielded much.

Finally found this:
https://wutils.com/wmi/root/cimv2/wi...fproc_process/


Any suggestions?

[AAraya]

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.

[Thierry69]

Thanks, I'll give a look.

[AAraya]

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.

[neotechni]

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