Solved

***WARNING*** HARDCORE EXPERTS ONLY - GDI Memory Leak / Run-Time Error 91 on Compiled .EXE

Posted on 2003-11-16
17
3,514 Views
Last Modified: 2012-05-04
Here is a project I have written in response to this question:

http://www.experts-exchange.com/Programming/Programming_Languages/Visual_Basic/Q_20799010.html

Obviously, the points alotted didn't inspire me.  In my opinion, the problem itself isn't that difficult, as it is fairly trivial to write an app of this type for one or two hard coded polygons using the GDI API's.

With this in mind, I wanted to see how difficult it would be write an app that could handle any number of polygons, without having the polygon arrays available as global variables.

I decided the only logical solution was to encapsulate the polygons in a class and store the polygon instances in a collection.  This in itself proved quite challenging as the Polygon API's expect the vertices to be passed in as an array of UDT's.  I'm sure most of you have found that you cannot use a UDT as a return type in a class.  I overcame this problem by instead returning a pointer to my internal array and using the dreaded CopyMemory API to reproduce the array outside the class.

The App initially draws four outlined shapes on the form.  Each time a shape is clicked, it is filled with a different random color.  The whole point of the project was to make the shapes persistent, so be sure to minimize the window or drag another window over the app to verify the it redraws itself correctly.

For a program that doesn't really do anything useful except demonstrate obscure VB parlor tricks, I'm quite happy with the results except for two things:

1) The app has a major memory leak.  To reproduce the leak, run the program and grab the resize handle up by the control box.  Drag vigorously whilst resizing the window and watch your memory fizzle away.  The memory is returned to the system when I close the Visual Basic IDE.

2) Despite the leak mentioned above, the app runs fairly well...but only in the IDE.  The compiled EXE gives me a Run-Time Rrror 91 "Object variable or with block variable not set" as soon as I run it.

I am using VB6 on a Win ME machine.

Looking forward to your responses on these two issues,

Idle_Mind

Here is the code for the main form and the class module:

' ************************* Code for Form1  *************************
Option Explicit

Private Type point
    x As Long
    y As Long
End Type

Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As Any, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
Private Declare Function Polygon Lib "gdi32" (ByVal hdc As Long, lpPoint As Any, ByVal nCount As Long) As Long
Private Declare Function FillRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long, ByVal hBrush As Long) As Long
Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function PtInRegion Lib "gdi32" (ByVal hRgn As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function ExtFloodFill Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long, ByVal wFillType As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)

Const FLOODFILLBORDER = 0
Const FLOODFILLSURFACE = 1
Const ALTERNATE = 1
Const WINDING = 2
Const BLACKBRUSH = 4

Private shapes As New Collection
Private regions As New Collection
Private clickedRegions As New Collection
Private points() As point
Private onePoint As point

Private Sub Form_Load()
    Me.ScaleMode = vbPixels
    createPolygons
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Dim rgnString As Variant
    Dim shape As Variant
   
    For Each rgnString In regions
        DeleteObject CLng(rgnString)
    Next rgnString
   
    For Each shape In shapes
        Set shape = Nothing
    Next shape
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim region As Variant
    Dim rgbColor As Long
    Dim hBrush As Long
    Dim mBrush As Long
       
    For Each region In regions
        If PtInRegion(CLng(region), x, y) <> 0 Then
            rgbColor = RGB(Int(Rnd * 255), Int(Rnd * 255), Int(Rnd * 255))
            If Not regionAlreadyClicked(CStr(region)) Then
                hBrush = GetStockObject(BLACKBRUSH)
                SelectObject Me.hdc, hBrush
                FillRgn Me.hdc, CLng(region), hBrush
                DeleteObject hBrush
                clickedRegions.Add CStr(rgbColor), CStr(region)
            End If
            clickedRegions.Remove CStr(region)
            mBrush = CreateSolidBrush(rgbColor)
            SelectObject Me.hdc, mBrush
            ExtFloodFill Me.hdc, x, y, GetPixel(Me.hdc, x, y), FLOODFILLSURFACE
            DeleteObject mBrush
            clickedRegions.Add CStr(rgbColor), CStr(region)
            Exit For
        End If
    Next region
End Sub

Private Sub Form_Resize()
    Form_Paint
End Sub

Private Sub Form_Paint()
    Dim shape As Variant
    Dim region As Variant
    Dim rgbColor As Long
    Dim hBrush As Long
    Dim mBrush As Long
               
    Me.Cls
    For Each shape In shapes
        createPointsArray shape.vertices
        Polygon Me.hdc, points(0), shape.numVertices
    Next shape

    For Each region In regions
        If regionAlreadyClicked(CStr(region)) Then
            hBrush = GetStockObject(BLACKBRUSH)
            SelectObject Me.hdc, hBrush
            FillRgn Me.hdc, CLng(region), hBrush
            DeleteObject hBrush
                     
            rgbColor = CLng(clickedRegions.Item(CStr(region)))
            mBrush = CreateSolidBrush(rgbColor)
            SelectObject Me.hdc, mBrush
            Set shape = shapes.Item(CStr(region))
            createPointsArray shape.vertices
            ExtFloodFill Me.hdc, points(0).x, points(0).y, GetPixel(Me.hdc, points(0).x, points(0).y), FLOODFILLSURFACE
            DeleteObject mBrush
        End If
    Next region
End Sub

Private Sub createPolygons()
    Dim poly1 As New Class1
    Dim hRgn As Long
   
    ' Square in Upper Left
    poly1.addVertex Form1.ScaleWidth / 8, Form1.ScaleHeight / 8
    poly1.addVertex 3 * Form1.ScaleWidth / 8, Form1.ScaleHeight / 8
    poly1.addVertex 3 * Form1.ScaleWidth / 8, 3 * Form1.ScaleHeight / 8
    poly1.addVertex Form1.ScaleWidth / 8, 3 * Form1.ScaleHeight / 8
    poly1.addVertex Form1.ScaleWidth / 8, Form1.ScaleHeight / 8
    createPointsArray poly1.vertices
    hRgn = CreatePolygonRgn(points(0), poly1.numVertices, ALTERNATE)
    shapes.Add poly1, CStr(hRgn)
    regions.Add CStr(hRgn), CStr(hRgn)
   
    ' Triangle in Upper Right
    Set poly1 = New Class1
    poly1.addVertex 6 * Form1.ScaleWidth / 8, Form1.ScaleHeight / 8
    poly1.addVertex 7 * Form1.ScaleWidth / 8, 3 * Form1.ScaleHeight / 8
    poly1.addVertex 5 * Form1.ScaleWidth / 8, 3 * Form1.ScaleHeight / 8
    poly1.addVertex 6 * Form1.ScaleWidth / 8, Form1.ScaleHeight / 8
    createPointsArray poly1.vertices
    hRgn = CreatePolygonRgn(points(0), poly1.numVertices, ALTERNATE)
    shapes.Add poly1, CStr(hRgn)
    regions.Add CStr(hRgn), CStr(hRgn)
   
    ' Diamond in Bottom Left
    Set poly1 = New Class1
    poly1.addVertex Form1.ScaleWidth / 8, 6 * Form1.ScaleHeight / 8
    poly1.addVertex 2 * Form1.ScaleWidth / 8, 5 * Form1.ScaleHeight / 8
    poly1.addVertex 3 * Form1.ScaleWidth / 8, 6 * Form1.ScaleHeight / 8
    poly1.addVertex 2 * Form1.ScaleWidth / 8, 7 * Form1.ScaleHeight / 8
    poly1.addVertex Form1.ScaleWidth / 8, 6 * Form1.ScaleHeight / 8
    createPointsArray poly1.vertices
    hRgn = CreatePolygonRgn(points(0), poly1.numVertices, ALTERNATE)
    shapes.Add poly1, CStr(hRgn)
    regions.Add CStr(hRgn), CStr(hRgn)
   
    ' Odd Thing in Bottom Right
    Set poly1 = New Class1
    poly1.addVertex 5 * Form1.ScaleWidth / 8, 6 * Form1.ScaleHeight / 8
    poly1.addVertex 6 * Form1.ScaleWidth / 8, 5 * Form1.ScaleHeight / 8
    poly1.addVertex 7 * Form1.ScaleWidth / 8, 5 * Form1.ScaleHeight / 8
    poly1.addVertex 7 * Form1.ScaleWidth / 8, 7 * Form1.ScaleHeight / 8
    poly1.addVertex 13 * Form1.ScaleWidth / 16, 12 * Form1.ScaleHeight / 16
    poly1.addVertex 5 * Form1.ScaleWidth / 8, 7 * Form1.ScaleHeight / 8
    poly1.addVertex 5 * Form1.ScaleWidth / 8, 6 * Form1.ScaleHeight / 8
    createPointsArray poly1.vertices
    hRgn = CreatePolygonRgn(points(0), poly1.numVertices, ALTERNATE)
    shapes.Add poly1, CStr(hRgn)
    regions.Add CStr(hRgn), CStr(hRgn)
End Sub

Private Sub createPointsArray(ByVal pointsInformation As String)
    Dim vertexValues As Variant
    vertexValues = Split(pointsInformation, "|")
    ReDim points(CLng(vertexValues(1)))
    CopyMemory ByVal points(0), ByVal CLng(vertexValues(0)), ByVal LenB(onePoint) * CLng(vertexValues(1))
End Sub

Private Function regionAlreadyClicked(ByVal regionToCheck As String) As Boolean
    On Error GoTo notClickedYet
   
    Dim checkRegion As Variant
    regionAlreadyClicked = False
    checkRegion = clickedRegions.Item(regionToCheck)
    regionAlreadyClicked = True

notClickedYet:
End Function


' ************************* Code for Class1  *************************
Option Explicit

Private Type point
    x As Long
    y As Long
End Type

Private points() As point
Private numPoints As Integer

Private Sub Class_Initialize()
    numPoints = 0
End Sub

Public Property Get vertices() As String
    vertices = CStr(VarPtr(points(0))) & "|" & Me.numVertices
End Property

Public Property Get numVertices() As Integer
    numVertices = numPoints
End Property

Public Sub addVertex(x As Long, y As Long)
    Dim newPoint As point
    newPoint.x = x
    newPoint.y = y
    numPoints = numPoints + 1
    ReDim Preserve points(numPoints)
    points(numPoints - 1) = newPoint
End Sub
0
Comment
Question by:Mike Tomlinson
  • 8
  • 7
  • 2
17 Comments
 
LVL 3

Expert Comment

by:NBrownoh
ID: 9757978
well your error is in the CreatePolygons routine at:

hRgn = CreatePolygonRgn(points(0), poly1.numVertices, ALTERNATE)

basically anywhere CreatePolygonRgn was called.

I was able to get arround this by putting all the form decs into a module and making them public.  but even after that it wouldnt do it correctly, never drawing the polygons n stuff.  I wasnt able to duplicate your mem runaway issue.  It actually dropped after shaking the form and resizing it very quickly.
0
 
LVL 85

Author Comment

by:Mike Tomlinson
ID: 9758505
Can you be a little more specific as to what error you believe I am making in my usage of the CreatePolygonRgn() API?

Idle_Mind
0
 
LVL 15

Expert Comment

by:ameba
ID: 9758622
Hi Idle_Mind,
> I'm sure most of you have found that you cannot use a UDT as a return type in a class.

You can. If project is ActiveX Exe or Dll, declare UDT in public class, and you'll be able to return UDT.  If it's Standard Exe, change Public to Friend in your function which returns UDT.


Autoinstancing, i.e. declaring variables "As New" is not good practice - you don't have control over such variables.

Cheers!
0
 
LVL 85

Author Comment

by:Mike Tomlinson
ID: 9758707
I apologize for the less than clean code posted earlier.  =(
I have moved all the polygon code into the class where it should have been to begin with.  =)

The resulting code is much smaller and easier to read and the compiled EXE now runs without the Run-Time Error 91!

It still, however, has the memory leak problem.  I was very careful, at least I thought I was, in managing my GDI resources.  Everywhere that I create an object, I use it immediately and then delete it.

Can anyone spot where I have gone wrong?

Idle_Mind

' ************************* Code for Form1  *************************
Option Explicit

Private shapes As Collection

Private Sub Form_Load()
    Set shapes = New Collection
    Me.ScaleMode = vbPixels
    createPolygons
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Dim shape As Variant
   
    For Each shape In shapes
        Set shape = Nothing
    Next shape
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim shape As Variant
    Dim rgbColor As Long
           
    For Each shape In shapes
        If shape.pointInRegion(x, y) Then
            shape.hasBeenClicked = True
            rgbColor = RGB(Int(Rnd * 255), Int(Rnd * 255), Int(Rnd * 255))
            shape.fillColor = rgbColor
            shape.drawPolygon Me.hDC
            Exit For
        End If
    Next shape
End Sub

Private Sub Form_Resize()
    Form_Paint
End Sub

Private Sub Form_Paint()
    Dim shape As Variant
                   
    Me.Cls
    For Each shape In shapes
        shape.drawPolygon Me.hDC
    Next shape
End Sub

Private Sub createPolygons()
    Dim poly1 As New Class1
   
    ' Square in Upper Left
    poly1.addVertex Form1.ScaleWidth / 8, Form1.ScaleHeight / 8
    poly1.addVertex 3 * Form1.ScaleWidth / 8, Form1.ScaleHeight / 8
    poly1.addVertex 3 * Form1.ScaleWidth / 8, 3 * Form1.ScaleHeight / 8
    poly1.addVertex Form1.ScaleWidth / 8, 3 * Form1.ScaleHeight / 8
    poly1.addVertex Form1.ScaleWidth / 8, Form1.ScaleHeight / 8
    shapes.Add poly1
   
    ' Triangle in Upper Right
    Set poly1 = New Class1
    poly1.addVertex 6 * Form1.ScaleWidth / 8, Form1.ScaleHeight / 8
    poly1.addVertex 7 * Form1.ScaleWidth / 8, 3 * Form1.ScaleHeight / 8
    poly1.addVertex 5 * Form1.ScaleWidth / 8, 3 * Form1.ScaleHeight / 8
    poly1.addVertex 6 * Form1.ScaleWidth / 8, Form1.ScaleHeight / 8
    shapes.Add poly1
       
    ' Diamond in Bottom Left
    Set poly1 = New Class1
    poly1.addVertex Form1.ScaleWidth / 8, 6 * Form1.ScaleHeight / 8
    poly1.addVertex 2 * Form1.ScaleWidth / 8, 5 * Form1.ScaleHeight / 8
    poly1.addVertex 3 * Form1.ScaleWidth / 8, 6 * Form1.ScaleHeight / 8
    poly1.addVertex 2 * Form1.ScaleWidth / 8, 7 * Form1.ScaleHeight / 8
    poly1.addVertex Form1.ScaleWidth / 8, 6 * Form1.ScaleHeight / 8
    shapes.Add poly1
   
    ' Odd Thing in Bottom Right
    Set poly1 = New Class1
    poly1.addVertex 5 * Form1.ScaleWidth / 8, 6 * Form1.ScaleHeight / 8
    poly1.addVertex 6 * Form1.ScaleWidth / 8, 5 * Form1.ScaleHeight / 8
    poly1.addVertex 7 * Form1.ScaleWidth / 8, 5 * Form1.ScaleHeight / 8
    poly1.addVertex 7 * Form1.ScaleWidth / 8, 7 * Form1.ScaleHeight / 8
    poly1.addVertex 13 * Form1.ScaleWidth / 16, 12 * Form1.ScaleHeight / 16
    poly1.addVertex 5 * Form1.ScaleWidth / 8, 7 * Form1.ScaleHeight / 8
    poly1.addVertex 5 * Form1.ScaleWidth / 8, 6 * Form1.ScaleHeight / 8
    shapes.Add poly1
End Sub

' ************************* Code for Class1  *************************
Option Explicit

Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As Any, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
Private Declare Function Polygon Lib "gdi32" (ByVal hDC As Long, lpPoint As Any, ByVal nCount As Long) As Long
Private Declare Function FillRgn Lib "gdi32" (ByVal hDC As Long, ByVal hRgn As Long, ByVal hbrush As Long) As Long
Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function PtInRegion Lib "gdi32" (ByVal hRgn As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function ExtFloodFill Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long, ByVal wFillType As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)

Private Type point
    x As Long
    y As Long
End Type

Private Const FLOODFILLBORDER = 0
Private Const FLOODFILLSURFACE = 1
Private Const ALTERNATE = 1
Private Const WINDING = 2
Private Const BLACKBRUSH = 4
Private Const NULLBRUSH = 5

Private points() As point
Private numPoints As Integer
Private clicked As Boolean
Private polygonColor As Long
Private polygonRegion As Long

Private Sub Class_Initialize()
    numPoints = 0
    clicked = False
    polygonRegion = 0
    polygonColor = 0
End Sub

Private Sub Class_Terminate()
    If polygonRegion <> 0 Then
        DeleteObject polygonRegion
    End If
End Sub

Public Property Get hasBeenClicked() As Boolean
    hasBeenClicked = clicked
End Property

Public Property Let hasBeenClicked(newClickValue As Boolean)
    clicked = newClickValue
End Property

Public Property Get fillColor() As Long
    fillColor = polygonColor
End Property

Public Property Let fillColor(newFillColor As Long)
    polygonColor = newFillColor
End Property

Public Property Get vertices() As String
    vertices = CStr(VarPtr(points(0))) & "|" & Me.numVertices
End Property

Public Property Get numVertices() As Integer
    numVertices = numPoints
End Property

Public Property Get regionHandle() As Long
    regionHandle = polygonRegion
End Property

Public Sub drawPolygon(hDC As Long)
    Dim hbrush As Long
    If Me.numVertices() >= 2 Then
        hbrush = GetStockObject(NULLBRUSH)
        SelectObject hDC, hbrush
        Polygon hDC, points(0), Me.numVertices
        DeleteObject hbrush
        If Me.hasBeenClicked() Then
            hbrush = GetStockObject(BLACKBRUSH)
            SelectObject hDC, hbrush
            FillRgn hDC, polygonRegion, hbrush
            DeleteObject hbrush
           
            hbrush = CreateSolidBrush(polygonColor)
            SelectObject hDC, hbrush
            ExtFloodFill hDC, points(0).x, points(0).y, GetPixel(hDC, points(0).x, points(0).y), FLOODFILLSURFACE
            DeleteObject hbrush
        End If
    End If
End Sub

Public Function pointInRegion(x As Single, y As Single) As Boolean
    If polygonRegion = 0 Then
        pointInRegion = False
    Else
        pointInRegion = PtInRegion(polygonRegion, x, y)
    End If
End Function

Public Sub addVertex(x As Long, y As Long)
    Dim newPoint As point
    newPoint.x = x
    newPoint.y = y
    numPoints = numPoints + 1
    ReDim Preserve points(numPoints)
    points(numPoints - 1) = newPoint
    If numPoints >= 2 Then
        If polygonRegion <> 0 Then
            DeleteObject polygonRegion
        End If
        polygonRegion = CreatePolygonRgn(points(0), Me.numVertices, ALTERNATE)
    End If
End Sub
0
 
LVL 15

Expert Comment

by:ameba
ID: 9759099
1. Do you know that referencing Form1 as in next line:
     poly1.addVertex Form1.ScaleWidth / 8, Form1.ScaleHeight / 8
might create new instance of Form1?

2. I still see one "As New" declaration. :-)

3. In Form_Unload you have code:
    For Each shape In shapes
        Set shape = Nothing
    Next shape
which isn't doing anything.  There is a reference to each shape in parent collection and setting your loop variable to Nothing won't unload shape objects from memory.  Object will be removed when its REFCOUNT is 0 - IOW, you have to remove each shape from collection, e.g. by setting collection to Nothing.

To check if all objects are unloaded: add breakpoints to Terminate events; use different startup form from which you'll show main form;
For GDI objects, it's more complicated - check documentation and samples on reliable sites.
0
 
LVL 3

Expert Comment

by:NBrownoh
ID: 9759571
the only reason i said the createpolygonrgn was erroring was cuz i put in an error handler on the createpolygons routine and added line numbers, then using the var Erl i was able to find where the error occured in your code. but since you have it working now that doesnt matter too much.
0
 
LVL 85

Author Comment

by:Mike Tomlinson
ID: 9775047
I have made all suggested changes but the mem leak is still occurring and I haven't found any glaring errors in my code.

Does anyone have any links to good GDI websites?

Idle_Mind
0
 
LVL 15

Accepted Solution

by:
ameba earned 500 total points
ID: 9775181
Maybe this can help, not sure; from MSDN:
SelectObject, Remarks
This function returns the previously selected object of the specified type. An application should always replace a new object with the original, default object after it has finished drawing with the new object.

So, instead of:
    SelectObject hDC, hbrush

use:
    hOldBrush = SelectObject(hdc, hbrush)
and later:
    ret = SelectObject(hdc, hOldBrush)

like in this sample: http://www.vbarchiv.net/vbapi/ExtFloodFill.php
0
Why You Should Analyze Threat Actor TTPs

After years of analyzing threat actor behavior, it’s become clear that at any given time there are specific tactics, techniques, and procedures (TTPs) that are particularly prevalent. By analyzing and understanding these TTPs, you can dramatically enhance your security program.

 
LVL 85

Author Comment

by:Mike Tomlinson
ID: 9779377
That's a great thought but I already tried this below in all the appropriate spots in it still had a leak.

ret = SelectObject(hdc, hOldBrush)
If ret <> 0 Then
    DeleteObject ret
End If

End If
0
 
LVL 15

Expert Comment

by:ameba
ID: 9779585
'DeleteObject ret' isn't needed... hope you didn't remove 'DeleteObject hbrush', which is needed.
0
 
LVL 85

Author Comment

by:Mike Tomlinson
ID: 9779590
According to your own post: "This function returns the previously selected object of the specified type"
So I would be deleting whatever was selected before.  The app still worked fine, it just didn't fix the leak. =)
0
 
LVL 15

Expert Comment

by:ameba
ID: 9779708
That is very possible (ret = hbrush); I'll test it all later...
0
 
LVL 85

Author Comment

by:Mike Tomlinson
ID: 9780006
This is what I was doing:

hbrush = GetStockObject(NULLBRUSH)
SelectObject hDC, hbrush
Polygon hDC, points(0), Me.numVertices
DeleteObject hbrush

This is how it should be done:

hbrush = GetStockObject(NULLBRUSH)
ret = SelectObject(hDC, hbrush)
Polygon hDC, points(0), Me.numVertices
SelectObject hDC, ret
DeleteObject hbrush

Thanx ameba,

The excerpt,

"This function returns the previously selected object of the specified type. An application should always replace a new object with the original, default object after it has finished drawing with the new object."

and the example at http://www.vbarchiv.net/vbapi/ExtFloodFill.php helped.

Idle_Mind
0
 
LVL 15

Expert Comment

by:ameba
ID: 9780502
Thanks Idle_Mind, I'm glad it works.  I'll post last version, for easier cut & paste, for any possible reader.

' ************************* Code for Form1  *************************
Option Explicit

Private shapes As Collection

Private Sub Form_Load()
    Set shapes = New Collection
    Me.ScaleMode = vbPixels
    createPolygons
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set shapes = Nothing
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim shape As Class1
    Dim rgbColor As Long
           
    For Each shape In shapes
        If shape.pointInRegion(x, y) Then
            shape.hasBeenClicked = True
            rgbColor = RGB(Int(Rnd * 255), Int(Rnd * 255), Int(Rnd * 255))
            shape.fillColor = rgbColor
            shape.drawPolygon Me.hDC
            Exit For
        End If
    Next shape
End Sub

Private Sub Form_Resize()
    'Form_Paint
End Sub

Private Sub Form_Paint()
    Dim shape As Class1
                   
    Me.Cls
    For Each shape In shapes
        shape.drawPolygon Me.hDC
    Next shape
End Sub

Private Sub createPolygons()
    Dim poly1 As Class1
   
    ' Square in Upper Left
    Set poly1 = New Class1
    poly1.addVertex Me.ScaleWidth / 8, Me.ScaleHeight / 8
    poly1.addVertex 3 * Me.ScaleWidth / 8, Me.ScaleHeight / 8
    poly1.addVertex 3 * Me.ScaleWidth / 8, 3 * Me.ScaleHeight / 8
    poly1.addVertex Me.ScaleWidth / 8, 3 * Me.ScaleHeight / 8
    poly1.addVertex Me.ScaleWidth / 8, Me.ScaleHeight / 8
    shapes.Add poly1
   
    ' Triangle in Upper Right
    Set poly1 = New Class1
    poly1.addVertex 6 * Me.ScaleWidth / 8, Me.ScaleHeight / 8
    poly1.addVertex 7 * Me.ScaleWidth / 8, 3 * Me.ScaleHeight / 8
    poly1.addVertex 5 * Me.ScaleWidth / 8, 3 * Me.ScaleHeight / 8
    poly1.addVertex 6 * Me.ScaleWidth / 8, Me.ScaleHeight / 8
    shapes.Add poly1
       
    ' Diamond in Bottom Left
    Set poly1 = New Class1
    poly1.addVertex Me.ScaleWidth / 8, 6 * Me.ScaleHeight / 8
    poly1.addVertex 2 * Me.ScaleWidth / 8, 5 * Me.ScaleHeight / 8
    poly1.addVertex 3 * Me.ScaleWidth / 8, 6 * Me.ScaleHeight / 8
    poly1.addVertex 2 * Me.ScaleWidth / 8, 7 * Me.ScaleHeight / 8
    poly1.addVertex Me.ScaleWidth / 8, 6 * Me.ScaleHeight / 8
    shapes.Add poly1
   
    ' Odd Thing in Bottom Right
    Set poly1 = New Class1
    poly1.addVertex 5 * Me.ScaleWidth / 8, 6 * Me.ScaleHeight / 8
    poly1.addVertex 6 * Me.ScaleWidth / 8, 5 * Me.ScaleHeight / 8
    poly1.addVertex 7 * Me.ScaleWidth / 8, 5 * Me.ScaleHeight / 8
    poly1.addVertex 7 * Me.ScaleWidth / 8, 7 * Me.ScaleHeight / 8
    poly1.addVertex 13 * Me.ScaleWidth / 16, 12 * Me.ScaleHeight / 16
    poly1.addVertex 5 * Me.ScaleWidth / 8, 7 * Me.ScaleHeight / 8
    poly1.addVertex 5 * Me.ScaleWidth / 8, 6 * Me.ScaleHeight / 8
    shapes.Add poly1
   
    Set poly1 = Nothing
End Sub


' ************************* Code for Class1  *************************
Option Explicit

Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As Any, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
Private Declare Function Polygon Lib "gdi32" (ByVal hDC As Long, lpPoint As Any, ByVal nCount As Long) As Long
Private Declare Function FillRgn Lib "gdi32" (ByVal hDC As Long, ByVal hRgn As Long, ByVal hbrush As Long) As Long
Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function PtInRegion Lib "gdi32" (ByVal hRgn As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function ExtFloodFill Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long, ByVal wFillType As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)

Private Type point
    x As Long
    y As Long
End Type

Private Const FLOODFILLBORDER = 0
Private Const FLOODFILLSURFACE = 1
Private Const ALTERNATE = 1
Private Const WINDING = 2
Private Const BLACKBRUSH = 4
Private Const NULLBRUSH = 5

Private points() As point
Private numPoints As Integer
Private clicked As Boolean
Private polygonColor As Long
Private polygonRegion As Long

Private Sub Class_Terminate()
    If polygonRegion <> 0 Then
        DeleteObject polygonRegion
    End If
End Sub

Public Property Get hasBeenClicked() As Boolean
    hasBeenClicked = clicked
End Property

Public Property Let hasBeenClicked(newClickValue As Boolean)
    clicked = newClickValue
End Property

Public Property Get fillColor() As Long
    fillColor = polygonColor
End Property

Public Property Let fillColor(newFillColor As Long)
    polygonColor = newFillColor
End Property

Public Property Get vertices() As String
    vertices = CStr(VarPtr(points(0))) & "|" & Me.numVertices
End Property

Public Property Get numVertices() As Integer
    numVertices = numPoints
End Property

Public Property Get regionHandle() As Long
    regionHandle = polygonRegion
End Property

Public Sub drawPolygon(hDC As Long)
    Dim hbrush As Long, oldbrush As Long
   
    If Me.numVertices() >= 2 Then
        hbrush = GetStockObject(NULLBRUSH)
        SelectObject hDC, hbrush
        Polygon hDC, points(0), Me.numVertices
        DeleteObject hbrush
        If Me.hasBeenClicked() Then
            hbrush = GetStockObject(BLACKBRUSH)
            oldbrush = SelectObject(hDC, hbrush)
            FillRgn hDC, polygonRegion, hbrush
            SelectObject hDC, oldbrush
            DeleteObject hbrush
           
            hbrush = CreateSolidBrush(polygonColor)
            oldbrush = SelectObject(hDC, hbrush)
            ExtFloodFill hDC, points(0).x, points(0).y, GetPixel(hDC, points(0).x, points(0).y), FLOODFILLSURFACE
            SelectObject hDC, oldbrush
            DeleteObject hbrush
        End If
    End If
End Sub

Public Function pointInRegion(x As Single, y As Single) As Boolean
    If polygonRegion Then
        pointInRegion = PtInRegion(polygonRegion, x, y)
    End If
End Function

Public Sub addVertex(x As Long, y As Long)
    Dim newPoint As point
   
    newPoint.x = x
    newPoint.y = y
    numPoints = numPoints + 1
    ReDim Preserve points(numPoints)
    points(numPoints - 1) = newPoint
    If numPoints >= 2 Then
        If polygonRegion <> 0 Then
            DeleteObject polygonRegion
        End If
        polygonRegion = CreatePolygonRgn(points(0), Me.numVertices, ALTERNATE)
    End If
End Sub


and a homework for that reader :-)
- allow move of polygons: left mouse button - move, right button - colorize
0
 
LVL 85

Author Comment

by:Mike Tomlinson
ID: 9780545
You missed one in the drawPolydon() function.

Public Sub drawPolygon(hDC As Long)
    Dim hbrush As Long, oldbrush As Long
   
    If Me.numVertices() >= 2 Then
        hbrush = GetStockObject(NULLBRUSH)
        SelectObject hDC, hbrush  ' <--------------------- Forgot one =)
        Polygon hDC, points(0), Me.numVertices
        DeleteObject hbrush
        If Me.hasBeenClicked() Then
            hbrush = GetStockObject(BLACKBRUSH)
            oldbrush = SelectObject(hDC, hbrush)
            FillRgn hDC, polygonRegion, hbrush
            SelectObject hDC, oldbrush
            DeleteObject hbrush
           
            hbrush = CreateSolidBrush(polygonColor)
            oldbrush = SelectObject(hDC, hbrush)
            ExtFloodFill hDC, points(0).x, points(0).y, GetPixel(hDC, points(0).x, points(0).y), FLOODFILLSURFACE
            SelectObject hDC, oldbrush
            DeleteObject hbrush
        End If
    End If
End Sub

So it should be:

Public Sub drawPolygon(hDC As Long)
    Dim hbrush As Long, oldbrush As Long
   
    If Me.numVertices() >= 2 Then
        hbrush = GetStockObject(NULLBRUSH)
        oldbrush = SelectObject(hDC, hbrush)
        Polygon hDC, points(0), Me.numVertices
        SelectObject hDc, oldbrush
        DeleteObject hbrush
        If Me.hasBeenClicked() Then
            hbrush = GetStockObject(BLACKBRUSH)
            oldbrush = SelectObject(hDC, hbrush)
            FillRgn hDC, polygonRegion, hbrush
            SelectObject hDC, oldbrush
            DeleteObject hbrush
           
            hbrush = CreateSolidBrush(polygonColor)
            oldbrush = SelectObject(hDC, hbrush)
            ExtFloodFill hDC, points(0).x, points(0).y, GetPixel(hDC, points(0).x, points(0).y), FLOODFILLSURFACE
            SelectObject hDC, oldbrush
            DeleteObject hbrush
        End If
    End If
End Sub

Idle_Mind
0
 
LVL 85

Author Comment

by:Mike Tomlinson
ID: 9780561
0
 
LVL 15

Expert Comment

by:ameba
ID: 9780562
Oops, thanks.
0

Featured Post

Better Security Awareness With Threat Intelligence

See how one of the leading financial services organizations uses Recorded Future as part of a holistic threat intelligence program to promote security awareness and proactively and efficiently identify threats.

Join & Write a Comment

Introduction While answering a recent question (http://www.experts-exchange.com/Q_27402310.html) in the VB classic zone, I wrote some VB code in the (Office) VBA environment, rather than fire up my older PC.  I didn't post completely correct code o…
You can of course define an array to hold data that is of a particular type like an array of Strings to hold customer names or an array of Doubles to hold customer sales, but what do you do if you want to coordinate that data? This article describes…
Get people started with the process of using Access VBA to control Excel using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Excel. Using automation, an Access application can laun…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

760 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

19 Experts available now in Live!

Get 1:1 Help Now