***WARNING*** HARDCORE EXPERTS ONLY - GDI Memory Leak / Run-Time Error 91 on Compiled .EXE
Here is a project I have written in response to this question:
https://www.experts-exchange.com/questions/20799010/how-to-fill-a-shape-triangle-hexagon-rectangle-etc-with-colors.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(
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(
hBrush = GetStockObject(BLACKBRUSH)
SelectObject Me.hdc, hBrush
FillRgn Me.hdc, CLng(region), hBrush
DeleteObject hBrush
rgbColor = CLng(clickedRegions.Item(C
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)
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)
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)
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)
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
On Error GoTo notClickedYet
Dim checkRegion As Variant
regionAlreadyClicked = False
checkRegion = clickedRegions.Item(region
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
https://www.experts-exchange.com/questions/20799010/how-to-fill-a-shape-triangle-hexagon-rectangle-etc-with-colors.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(
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(
hBrush = GetStockObject(BLACKBRUSH)
SelectObject Me.hdc, hBrush
FillRgn Me.hdc, CLng(region), hBrush
DeleteObject hBrush
rgbColor = CLng(clickedRegions.Item(C
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)
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)
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)
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)
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
On Error GoTo notClickedYet
Dim checkRegion As Variant
regionAlreadyClicked = False
checkRegion = clickedRegions.Item(region
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
ASKER
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
Idle_Mind
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!
> 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!
ASKER
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(newClickVal
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(polygonCo
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)
End If
End Sub
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(newClickVal
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(polygonCo
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)
End If
End Sub
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.
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.
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.
ASKER
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
Does anyone have any links to good GDI websites?
Idle_Mind
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
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
ret = SelectObject(hdc, hOldBrush)
If ret <> 0 Then
DeleteObject ret
End If
End If
'DeleteObject ret' isn't needed... hope you didn't remove 'DeleteObject hbrush', which is needed.
ASKER
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. =)
So I would be deleting whatever was selected before. The app still worked fine, it just didn't fix the leak. =)
That is very possible (ret = hbrush); I'll test it all later...
ASKER
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
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
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(newClickVal
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(polygonCo
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)
End If
End Sub
and a homework for that reader :-)
- allow move of polygons: left mouse button - move, right button - colorize
' ************************* 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(newClickVal
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(polygonCo
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)
End If
End Sub
and a homework for that reader :-)
- allow move of polygons: left mouse button - move, right button - colorize
ASKER
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(polygonCo
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(polygonCo
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
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(polygonCo
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(polygonCo
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
ASKER
You can also see the finished program here:
https://www.experts-exchange.com/questions/20799010/how-to-fill-a-shape-triangle-hexagon-rectangle-etc-with-colors.html
Idle_Mind
https://www.experts-exchange.com/questions/20799010/how-to-fill-a-shape-triangle-hexagon-rectangle-etc-with-colors.html
Idle_Mind
Oops, thanks.
hRgn = CreatePolygonRgn(points(0)
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.