Where is the memory leak in this short VBA code?

The simple example code simply reads the pixel color in the top left corner again and again to test the memory leaks with reading the pixel color. Currently it only runs about 1000 times, but you'd need to run it for more iterations for some problems.

The first sign of issue is that after about 310 iterations the status bar in excel stops updating for some reason. If however I get to this many iterations by slowly stepping in the debugger, this doesn't happen. Secondly as long as that code runs, the memory usage of excel is climbing up steadily (although it never reaches very high levels where running out of ram would be an issue). The memory usage stays the same when the macro stops, only restarting excel fixes it.

If the code runs constantly for about 5 and a half minutes, excel freezes completely with things not displaying correctly. There are also graphical errors in the task manager at this point. The memory usage of excel goes from 14.7 MB to 19.1 MB between opening excel and freezing. To achieve this I increased the iterations to 30,000 on my system, but you may need a different amount of iterations in your system.

''''PIXELS
#If VBA7 Then
    Private Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hdc As LongPtr, ByVal x As Long, ByVal y As Long) As Long
    Private Declare PtrSafe Function GetWindowDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
#Else
    Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
    Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
#End If



Sub testcolor()

Dim color As String
Dim Time As Double
Time = Now()


For i = 1 To 1000
color = GetPixelcolor(0, 0)
If i Mod 10 = 0 Then
Application.StatusBar = i & "  " & "  " & Now() - Time & "  " & color
End If
Next


Application.StatusBar = False
End Sub

Function GetPixelcolor(ByVal x As Long, ByVal y As Long)
    Dim iPixelColor As Long
    Dim lDC As Variant
    lDC = GetWindowDC(0)
    
    iPixelColor = GetPixel(lDC, x, y)
    GetPixelcolor = Hex(iPixelColor)

End Function

Open in new window


Other info
I am using Excel 2010 but I found similar issues with other systems running later versions.
The reason I want to read pixels again and again, as in another program I'm automating higly repetitive tasks and pixel changes on the screen is how VBA finds out when the desired part of the other program loaded.
Laszlo BenedekAsked:
Who is Participating?
 
QlemoBatchelor, Developer and EE Topic AdvisorCommented:
You need to release the DC again, that is each GetWindowDC or GetDC needs to be matched with a ReleaseDC for that DC. See https://msdn.microsoft.com/en-us/library/windows/desktop/dd144947(v=vs.85).aspx (GetWindowDC) and https://msdn.microsoft.com/en-us/library/windows/desktop/dd162920(v=vs.85).aspx (ReleaseDC).
1
 
Laszlo BenedekAuthor Commented:
''''PIXEL

    
#If VBA7 Then
    Private Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hdc As LongPtr, ByVal x As Long, ByVal y As Long) As Long
    Private Declare PtrSafe Function GetWindowDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As LongPtr
#Else
    Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
    Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
#End If



Sub testcolor()

Dim color As String
Dim Time As Double
Time = Now()


For i = 1 To 1000
color = GetPixelcolor(0, 0)
If i Mod 10 = 0 Then
DoEvents
Application.StatusBar = i & "  " & "  " & Now() - Time & "  " & color
End If



Next




Application.StatusBar = False
End Sub

Function GetPixelcolor(ByVal x As Long, ByVal y As Long)
    Dim iPixelColor As Long
    Dim lDC As Variant
    lDC = GetWindowDC(0)
    
    iPixelColor = GetPixel(lDC, x, y)
    GetPixelcolor = Hex(iPixelColor)
    

    ReleaseDC 0, lDC
End Function

Open in new window

0
 
Laszlo BenedekAuthor Commented:
Thanks, that solves it, and it was quite a quick reply.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.