Solved

Memory leak...

Posted on 2001-06-07
29
668 Views
Last Modified: 2007-11-27
Hey! I wrote a small DLL to make using the GID functions a little easier, however I ran into a problem. When using the DLL to write a small clock app that refreshes its display every 100 milliseconds or so, I eventually run out of memory... I don't see the problem. Any ideas?

Here's some of the code I'm using; it's not all of it however. The following sub is how I create a DC.

******

Private Sub CreateDC()
 
  If (Not inthDC = 0) Then Call Destroy
  inthDC = gdiCreateCompatibleDC(DesktopDC)
 
  Call CreatePen
  Call CreateFont
 
End Sub

******

There are also CreateBMP and CreateFont, however they follow the same pattern as this sub:

******

Private Sub CreatePen()
 
  Dim NewPen As Long, OldPen As Long
 
  If (Not inthPen = 0) Then
    Call gdiSelectObject(inthDC, intOldhPen)
    Call gdiDeleteObject(inthPen)
    inthPen = 0
  End If
 
  If (Not inthDC = 0) Then
   
    'Create a new pen
    NewPen = gdiCreatePen(intLineStyle, intLineWidth, intForeColor)
   
    If (Not NewPen = 0) Then
      intOldhPen = gdiSelectObject(inthDC, NewPen)
      inthPen = NewPen
    End If
   
  End If
 
End Sub

******

This is my clean up sub...

******

Public Sub Destroy()
 
  'Destroy all objects
 
  If (Not inthFont = 0) Then
    Call gdiSelectObject(inthDC, intOldhFont)
    Call gdiDeleteObject(inthFont)
    inthFont = 0
  End If
 
  If (Not inthPen = 0) Then
    Call gdiSelectObject(inthDC, intOldhPen)
    Call gdiDeleteObject(inthPen)
    inthPen = 0
  End If

  If (Not inthBMP = 0) Then
    Call gdiSelectObject(inthDC, intOldhBMP)
    Call gdiDeleteObject(inthBMP)
    inthBMP = 0
  End If
 
  'Destroy the DC
  If (Not inthDC = 0) Then
    Call gdiDeleteDC(inthDC)
    inthDC = 0
  End If
 
End Sub

******

Can you see anything right off that might be a problem?
0
Comment
Question by:aminerd
  • 14
  • 6
  • 4
  • +5
29 Comments
 
LVL 1

Expert Comment

by:tommy_boy
ID: 6166491
Hmmm.... not 100% sure... but for good programming standards.. destroy all references to objects in the class terminate.  Also collections of objects can be a problem (i see you did not post all your code).  Check if you keep any running collections of objects - these have to be set to nothing individually on termination of the class or they may cause a memory leek.

How fast are you losing memory?
0
 
LVL 8

Expert Comment

by:glass_cookie
ID: 6166759
Hi!

Is it possible that for this line:

- If (Not inthDC = 0) Then Call Destroy

inthDC is always 0 and the functions/sbs are forever called and never destroyed?

You may want to put a message box before this line to show the value of inthDC to see if it's always 0 or not.  Maybe that's the problem.

By the way, do make sure that the variable inthDC is a public or global variable or else it will always be 0 at the start of the function or sub.

That's it!

glass cookie : )
0
 
LVL 1

Expert Comment

by:morgan_peat
ID: 6167047
How are you getting your Desktop DC?
Are you using NULL or GetDesktopWindow()?
That would be the most obvious thing.
Other than that, are all your API parameters declared ByVal that need to be?
0
 
LVL 5

Author Comment

by:aminerd
ID: 6167901
morgan_peat,

Most of the API declarations came straight from the API utility or from www.vbapi.com.

This is how I'm getting my DesktopDC:

Public Property Get DesktopDC() As Long
 
  DesktopDC = gdiGetDC(gdiGetDesktopWindow)
 
End Property
0
 
LVL 4

Expert Comment

by:PBuck
ID: 6167920
I had a dll I had built that performed a folder status update - it too would eventually run out of memory.  Drove me wild for a while until I realized that I had a recursive procedure call.

I thought it was clearing the full procedure before calling itself - but nadda.  So have a good look at any procedure calls within procedure calls.

Hope this helps!
0
 
LVL 5

Author Comment

by:aminerd
ID: 6167924
glass cookie,

I know that inthDC is NOT zero because none of the other functions would run. For example:

Public Sub Line(x1 As Long, y1 As Long, x2 As Long, y2 As Long)
 
  Dim Pt As POINT
 
  If (Not inthDC = 0) And (Not inthPen = 0) Then
   
    'Draw the line
    Call gdiMoveToEx(inthDC, x1, y1, Pt)
    Call gdiLineTo(inthDC, x2, y2)
   
  End If
 
End Sub

And I've been able to draw a line before.

Andrew
0
 
LVL 5

Author Comment

by:aminerd
ID: 6167940
Oops! I think I may have found it. Inside my RectFill() sub I'm creating a brush, but not selecting the old one before destroying it. As I've found before, the brush does NOT get destroyed... So, we'll check that out.

Andrew
0
 
LVL 2

Expert Comment

by:WalterM
ID: 6167963
Assert!

Since you set all handle variables to zero immediately after releasing them, you should be able to find the leak by asserting for non-zero handles in the Class_Terminate event(s), e.g. use statements like

   Debug.Assert (inthDC = 0)
   Debug.Assert (inthBMP = 0)

etc.

Also, you could assert the return value of the gdiDeleteObjects calls to see if they succeed; MSDN sayz:

"If the function succeeds, the return value is nonzero.
If the specified handle is not valid or is currently selected into a DC, the return value is zero."

So try something like

   Dim lResult As Long

   If (Not inthDC = 0) Then
      lResult = gdiDeleteDC(inthDC)
      Debug.Assert (lResult <> 0)
      inthDC = 0
   End If

This should warn you in case you made a mistake, for example somewhere forgot or failed to select to old handle back into the DC.

Generally, I always assert GDI calls, as it is so very easy to introduce a memory leak. They aren't compiled into the executable anyway, so they never hurt.

Good hunting!

Michel
0
 
LVL 1

Expert Comment

by:morgan_peat
ID: 6167967
Ahhh, that must be it then.
The code you put up did select back the brushes before deleting them.

What I was thinking (and this still may be a problem) is that you should call ReleaseDC on your desktop DC once you have finished with it.
0
 
LVL 5

Author Comment

by:aminerd
ID: 6167976
Nope. Doesn't appear to be the problem (since I never select the brush, it just gets passed into the FillRect API call), however, I could be wrong. Might as well post it.

Public Sub RectFill(x As Long, y As Long, w As Long, h As Long, FillColor As Long)
 
  Dim FaceRect As Rect, Brush As Long
  Dim intColor As Long
 
  Call oleTranslateColor(FillColor, 0, intColor)
 
  If (Not inthDC = 0) Then
   
    'Create the brush
    Brush = gdiCreateSolidBrush(intColor)
   
    If Not Brush = -1 Then
     
      FaceRect.Left = x
      FaceRect.Top = y
      FaceRect.Right = x + w
      FaceRect.Bottom = y + h
     
      Call gdiFillRect(inthDC, FaceRect, Brush)
     
      'Delete the brush
      Call gdiDeleteObject(Brush)
     
    End If
   
  End If
 
End Sub
0
 
LVL 1

Expert Comment

by:morgan_peat
ID: 6167992
Learn a new thing every day....
I've never used OLETranslateColor - I just pass in a Long and use that.
It seems to work OK - is there any reason why you call it?
0
 
LVL 5

Author Comment

by:aminerd
ID: 6168011
morgan peat,

Yes, there is. If you pass in a constant like vb3DLight the API functions can't use it. However, OLETranslateColor turns it into a value they WILL use. Really handy.

Andrew
0
 
LVL 5

Author Comment

by:aminerd
ID: 6168039
Hmmm... I added some Assert statements, per WalterM's suggestion, and it passes through those fine. The result is a 1 for every Delete statement. Hmmm...

Andrew
0
 
LVL 1

Expert Comment

by:morgan_peat
ID: 6168068
Tried the ReleaseDC on the desktop DC?
Otherwise (shot in the dark - I'm doing a few of those today) try creating a ridiculously huge bitmap (1000x1000) and see if your memory leak gets bigger.  At least you will be able to rule that out/in.
0
Find Ransomware Secrets With All-Source Analysis

Ransomware has become a major concern for organizations; its prevalence has grown due to past successes achieved by threat actors. While each ransomware variant is different, we’ve seen some common tactics and trends used among the authors of the malware.

 
LVL 5

Author Comment

by:aminerd
ID: 6168096
Morgan peat,

I haven't tried that yet. However, I switched it to:

inthDC = gdiCreateCompatibleDC(0)

And everything appears to be working still. However, my CreateCompatibleBitmap call uses the DesktopDC:

NewBMP = gdiCreateCompatibleBitmap(DesktopDC, intWidth, intHeight)

It will be a little bit before I can test the memory leak again. I'll let you know the outcome when I do though.

Andrew
0
 
LVL 5

Expert Comment

by:gwgaw
ID: 6168798
Are you creating any palettes that you're not deleting?
0
 
LVL 5

Author Comment

by:aminerd
ID: 6169135
gwgaw,

Nope, not palettes.

Andrew
0
 
LVL 5

Author Comment

by:aminerd
ID: 6169188
Well, I've done some testing with it. Everything appears to get deleted fine when using either:

CreateCompatibleDC(DesktopDC)

-or-

CreateCompatibleDC(0)

I'm going to let the test run for a little while and see if I eventually run out of memory.
0
 
LVL 14

Expert Comment

by:Matti
ID: 6173511
Hi!

Replace:

Call gdiSelectObject(inthDC, intOldhFont)

As

Dim x&

x = gdiSelectObject(inthDC, intOldhFont)

Now it will wait for the return and does not execute more untill return or (error return).

And similary in whole program, consider making those sub's as functions and make then also return.


Matti
0
 
LVL 5

Author Comment

by:aminerd
ID: 6173766
Matti,

I'll try that out.. Thanks!

Andrew
0
 
LVL 2

Expert Comment

by:WalterM
ID: 6177110
Here's another possibility.

What version and service pack of Visual Basic are you using? Through time, Microsoft has fixed quite some memory leaks that were introduced into either VB itself or some of the ActiveX controls that come with it, as can be read in quite a few knowledge base articles. Just try a search on the keywords "KBVB* Memory Leak" and you'll see what I mean.

So you might leak resources not directly from you own GDI code but from the use of some buggy VB control, which would explain why all assertions on your own code are satisfied. If this is the case, then running SP5 might just fix the problem.

Also, I would certainly recommend trying Morgan Peats tip of using excessively sized bitmaps when debugging, as this will unveil any memory leaks more quickly. That way, you will also be able to locate any leaks caused by buggy ActiveX controls.

Michel
0
 
LVL 5

Author Comment

by:aminerd
ID: 6178291
Well, the leak seems to be slowly disappearing, though it still exists. It takes about 10-15 minutes before Windows reports that I'm running out of memory (when using a clock that refreshes every 100 milliseconds). That's about 6,000 times.

I'm now trying the clock with a bitmap that's 1024x768 (per Morgan Peat's suggestion). However, I don't appear to be running out of memory any faster; it took 18 minutes this time.
0
 
LVL 1

Expert Comment

by:morgan_peat
ID: 6178370
If it's not the BMP, then there is clearly some small thing that is causing a minor leak.
That can only be (surely?) a DC or brush that is not being cleaned up properly.

Want to put all the code up?
0
 
LVL 5

Author Comment

by:aminerd
ID: 6178519
Here it is...

**************************************

Option Explicit

Private inthDC As Long
Private inthBMP As Long
Private inthFont As Long
Private inthPen As Long

Private intOldhBMP As Long
Private intOldhFont As Long
Private intOldhPen As Long

Private intLineStyle As PenStyles
Private intLineWidth As Long
Private intHeight As Long
Private intWidth As Long
Private intBackColor As Long
Private intForeColor As Long
Private objFont As Font

Private Declare Function gdiCreateCompatibleDC Lib "gdi32.dll" Alias "CreateCompatibleDC" (ByVal hDC As Long) As Long
Private Declare Function gdiGetDeviceCaps Lib "gdi32" Alias "GetDeviceCaps" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function gdiDeleteDC Lib "gdi32.dll" Alias "DeleteDC" (ByVal hDC As Long) As Long
Private Declare Function gdiCreateCompatibleBitmap Lib "gdi32.dll" Alias "CreateCompatibleBitmap" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function gdiCreateFont Lib "gdi32" Alias "CreateFontA" (ByVal h As Long, ByVal w As Long, ByVal E As Long, ByVal O As Long, ByVal w As Long, ByVal i As Long, ByVal u As Long, ByVal S As Long, ByVal c As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, ByVal f As String) As Long
Private Declare Function gdiCreateSolidBrush Lib "gdi32.dll" Alias "CreateSolidBrush" (ByVal crColor As Long) As Long
Private Declare Function gdiCreatePen Lib "gdi32.dll" Alias "CreatePen" (ByVal nPenStyle As PenStyles, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function gdiSelectObject Lib "gdi32.dll" Alias "SelectObject" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function gdiDeleteObject Lib "gdi32.dll" Alias "DeleteObject" (ByVal hObject As Long) As Long
Private Declare Function gdiMoveToEx Lib "gdi32.dll" Alias "MoveToEx" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, lpPoint As POINT) As Long
Private Declare Function gdiLineTo Lib "gdi32.dll" Alias "LineTo" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function gdiDrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As Rect, ByVal wFormat As TextFormats) As Long
Private Declare Function gdiRectangle Lib "gdi32" Alias "Rectangle" (ByVal hDC As Long, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As Long
Private Declare Function gdiFillRect Lib "user32.dll" Alias "FillRect" (ByVal hDC As Long, lpRect As Rect, ByVal hBrush As Long) As Long
Private Declare Function gdiDrawFocusRect Lib "user32.dll" Alias "DrawFocusRect" (ByVal hDC As Long, lpRect As Rect) As Long
Private Declare Function gdiExtFloodFill Lib "gdi32.dll" Alias "ExtFloodFill" (ByVal hDC As Long, ByVal nXStart As Long, ByVal nYStart As Long, ByVal crColor As Long, ByVal fuFillType As Long) As Long
Private Declare Function gdiEllipse Lib "gdi32" Alias "Ellipse" (ByVal hDC As Long, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As Long
Private Declare Function gdiSetTextColor Lib "gdi32" Alias "SetTextColor" (ByVal hDC As Long, ByVal crColor As Long) As Long
Private Declare Function gdiSetBkColor Lib "gdi32.dll" Alias "SetBkColor" (ByVal hDC As Long, ByVal crColor As Long) As Long
Private Declare Function gdiSetBkMode Lib "gdi32" Alias "SetBkMode" (ByVal hDC As Long, ByVal nBkMode As cBackModes) As Long
Private Declare Function gdiBitBlt Lib "gdi32.dll" Alias "BitBlt" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As cBitBltOps) As Long
Private Declare Function gdiStretchBlt Lib "gdi32" Alias "StretchBlt" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function gdiGetDesktopWindow Lib "user32" Alias "GetDesktopWindow" () As Long
Private Declare Function gdiGetDC Lib "user32" Alias "GetDC" (ByVal hWnd As Long) As Long
Private Declare Function oleTranslateColor Lib "olepro32.dll" Alias "OleTranslateColor" (ByVal OLE_COLOR As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
Private Declare Function oleCreatePictureIndirect Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (lpPictDesc As PICT_DESC, riid As Guid, ByVal fPictureOwnsHandle As Long, ipic As IPicture) As Long
Private Declare Function MulDiv Lib "kernel32.dll" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long

Private Type Rect
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type

Private Type POINT
  x As Long
  y As Long
End Type

Private Type PICT_DESC
  cbSizeofStruct As Long
  picType As Long
  hImage As Long
  xExt As Long
  yExt As Long
End Type

Private Type Guid
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(0 To 7) As Byte
End Type

Public Enum TextFormats
  tfTop = &H0
  tfLeft = &H0
  tfCenter = &H1
  tfRight = &H2
  tfVCenter = &H4
  tfBottom = &H8
  tfWordBreak = &H10
  tfSingleLine = &H20
  tfExpandTabs = &H40
  tfTabStop = &H80
  tfNoClip = &H100
  tfExternalLeading = &H200
  tfCalcRect = &H400
  tfNoPrefix = &H800
  tfInternal = &H1000
  tfEditControl = &H2000
  tfPathEllipsis = &H4000
  tfEndEllipsis = &H8000
  tfModifyString = &H10000
  tfRTLReading = &H20000
  tfWordEllipsis = &H40000
End Enum

Private Enum cBitBltOps
  NOTSRCCOPY = &H330008
  SRCCOPY = &HCC0020
  SRCAND = &H8800C6
  SRCPAINT = &HEE0086
End Enum

Private Enum cBackModes
  bkSolid = 0
  bkTransparent = 1
End Enum

Public Enum PenStyles
  psSolid = 0
  psDash = 1
  psDot = 2
  psDashDot = 3
  psDashDotDot = 4
  psInsideFrame = 6
  psAlternate = 8
End Enum

Private Enum FontWeights
  fwBold = 700
  fwNormal = 400
End Enum

'*
'* Constants for converting between scale modes
'*
Private Const TwipsPerPoint = 20
Private Const TwipsPerCharacterX = 120
Private Const TwipsPerCharacterY = 250
Private Const TwipsPerInch = 1440
Private Const TwipsPerCentimeter = 567
Private Const TwipsPerMillimeter = 5.67
Private Const TwipsPerHimetric = 0.567

Private Const DEFAULT_CHARSET = 1
Private Const OUT_DEFAULT_PRECIS = 0
Private Const CLIP_DEFAULT_PRECIS = 0
Private Const PROOF_QUALITY = 2
Private Const DEFAULT_PITCH = 0
Private Const FF_DONTCARE = 0

Private Const LOGPIXELSY = 90

Public Property Let BackColor(nBackColor As Long)
 
  intBackColor = nBackColor
 
End Property

Public Property Get BackColor() As Long
 
  BackColor = intBackColor
 
End Property

Public Sub Clear()
 
  If (Not inthDC = 0) Then
    Call RectFill(0, 0, intWidth, intHeight, intBackColor)
  End If
 
End Sub

Public Sub Copy()
 
  'Copy to the clipboard
  Call Clipboard.SetData(Picture, vbCFBitmap)
 
End Sub

Public Sub CopyTo(DestDC As Long, x As Long, y As Long)
 
  Dim intResult As Long
 
  If (Not inthDC = 0) Then
   
    intResult = gdiBitBlt(DestDC, x, y, intWidth, intHeight, inthDC, 0, 0, SRCCOPY)
   
  End If
 
End Sub

Public Sub Create(Width As Long, Height As Long)
 
  intWidth = Width
  intHeight = Height
 
  Call CreateDC
  Call CreateBMP
 
End Sub

Private Sub CreateBMP()
 
  Dim NewBMP As Long
  Dim intResult As Long
 
  If (Not inthBMP = 0) Then
    intResult = gdiSelectObject(inthDC, intOldhBMP)
    intResult = gdiDeleteObject(inthBMP)
    If (intResult <> 0) Then inthBMP = 0 Else Stop
  End If
 
  If (Not inthDC = 0) Then
   
    NewBMP = gdiCreateCompatibleBitmap(DesktopDC, intWidth, intHeight)
   
    If (Not NewBMP = 0) Then
     
      intOldhBMP = gdiSelectObject(inthDC, NewBMP)
      inthBMP = NewBMP
     
      Call RectFill(0, 0, intWidth, intHeight, intBackColor)
     
    End If
   
  End If
 
End Sub

Private Sub CreateDC()
 
  If (Not inthDC = 0) Then Call Destroy
  inthDC = gdiCreateCompatibleDC(0)
 
  Call CreatePen
  Call CreateFont
 
End Sub

Private Sub CreateFont()
 
  Dim NewFont As Long
  Dim FontWeight As FontWeights, h As Long
  Dim intResult As Long
 
  If (Not inthFont = 0) Then
    intResult = gdiSelectObject(inthDC, intOldhFont)
    intResult = gdiDeleteObject(inthFont)
    If (intResult <> 0) Then inthFont = 0 Else Stop
  End If
 
  If (Not inthDC = 0) And (Not objFont Is Nothing) Then
   
    h = -MulDiv(Font.Size, gdiGetDeviceCaps(inthDC, LOGPIXELSY), 72)
    If Font.Bold Then FontWeight = fwBold Else FontWeight = fwNormal
   
    NewFont = gdiCreateFont(h, 0, 0, 0, FontWeight, Font.Italic, Font.Underline, Font.Strikethrough, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, PROOF_QUALITY, DEFAULT_PITCH, Font.Name)
   
    If (Not NewFont = 0) Then
     
      intOldhFont = gdiSelectObject(inthDC, NewFont)
      inthFont = NewFont
     
    End If
   
  End If
 
End Sub

Private Sub CreatePen()
 
  Dim NewPen As Long
  Dim intResult As Long
 
  If (Not inthPen = 0) Then
    intResult = gdiSelectObject(inthDC, intOldhPen)
    intResult = gdiDeleteObject(inthPen)
    If (intResult <> 0) Then inthPen = 0 Else Stop
  End If
 
  If (Not inthDC = 0) Then
   
    'Create a new pen
    NewPen = gdiCreatePen(intLineStyle, intLineWidth, intForeColor)
   
    If (Not NewPen = 0) Then
     
      intOldhPen = gdiSelectObject(inthDC, NewPen)
      inthPen = NewPen
     
    End If
   
  End If
 
End Sub

Public Sub Destroy()
 
  Dim intResult As Long
 
  'Destroy all objects
 
  If (Not inthBMP = 0) Then
   
    intResult = gdiSelectObject(inthDC, intOldhBMP)
    intResult = gdiDeleteObject(inthBMP)
    If (intResult <> 0) Then inthBMP = 0 Else Stop
   
  End If
 
  If (Not inthFont = 0) Then
   
    intResult = gdiSelectObject(inthDC, intOldhFont)
    intResult = gdiDeleteObject(inthFont)
    If (intResult <> 0) Then inthFont = 0 Else Stop
   
  End If
 
  If (Not inthPen = 0) Then
   
    intResult = gdiSelectObject(inthDC, intOldhPen)
    intResult = gdiDeleteObject(inthPen)
    If (intResult <> 0) Then inthPen = 0 Else Stop
   
  End If
 
  'Destroy the DC
  If (Not inthDC = 0) Then
   
    intResult = gdiDeleteDC(inthDC)
    If (intResult <> 0) Then inthDC = 0 Else Stop
   
  End If
 
End Sub

Public Sub Ellipse(x As Long, y As Long, w As Long, h As Long)
 
  Dim Pen As Long, OldObject As Long
  Dim intResult As Long
 
  If (Not inthDC = 0) And (Not inthPen = 0) Then
   
    'Draw the ellipse
    intResult = gdiEllipse(inthDC, x, y, (x + w), (y + h))
   
  End If
 
End Sub

Public Sub CopyPicture(Source As StdPicture, x As Long, y As Long)
 
  Dim h As Long, w As Long
  Dim TempDC As Long, OldObject As Long
  Dim intResult As Long
 
  If (Not inthDC = 0) Then
   
    'Find the width and height of the source image
    w = CLng(Convert(Source.Width, vbHimetric, vbPixels))
    h = CLng(Convert(Source.Height, vbHimetric, vbPixels))
   
    'Create a temporary DC and select the source picture
    TempDC = gdiCreateCompatibleDC(inthDC)
    OldObject = gdiSelectObject(TempDC, Source.Handle)
   
    'Copy the source to the sprite DC
    intResult = gdiBitBlt(inthDC, x, y, w, h, TempDC, 0, 0, SRCCOPY)
   
    'Delete the temporary DC
    intResult = gdiSelectObject(TempDC, OldObject)
    intResult = gdiDeleteDC(TempDC)
    If (intResult = 0) Then Stop
   
  End If
 
End Sub

Public Sub FocusRect(x As Long, y As Long, h As Long, w As Long)
 
  Dim typRect As Rect
  Dim intResult As Long
 
  If (Not inthDC = 0) Then
   
    typRect.Left = x
    typRect.Top = y
    typRect.Right = x + w
    typRect.Bottom = y + h
   
    'Draw the focus rectangle
    intResult = gdiDrawFocusRect(inthDC, typRect)
   
  End If
 
End Sub

Public Sub DrawText(x As Long, y As Long, w As Long, h As Long, Text As String, Optional Options As TextFormats)
 
  Dim TextRect As Rect
  Dim intResult As Long
 
  If (Not inthDC = 0) And (Not inthFont = 0) Then
   
    'Set the text color and background mode
    intResult = gdiSetTextColor(inthDC, intForeColor)
    intResult = gdiSetBkMode(inthDC, bkTransparent)
   
    'Position the text
    TextRect.Left = x
    TextRect.Top = y
    TextRect.Right = x + w
    TextRect.Bottom = y + h
   
    'Draw the text
    intResult = gdiDrawText(inthDC, Text, Len(Text), TextRect, Options)
   
  End If
 
End Sub

Public Sub FloodFill(x As Long, y As Long, ByVal Color As Long, ByVal BorderColor As Long)
 
  Dim Brush As Long, OldObject As Long
  Dim intResult As Long
 
  If (Not inthDC = 0) Then
   
    'Translate the colors into something useful
    intResult = oleTranslateColor(Color, 0, Color)
    intResult = oleTranslateColor(BorderColor, 0, BorderColor)
   
    'Create the pen
    Brush = gdiCreateSolidBrush(Color)
   
    If (Not Brush = -1) Then
     
      'We want to use the pen
      OldObject = gdiSelectObject(inthDC, Brush)
     
      'Do the flood fill
      intResult = gdiExtFloodFill(inthDC, x, y, BorderColor, 0)
     
      'Delete the pen
      intResult = gdiSelectObject(inthDC, OldObject)
      intResult = gdiDeleteObject(Brush)
      If (intResult = 0) Then Stop
     
    End If
   
  End If
 
End Sub

Public Property Get DesktopDC() As Long
 
  DesktopDC = gdiGetDC(gdiGetDesktopWindow)
 
End Property

Public Property Set Font(nFont As Font)
 
  Set objFont = nFont
  Call CreateFont
 
End Property

Public Property Get Font() As Font
 
  Set Font = objFont
 
End Property

Public Property Get ForeColor() As Long
 
  ForeColor = intForeColor
 
End Property

Public Property Let ForeColor(nForeColor As Long)
 
  Call oleTranslateColor(nForeColor, 0, intForeColor)
  Call CreatePen
 
End Property

Public Property Get hDC() As Long
 
  hDC = inthDC
 
End Property

Public Property Get hBmp() As Long
 
  hBmp = inthBMP
 
End Property

Public Property Get Height()
 
  Height = intHeight
 
End Property

Public Property Get hFont() As Long
 
  hFont = inthFont
 
End Property
Public Property Get hPen() As Long
 
  hPen = inthPen
 
End Property

Public Property Let LineStyle(nLineStyle As PenStyles)
 
  intLineStyle = nLineStyle
  Call CreatePen
 
End Property

Public Property Get LineStyle() As PenStyles
 
  LineStyle = intLineStyle
 
End Property

Public Property Let LineWidth(nLineWidth As Long)
 
  intLineWidth = nLineWidth
  Call CreatePen
 
End Property

Public Property Get LineWidth() As Long
 
  LineWidth = intLineWidth
 
End Property

Public Property Get Picture() As IPicture
 
  Dim intResult As Long
 
  If (Not inthBMP = 0) Then
   
    Dim objPic As Picture, tPicConv As PICT_DESC, IGuid As Guid
   
    'Fill PictDesc structure with necessary parts:
    With tPicConv
      .cbSizeofStruct = Len(tPicConv)
      .picType = vbPicTypeBitmap
      .hImage = inthBMP
    End With
   
    'Fill in IDispatch Interface ID
    With IGuid
      .Data1 = &H20400
      .Data4(0) = &HC0
      .Data4(7) = &H46
    End With
   
    'Create a picture object:
    intResult = oleCreatePictureIndirect(tPicConv, IGuid, True, objPic)
   
    'Return it:
    Set Picture = objPic
    Set objPic = Nothing
   
  Else
   
    Set Picture = Nothing
   
  End If
 
End Property

Public Sub DrawPic(Source As StdPicture, x As Long, y As Long, h As Long, w As Long)
 
  Dim sh As Long, sw As Long
  Dim TempDC As Long, OldObject As Long
  Dim intResult As Long
 
  If (Not inthDC = 0) Then
   
    'Find the source width and height of the source image
    sw = CLng(Convert(Source.Width, vbHimetric, vbPixels))
    sh = CLng(Convert(Source.Height, vbHimetric, vbPixels))
   
    'Create a temporary DC and select the source picture
    TempDC = gdiCreateCompatibleDC(inthDC)
    OldObject = gdiSelectObject(TempDC, Source.Handle)
   
    'Copy the source to the sprite DC
    intResult = gdiStretchBlt(inthDC, x, y, w, h, TempDC, 0, 0, sw, sh, SRCCOPY)
   
    'Delete the temporary DC
    intResult = gdiSelectObject(TempDC, OldObject)
    intResult = gdiDeleteDC(TempDC)
    If (intResult = 0) Then Stop
   
  End If
 
End Sub

Public Sub RectFill(x As Long, y As Long, w As Long, h As Long, FillColor As Long)
 
  Dim FaceRect As Rect, Brush As Long
  Dim intColor As Long
  Dim intResult As Long
 
  intResult = oleTranslateColor(FillColor, 0, intColor)
 
  If (Not inthDC = 0) Then
   
    'Create the brush
    Brush = gdiCreateSolidBrush(intColor)
   
    If Not Brush = -1 Then
     
      FaceRect.Left = x
      FaceRect.Top = y
      FaceRect.Right = x + w
      FaceRect.Bottom = y + h
     
      intResult = gdiFillRect(inthDC, FaceRect, Brush)
     
      'Delete the brush
      intResult = gdiDeleteObject(Brush)
      If (intResult = 0) Then Stop
     
    End If
   
  End If
 
End Sub

Public Function Convert(Value As Single, FromScale As Integer, ToScale As Integer) As Single
 
  Dim Temp As Single, Conversion As Single
 
  'Temporary variable for conversion
  Temp = Value
 
  'Convert to Twips
  Conversion = Factor(FromScale)
  Temp = (Temp * Conversion)
 
  'Convert to ToScale
  Conversion = (1 / Factor(ToScale))
  Temp = (Temp * Conversion)
 
  'Return value after conversions
  Convert = Temp
 
End Function

Private Function Factor(FromScale As Integer) As Single
 
  Dim Conversion As Single
 
  Select Case FromScale
    Case vbPoints
      Conversion = TwipsPerPoint
    Case vbPixels
      Conversion = Screen.TwipsPerPixelX
    Case vbInches
      Conversion = TwipsPerInch
    Case vbCentimeters
      Conversion = TwipsPerCentimeter
    Case vbMillimeters
      Conversion = TwipsPerMillimeter
    Case vbHimetric
      Conversion = TwipsPerHimetric
    Case vbTwips
      Conversion = 1
  End Select
 
  Factor = Conversion
 
End Function

Public Sub Rectangle(x As Long, y As Long, w As Long, h As Long)
 
  Dim intResult As Long
 
  If (Not inthDC = 0) And (Not inthPen = 0) Then
   
    'Draw the rectangle
    intResult = gdiRectangle(inthDC, x, y, (x + w), (y + h))
   
  End If
 
End Sub

Public Sub Line(x1 As Long, y1 As Long, x2 As Long, y2 As Long)
 
  Dim Pt As POINT
  Dim intResult As Long
 
  If (Not inthDC = 0) And (Not inthPen = 0) Then
   
    'Draw the line
    intResult = gdiMoveToEx(inthDC, x1, y1, Pt)
    intResult = gdiLineTo(inthDC, x2, y2)
   
  End If
 
End Sub

Public Function TextHeight(Str As String) As Single
 
  Dim TextRect As Rect
  Dim intResult As Long
 
  If (Not inthDC = 0) Then
   
    'Calculate the size
    intResult = gdiDrawText(inthDC, Str, Len(Str), TextRect, tfCalcRect)
   
    'Calculate the height and convert to twips
    TextHeight = TextRect.Bottom - TextRect.Top
   
  End If
 
End Function

Public Function TextWidth(Str As String) As Single
 
  Dim TextRect As Rect
  Dim intResult As Long
 
  If (Not inthDC = 0) Then
   
    'Calculate the size
    intResult = gdiDrawText(inthDC, Str, Len(Str), TextRect, tfCalcRect)
   
    'Calculate the height and convert to twips
    TextWidth = TextRect.Right - TextRect.Left
   
  End If
 
End Function

Public Property Get Width()
 
  Width = intWidth
 
End Property
Private Sub Class_Initialize()
 
  intForeColor = vbBlack
  intBackColor = vbWhite
  intLineStyle = psSolid
  intLineWidth = 1
 
End Sub

Private Sub Class_Terminate()
 
  Call Destroy
 
  Debug.Assert (inthBMP = 0)
  Debug.Assert (inthFont = 0)
  Debug.Assert (inthPen = 0)
  Debug.Assert (inthDC = 0)
 
End Sub
0
 
LVL 2

Expert Comment

by:WalterM
ID: 6180298
Seems to me that in the above code, the DesktopDC is never released.

The CreateBMP sub calls the DesktopDC property, which obtains the DC through a call to GetDC. This call needs to be balanced with a call to ReleaseDC in order to free the DC, e.g. in the Destroy method.

Michel
0
 
LVL 1

Accepted Solution

by:
morgan_peat earned 200 total points
ID: 6180463
I quote my earlier posts:

"How are you getting your Desktop DC?
Are you using NULL or GetDesktopWindow()?"

"What I was thinking (and this still may be a problem) is that you should call ReleaseDC on your desktop DC once you have finished with it."


Just ran the code (with a clock-type thing, like you said) and it is indeed ReleaseDC that is the problem.

I changed it as follows:
In Class_Initialize:

    m_hDesktop = gdiGetDesktopWindow
    m_hDCDesktop = gdiGetDC(m_hDesktop)


To store the hDesktop, and the Desktop DC.
In Class_Terminate:

    gdiReleaseDC m_hDesktop, m_hDCDesktop

And changed DesktopDC PropertyGet to:

    DesktopDC = m_hDCDesktop


Ran and looked at PerfMon - totally flat.
0
 
LVL 5

Author Comment

by:aminerd
ID: 6181929
morgan peat,

Well, we could have been done with this one a while ago...
Thanks a bunch!

Andrew
0
 
LVL 2

Expert Comment

by:WalterM
ID: 6182027
*sigh*

onto the next leak-hunt...
0
 
LVL 5

Author Comment

by:aminerd
ID: 6182084
By the way, if anyone wants to download the DLL and perhaps avoid memory problems similar to the one I encountered, you can get it at:

http://andyroo.cjb.net/vb/gdi.dll
0

Featured Post

IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

There are many ways to remove duplicate entries in an SQL or Access database. Most make you temporarily insert an ID field, make a temp table and copy data back and forth, and/or are slow. Here is an easy way in VB6 using ADO to remove duplicate row…
Have you ever wanted to restrict the users input in a textbox to numbers, and while doing that make sure that they can't 'cheat' by pasting in non-numeric text? Of course you can do that with code you write yourself but it's tedious and error-prone …
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…

707 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

16 Experts available now in Live!

Get 1:1 Help Now