Home » excel » excel – Out of Memory Error – Trying to use Win API to check memory usage in ErrorHandler

excel – Out of Memory Error – Trying to use Win API to check memory usage in ErrorHandler

Posted by: admin April 23, 2020 Leave a comment

Questions:

I have a procedure in Excel VBA that is causing an out of memory error. I’m trying to check memory usage as part of my ErrorHandler as well as take a snapshot of how far along execution has reached when the error is encountered.

I’ve found the following code that calls the Win API and provides the ‘Working Set Size’ memory but I also would like to check the Commit Size. Does anyone know what syntax I should use for the Commit Size?

I assume I need to change .WorkingSetSize with something else but I can’t find a reference and random tests with things like ‘CommitSize’ don’t work.

Thanks in advance.

Declare Function GetCurrentProcessId Lib "kernel32" () As Long

Function GetWorkingSetSize()
Dim objSWbemServices As Object

' Returns the current Excel.Application
' memory usage in MB

Set objSWbemServices = GetObject("winmgmts:")
GetWorkingSetSize = objSWbemServices.Get( _
  "Win32_Process.Handle='" & _
  GetCurrentProcessId & "'").WorkingSetSize / 1024

Set objSWbemServices = Nothing

End Function
How to&Answers:

Try this:

Function GetPctCommittedBytes()

Dim colItems As Variant
Dim objItem As Variant

Set colItems = GetObject("WinMgmts:root/cimv2").ExecQuery("Select * FROM Win32_PerfFormattedData_PerfOS_Memory ")

For Each objItem In colItems
    Debug.Print objItem.PercentCommittedBytesInUse
    Debug.Print objItem.CommittedBytes
Next

GetPctCommittedBytes = objItem.CommittedBytes

End Function

H/T to THIS which pointed me in the right direction. I had to use the object browser to review the available properties for objItem:

enter image description here

Answer:

To find out how much memory is available to VBA copy/paste the code below and call availableMemoryInMB()

Function allocateMB(intNumMB As Integer) As Boolean
    On Error Resume Next
    Dim a As Variant
    ReDim a(intNumMB, 256, 256) As Variant 'intNumMB x 256 x 256 x 16 bytes = intNumMB MB
    allocateMB = (Err.Number = 0)
    Err.Clear
    Erase a
End Function

Function availableMemoryInMB() As Integer
    Dim intLow As Integer, intHigh As Integer, intTest As Integer
    intTest = 1: intHigh = 0
    Do
        If allocateMB(intTest) Then
            intLow = intTest
            If intHigh = 0 Then
                intTest = intTest * 2
            Else
                intTest = (intLow + intHigh) / 2
            End If
        Else
            intHigh = intTest
            intTest = (intLow + intHigh) / 2
        End If
    Loop Until intHigh - intLow <= 1 And intHigh > 0
    availableMemoryInMB = intLow
End Function

Execution of the code takes 2-20 seconds.