GFSaveMemory/GFSaveMemorymod.bas
Attribute VB_Name = "GFSaveMemorymod"
Option Explicit
'(c)2001 by Louis. Use this module to find nasty memory leaks in programs.
'
'NOTE: this module 'copies' API functions that create something that must
'be deleted manually.
'All functions provided by the GFSaveMemorymod have the same
'parameters as the API functions, only the name has the prefix 'GFSM_'.
'For some subs/functions an extended version is available that can also
'receive a text for a detailed object description.
'When the target project is unloaded it should call GFSM_Terminate,
'which will display objects that were not removed.
'
Const GFSMEnabledFlag As Boolean = True 'may be disabled for compiling
'
Private Type GFSMObjectStruct
ObjectwParam As Long
ObjectlParam As Long
ObjectSource As String 'general API classification name (hDC, hWnd, etc.)
ObjectDescription As String
End Type
Dim GFSMObjectStructNumber As Integer
Dim GFSMObjectStructArray() As GFSMObjectStruct
'
'API FUNCTIONS SUPPORTED BY GFSM:
'
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
'
Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As POINTAPI, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
'
'CreatePolygonRgn
Private Type POINTAPI
X As Long
Y As Long
End Type
'
'END OF API FUNCTIONS SUPPORTED BY GFSM
'
'***INTERFACE***
'NOTE: the following functions should be called by the target project instead
'of the original API functions.
Public Function GFSM_CreateCompatibleDC(ByVal hDC As Long) As Long
'On Error Resume Next
Dim Temp As Long
Temp = CreateCompatibleDC(hDC)
Call GFSM_AddObject(Temp, 0, "hDC", "")
GFSM_CreateCompatibleDC = Temp
End Function
Public Function GFSM_DeleteDC(ByVal hDC As Long) As Long
'On Error Resume Next
'
'IMPORTANT: call GFSM_DeleteObject(hdc) before deleting the DC itself
'as any object could have been selected into the DC (causes memory leaks)!
'
Call GFSM_RemoveObject(hDC, 0, "hDC")
GFSM_DeleteDC = DeleteDC(hDC)
End Function
Public Function GFSM_CreatePolygonRgn(ByRef lpPoint() As POINTAPI, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
'on error resume next
Dim Temp As Long
Temp = CreatePolygonRgn(lpPoint(0), nCount, nPolyFillMode)
Call GFSM_AddObject(Temp, 0, "hObject", "")
GFSM_CreatePolygonRgn = Temp
End Function
Public Function GFSM_CreateRectRgn(ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
'on error resume next
Dim Temp As Long
Temp = CreateRectRgn(X1, Y1, X2, Y2)
Call GFSM_AddObject(Temp, 0, "hObject", "")
GFSM_CreateRectRgn = Temp
End Function
Public Function GFSM_DeleteObject(ByVal hObject As Long) As Long
'on error resume next
Call GFSM_RemoveObject(hObject, 0, "hObject")
GFSM_DeleteObject = DeleteObject(hObject)
End Function
'***END OF INTERFACE
'**************************************GFSM SYSTEM**************************************
Private Sub GFSM_AddObject(ByVal wParam As Long, ByVal lParam As Long, ByVal Source As String, ByVal Description As String)
'On Error Resume Next 'the source should be a general description, e.g. 'hDC' or 'hObject' or 'TreeViewItemHandle'
If Not (GFSMObjectStructNumber = 32766) Then 'verify
GFSMObjectStructNumber = GFSMObjectStructNumber + 1
ReDim Preserve GFSMObjectStructArray(1 To GFSMObjectStructNumber) As GFSMObjectStruct
GFSMObjectStructArray(GFSMObjectStructNumber).ObjectwParam = wParam
GFSMObjectStructArray(GFSMObjectStructNumber).ObjectlParam = lParam
GFSMObjectStructArray(GFSMObjectStructNumber).ObjectSource = Source
GFSMObjectStructArray(GFSMObjectStructNumber).ObjectDescription = Description
Else
MsgBox "internal error in GFSM_AddObject(): overflow !", vbOKOnly + vbExclamation
Exit Sub 'error
End If
End Sub
Private Sub GFSM_RemoveObject(ByVal wParam As Long, ByVal lParam As Long, ByVal Source As String)
'On Error Resume Next 'an object is identified by its w‑ and lParam and its source
Dim StructIndex As Integer 'index of object to remove
Dim StructLoop As Integer
'begin
StructIndex = 0
For StructLoop = 1 To GFSMObjectStructNumber
If GFSMObjectStructArray(StructLoop).ObjectwParam = wParam Then
If GFSMObjectStructArray(StructLoop).ObjectlParam = lParam Then
If GFSMObjectStructArray(StructLoop).ObjectSource = Source Then
StructIndex = StructLoop
Exit For
End If
End If
End If
Next StructLoop
If Not (StructIndex = 0) Then
For StructLoop = StructIndex To GFSMObjectStructNumber
If Not (StructLoop = GFSMObjectStructNumber) Then
GFSMObjectStructArray(StructLoop) = GFSMObjectStructArray(StructLoop + 1)
Else
GFSMObjectStructNumber = GFSMObjectStructNumber ‑ 1
StructLoop = GFSMObjectStructNumber 'not used anymore
If StructLoop < 1 Then StructLoop = 1
ReDim Preserve GFSMObjectStructArray(1 To StructLoop) As GFSMObjectStruct
Exit For
End If
Next StructLoop
Else
'Debug.Print "GFSM: multiple remove"
End If
End Sub
Private Sub GFSMObjectToDebug(ByVal StructIndex As Integer)
'On Error Resume Next
If Not ((StructIndex < 1) Or (StructIndex > GFSMObjectStructNumber)) Then 'verify
Debug.Print "GFSM: error object #" + LTrim$(Str$(StructIndex))
Debug.Print "wParam: " + LTrim$(Str$(GFSMObjectStructArray(StructIndex).ObjectwParam))
Debug.Print "lParam: " + LTrim$(Str$(GFSMObjectStructArray(StructIndex).ObjectlParam))
Debug.Print "Source: " + GFSMObjectStructArray(StructIndex).ObjectSource
Debug.Print "Description: " + GFSMObjectStructArray(StructIndex).ObjectDescription
Else
MsgBox "internal error in GFSMObjectToDebug(): passed value invalid !", vbOKOnly + vbExclamation
End If
End Sub
Public Sub GFSM_Reset()
'On Error Resume Next 'call to begin another checking 'pass'
GFSMObjectStructNumber = 0 'reset
ReDim GFSMObjectStructArray(1 To 1) As GFSMObjectStruct
End Sub
Public Sub GFSM_Terminate()
'On Error Resume Next
Dim StructLoop As Integer
'begin
If Not (GFSMObjectStructNumber = 0) Then
MsgBox "STOP !" + Chr$(10) + Chr$(10) + "The GFSM system detected a memory leak created by " + LTrim$(Str$(GFSMObjectStructNumber)) + " object(s) that were not removed from memory. Watch debug window for description and additional data related to these objects.", vbOKOnly + vbCritical, "GFSaveMemory"
For StructLoop = 1 To GFSMObjectStructNumber
Call GFSMObjectToDebug(StructLoop)
Next StructLoop
Stop
End If
Call GFSM_Reset 'reset
End Sub
'**********************************END OF GFSM SYSTEM***********************************
[END OF FILE]