Helper functions to avoid running out of resources

[Eduardo-]

A process has limited resources available.
They can be of several kinds, here we cover GDI objects, RAM and Disk.

If your program must be able to handle, or at least not to crash with huge amounts of data, you'll probably will need to check resources to see if you can safely do something, or decide to use files over variables, or whatever.

The normal GDI object limit is of 10000. Each font, bitmap, pen, brush, metafile, etc consume GDI handles.
The actual value of GDI the handles limit can be found on the registry key
HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Windows\GDIProcessHandleQuota

About the RAM memory, a 32 bits process can use as much as 2 GB.

And the disk, is the free space on the system unit.

Here are the functions:

Private Declare Function GetDiskFreeSpaceEx Lib "kernel32" Alias "GetDiskFreeSpaceExA" (ByVal lpRootPathName As String, lpFreeBytesAvailableToCaller As Currency, lpTotalNumberOfBytes As Currency, lpTotalNumberOfFreeBytes As Currency) As Long

Private Type PROCESS_MEMORY_COUNTERS_EX
    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
    PrivateUsage As Long
End Type

Private Declare Function GetProcessMemoryInfo Lib "PSAPI.DLL" (ByVal hProcess As Long, ppsmemCounters As PROCESS_MEMORY_COUNTERS_EX, ByVal cb As Long) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function GetGuiResources Lib "user32.dll" (ByVal hProcess As Long, ByVal uiFlags As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () 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 CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long


Public Function FolderExists(ByVal nFolderPath As String) As Boolean
    On Error Resume Next

    FolderExists = (GetAttr(nFolderPath) And vbDirectory) = vbDirectory
    Err.Clear
End Function

Public Function GetTempFolder() As String
    Dim lChar As Long
    Static sValue As String
    
    If sValue = "" Then
        sValue = String$(255, 0)
        lChar = GetTempPath(255, sValue)
        sValue = Left$(sValue, lChar)
        If Right$(sValue, 1) <> "\" Then sValue = sValue & "\"
    End If
    GetTempFolder = sValue
End Function

Public Function GetProcessTempPath() As String
    Static sValue As String
    
    If sValue = "" Then
        sValue = GetTempFolder & "BSP_temp" & CStr(GetCurrentProcessId)
        If Right$(sValue, 1) <> "\" Then sValue = sValue & "\"
        If Not FolderExists(sValue) Then
            MkDir sValue
        End If
    End If
    GetProcessTempPath = sValue
End Function

Public Function GDIResourcesLow() As Boolean
    Static sMaxGDIObjects As Long
    Const GR_GDIOBJECTS = 0
    Const HKEY_LOCAL_MACHINE = &H80000002
    Dim iGDICount As Long
    
    If sMaxGDIObjects = 0 Then
        sMaxGDIObjects = QueryRegValue(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Windows", "GDIProcessHandleQuota")
        If sMaxGDIObjects = 0 Then
            sMaxGDIObjects = 9000
        Else
            sMaxGDIObjects = sMaxGDIObjects - 1000
        End If
        If sMaxGDIObjects < 100 Then sMaxGDIObjects = 100
    End If
    
    iGDICount = GetGuiResources(GetCurrentProcess, GR_GDIOBJECTS)
    GDIResourcesLow = (iGDICount >= sMaxGDIObjects)
End Function

Public Function GDIResourcesCritical() As Boolean
    Static sMaxGDIObjects As Long
    Const GR_GDIOBJECTS = 0
    Const HKEY_LOCAL_MACHINE = &H80000002
    Dim iGDICount As Long
    
    If sMaxGDIObjects = 0 Then
        sMaxGDIObjects = QueryRegValue(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Windows", "GDIProcessHandleQuota")
        If sMaxGDIObjects = 0 Then
            sMaxGDIObjects = 9500
        Else
            sMaxGDIObjects = sMaxGDIObjects - 500
        End If
        If sMaxGDIObjects < 150 Then sMaxGDIObjects = 150
    End If
    
    iGDICount = GetGuiResources(GetCurrentProcess, GR_GDIOBJECTS)
    GDIResourcesCritical = (iGDICount >= sMaxGDIObjects)
End Function

Public Function GetGDIUsedObjectsCount() As Long
    Const GR_GDIOBJECTS = 0
    
    GetGDIUsedObjectsCount = GetGuiResources(GetCurrentProcess, GR_GDIOBJECTS)
End Function

Public Function FreeMemoryAvailableIsLow() As Boolean
    Dim pmc As PROCESS_MEMORY_COUNTERS_EX
    Dim iProcessHandle As Long
    Dim LRet As Long
    Const PROCESS_QUERY_INFORMATION = 1024
    Const PROCESS_VM_READ = 16
    
    iProcessHandle = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, GetCurrentProcessId)
    If iProcessHandle = 0 Then Exit Function
    
    pmc.cb = LenB(pmc)
    LRet = GetProcessMemoryInfo(iProcessHandle, pmc, pmc.cb)
    If LRet = 0 Then Exit Function
    FreeMemoryAvailableIsLow = pmc.WorkingSetSize > 1600000000
    LRet = CloseHandle(iProcessHandle)
End Function

Public Function FreeMemoryAvailableIsCritical() As Boolean
    Dim pmc As PROCESS_MEMORY_COUNTERS_EX
    Dim iProcessHandle As Long
    Dim LRet As Long
    Const PROCESS_QUERY_INFORMATION = 1024
    Const PROCESS_VM_READ = 16
    iProcessHandle = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, GetCurrentProcessId)
    If iProcessHandle = 0 Then Exit Function
    
    pmc.cb = LenB(pmc)
    LRet = GetProcessMemoryInfo(iProcessHandle, pmc, pmc.cb)
    If LRet = 0 Then Exit Function
    FreeMemoryAvailableIsCritical = pmc.WorkingSetSize > 1700000000
    LRet = CloseHandle(iProcessHandle)
End Function

Public Function FreeDiscSpaceIsCritical() As Boolean
    Dim BytesFreeToCalller As Currency, TotalBytes As Currency
    Dim TotalFreeBytes As Currency, TotalBytesUsed As Currency
    
    If GetDiskFreeSpaceEx(GetTempFolder, BytesFreeToCalller, TotalBytes, TotalFreeBytes) Then
        FreeDiscSpaceIsCritical = (CCur(100) * BytesFreeToCalller \ TotalBytes < 1)
    End If
End Function

HTH.

[Flauzer]

Great post and very useful information, thanks

[Argus19]

Eduardo, As I understand it, it only works with the registry of 32-bit operating systems?

[Eduardo-]

Eduardo, As I understand it, it only works with the registry of 32-bit operating systems?

VB6 produces 32bit exes, they run in WOW64 (32 bits emulation) in 64bits Windows, so you need to care about 32bits exes resources. So we are using 32bits code, but Windows 64bits is compatible with it.

And: if it works in your machine (that I guess it is 64 bits, as mine is), then it works on 64bits Windows.

[Argus19]

Apparently, I'm running out of memory when working with the Excel.Workbook object.
I created a module:
https://disk.yandex.ru/d/2E5Jk3ys6dK-wQ
Calling functions at critical points:

Call ComprehensiveLogging

Tomorrow I'll add it to my work program and see the result.