|
-
Mar 2nd, 2020, 12:53 PM
#19
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.
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|