内存不足错误 – 尝试使用Win API来检查ErrorHandler中的内存使用情况

我在Excel VBA中有一个导致内存不足错误的过程。 我试图检查内存的使用情况作为我的ErrorHandler的一部分，以及当遇到错误时，执行已达到多远的快照。

我发现下面的代码调用Win API，并提供“工作集大小”的内存，但我也想检查提交大小。 有谁知道什么语法我应该使用提交大小？

我想我需要改变.WorkingSetSize与其他东西，但我找不到一个参考和随机testing像'CommitSize'的东西不起作用。

提前致谢。

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 

Answer 1

尝试这个：

 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这指出我在正确的方向。 我不得不使用对象浏览器来查看objItem的可用属性：

Answer 2

要找出有多less内存可用于VBA复制/粘贴下面的代码，并调用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 

代码的执行需要2-20秒。