Draw diamond shape 2

[SimonFinn]

Hi Guys

I want to draw a diamond shape in a program that i am writing.

I am wondering if it possible without using 4 lines.

I need to be able to reference it as a whole in an array, as i would with an array of say rectangles. The size of the diamond will be determined by the user prior to the program drawing it.

Is there a quick way of doing this with low overheads?

Cheers Si

 

[DrJavaJoe]

You could create your own class that draws a diamond then create array of those diamonds. For the quickest drawing I would use the Polygon api.

 

[SimonFinn]

Hi

I have started using the Polygon API, and am having trouble getting it to work fully.

It is not quite a diamond that i am trying to create it is more like a rectangle on its side, which needs to be drawn to the users scale.

Currently i am attempting to just put one polygon on the form when the user clicks on the form. I need to calculate the X & Y of each of the 4 points, the only data i have is the length of each side of the rectangle and that it will be at a 45 degree angle.

I dont think i quite have the right calculation, as my rectangle seems to look more like an odd shaped triangle. And the more modifications i make the less like a rectangle it looks!

Here is my code, could you please point me in the right direction:


Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

Dim c As Double
Dim d As Double
Dim poly(1 To 4) As COORD, NumCoords As Long, hBrush As Long, hRgn As Long

intX = X
intY = Y

Me.Cls
NumCoords = 4
Const width = 25
Const height = 40

c = Sqr(width ^ 2 / 2)
d = Sqr(height ^ 2 / 2)

poly(1).X = intX
poly(1).Y = intY

poly(2).X = intX + c
poly(2).Y = intY + c

poly(4).Y = intY + d
poly(4).X = intX + d

poly(3).X = poly(2).X + d
poly(3).Y = poly(2).Y + c

Polygon Me.hdc, poly(1), NumCoords
hBrush = GetStockObject(BLACKBRUSH)
hRgn = CreatePolygonRgn(poly(1), NumCoords, ALTERNATE)
DeleteObject hRgn

End Sub

 

[DrJavaJoe]

Try changing these line:

poly(1).X = intX
poly(1).Y = intY
poly(2).X = poly(1).X + d
poly(2).Y = poly(1).Y + d
poly(3).X = poly(2).X - c
poly(3).Y = poly(2).Y + c
poly(4).X = poly(3).X - d
poly(4).Y = poly(3).Y - d

 

[paulbent]

I just set up a simple test and this seemed to work fien:

Private Sub Command1_Click()

    Dim lngRtn As Long
    Dim audtPt(0 To 3) As POINT_TYPE
    Const R_WIDTH = 25
    Const R_HEIGHT = 40
    Const R_ANGLE = 45
    
    'First point
    audtPt(0).x = 200
    audtPt(0).y = 100
    'Second point
    audtPt(1).x = audtPt(0).x + CLng(R_WIDTH * Cos(R_ANGLE))
    audtPt(1).y = audtPt(0).y + CLng(R_HEIGHT * Sin(R_ANGLE))
    'Third point
    audtPt(2).x = audtPt(0).x
    audtPt(2).y = audtPt(0).y + ((audtPt(1).y - audtPt(0).y) * 2)
    'Fourth point
    audtPt(3).x = audtPt(0).x - (audtPt(1).x - audtPt(0).x)
    audtPt(3).y = audtPt(1).y
    
    Me.Cls
    lngRtn = Polygon(Me.hdc, audtPt(0), 4)

End Sub

Paul Bent
Northwind IT Systems

http://www.northwindit.co.uk

 

[strongm]

Or you could use a world transform and the Rectangle API call...(a bit more complex to set up, but has the advantage that the rectangle can be shown at any angle of rotation you fancy)

 

[SimonFinn]

Hi guys,

Dr Java Jo's ammendments made the code run correctly, but thanks for the other posts guys. Now im having a few probs turning it into a class and a function.

I need to be able to list the polygons in an array and delete them if the user requires it.

I currently have this code:


Class: clsPolygon

Option Explicit
Private Declare Function polygon Lib "gdi32" Alias "Polygon" (ByVal hdc As Long, lpPoint As Any, ByVal nCount As Long) As Long
Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As Any, ByVal nCount As Long, ByVal nPolyFillMode 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
Const BLACKBRUSH = 4
Const ALTERNATE = 1
Const WINDING = 2


Module: modPolygon
Option Explicit
Private Type COORD
X As Long
Y As Long
End Type


Public Sub drawpolygon(ByVal lngX As Long, ByVal lngY As Long, ByVal dblHeight As Double, ByVal dblWidth As Double, ByVal lngHDC As Long)

Dim c As Double
Dim d As Double
Dim poly(1 To 4) As COORD, NumCoords As Long, hBrush As Long, hRgn As Long

'No Verticies in Polygon
NumCoords = 4

c = Sqr(dblWidth ^ 2 / 2)
d = Sqr(dblHeight ^ 2 / 2)

poly(1).X = lngX
poly(1).Y = lngY
poly(2).X = poly(1).X + d
poly(2).Y = poly(1).Y + d
poly(3).X = poly(2).X - c
poly(3).Y = poly(2).Y + c
poly(4).X = poly(3).X - d
poly(4).Y = poly(3).Y - d


polygon lngHDC, poly(1), NumCoords
hBrush = GetStockObject(BLACKBRUSH)
hRgn = CreatePolygonRgn(poly(1), NumCoords, ALTERNATE)
DeleteObject hRgn

End Sub


Form1 Subs:
Option Explicit

Private lngX As Integer
Private lngY As Integer


Private Sub picPlan_Click()

Dim dblHeight As Double
Dim dblWidth As Double

dblHeight = 25
dblWidth = 40
Call drawpolygon(lngX, lngY, dblHeight, dblWidth, picPlan.hdc)

End Sub


Private Sub picPlan_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

lngX = X
lngY = Y

End Sub



Thanks Si

 

[DrJavaJoe]

The function drawpolygon and all your api declaration should be in your Diamond class module. Then I would create a collection of clsDiamonds. you should then be able to do something like me.cls -> collectionName.Add Key or collectionName.Remove Key -> then for each item in the collection redraw your diamonds. Hope this makes since.

 

[SimonFinn]

Hi

Sorry about such a delay in replying I had an urgent project to complete.

I have created my class and copied my code to it, but i am a little confused to how i pass the arguements to the function.

If i put: "Private clsPolygon As Collection" in the module that i want to access the class from i get the options: add, count etc, but i need to pass these arguments to the class:
ByVal lngX As Long, ByVal lngY As Long, ByVal dblHeight As Double, ByVal dblWidth As Double, ByVal lngHDC As Long

Plus whichever way i do this when i attempt to call the add function i get the error: Object Variable or With Block Variable not set.

Thanks Si

 

[paulbent]

I take it you are using two classes, one for a Polygon and one for a collection of Polygons.

Put those parameters in the Add method of the Polygons class. Each of the parameters should be Public or Friend properties of the Polygon class. Eg:

Public Function Add(ByVal lngX As Long, _
ByVal lngY As Long, ByVal dblHeight As Double, _
ByVal dblWidth As Double, ByVal lngHDC As Long) _
As Polygon

    'Create a new Polygon object
    Dim objPoly As Polygon
    Set objPoly = New Polygon
    
    'Set the properties passed into the method
    With objPoly
        .X = lngX
        .Y = lngY
        .Height = dblHeight
        .Width = dblWidth
        .HDC = lngHDC
    End With

    'Add the object
    mCol.Add objPoly
    
    'Return the new Polygon object
    Set Add = objPoly
    Set objPoly = Nothing

End Function

Paul Bent
Northwind IT Systems

http://www.northwindit.co.uk

 

[SimonFinn]

Hi Paul,

I actually only have one class, do I need to change it in to two as you have noted? My code is below:

clsPolygon:

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" Alias "Polygon" (ByVal hdc As Long, lpPoint As Any, ByVal nCount 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
Const ALTERNATE = 1
Const WINDING = 2
Const BLACKBRUSH = 4
Private Type COORD
X As Long
Y As Long
End Type

Public Sub Add(ByVal lngX As Long, ByVal lngY As Long, ByVal dblHeight As Double, ByVal dblWidth As Double, ByVal lngHDC As Long)

Dim c As Double
Dim d As Double
Dim poly(1 To 4) As COORD, NumCoords As Long, hBrush As Long, hRgn As Long

NumCoords = 4

c = Sqr(dblWidth ^ 2 / 2)
d = Sqr(dblHeight ^ 2 / 2)

poly(1).X = lngX
poly(1).Y = lngY
poly(2).X = poly(1).X + d
poly(2).Y = poly(1).Y + d
poly(3).X = poly(2).X - c
poly(3).Y = poly(2).Y + c
poly(4).X = poly(3).X - d
poly(4).Y = poly(3).Y - d

polygon lngHDC, poly(1), NumCoords
hBrush = GetStockObject(BLACKBRUSH)
hRgn = CreatePolygonRgn(poly(1), NumCoords, ALTERNATE)

DeleteObject hRgn

End Sub


And Form1:

Private clsPolygon As Collection
Private lngX As Integer
Private lngY As Integer


Private Sub picPlan_Click()

Dim dblHeight As Double
Dim dblWidth As Double

dblHeight = 25
dblWidth = 40
clsPolygon.Add clsPolygon.Count - 1, clsPolygon.Count

End Sub


Private Sub picPlan_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

lngX = X
lngY = Y


End Sub

 

[DrJavaJoe]

SimonFinn, yes you should create a second class. What you might try if you never used collections before is use the VB Class Builder. When you choose to add class module select the Vb Class Builder then on the Class Builder dialog choose the 2nd toolbar option Add New Collection.

 

[paulbent]

Yes, you should have two classes: one for the object and one for a collection of them. Here's an example of a Paper object and a Papers collection that you can easily adapt. Some properties are declared as Friend because in this example its part of an ActiveX project in which Paper and Papers objects can only be created by another object and aren't directly public to a client exe.

Private lngPaper As PDXPaperSize  'Paper size constant
Private intWidth As Integer   'Paper width in tenths of a millimetre
Dim intLength As Integer    'Paper length in tenths of a millimetre
Private strPaperName As String  'Paper name

'--- LENGTH property
'--- Returns the length of the paper in tenths of a millimetre
'--- Public read-only

Public Property Get Length() As Integer

    Length = intLength

End Property

Friend Property Let Length(ByVal intNewData As Integer)

    intLength = intNewData

End Property

'--- NAME property
'--- Returns the name of the paper
'--- Public read-only

Public Property Get Name() As String

    Name = strPaperName

End Property

Friend Property Let Name(ByVal strNewData As String)

    strPaperName = strNewData

End Property

'--- ENUMVALUE property
'--- Returns the enum value of the paper
'--- Public read-only

Public Property Get EnumValue() As PDXPaperSize

    EnumValue = lngPaper

End Property

Friend Property Let EnumValue(ByVal lngNewData As PDXPaperSize)

    lngPaper = lngNewData

End Property

'--- WIDTH property
'--- Returns the width of the paper in tenths of a millimetre
'--- Public read-only

Public Property Get Width() As Integer

    Width = intWidth

End Property

Friend Property Let Width(ByVal intNewData As Integer)

    intWidth = intNewData

End Property
'________________________________
Private mCol As Collection      'Papers collection object

'--- COUNT property - Read Only
'--- Returns the number of objects in the collection

Public Property Get Count() As Long
    
    Count = mCol.Count
    
End Property

'--- ITEM property - Read Only
'--- Returns an object from the collection

Public Property Get Item(ByVal Index As Variant) As Paper
    
    On Error Resume Next
    Set Item = mCol(Index)
    On Error GoTo 0
    
End Property

'--- ADD method - Friend function
'     Adds a Paper object to the collection

Friend Function Add(ByVal PaperName As String, _
ByVal EnumValue As PDXPaperSource, _
ByVal Width As Integer, _
ByVal Length As Integer) As Paper

    'Create a new Printer object
    Dim objPaper As Paper
    Set objPaper = New Paper
    
    'Set the properties passed into the method
    objPaper.Name = PaperName
    objPaper.EnumValue = EnumValue
    objPaper.Width = Width
    objPaper.Length = Length
    
    'Add the object
    mCol.Add objPaper, PaperName
    
    'Return the new Printer object
    Set Add = objPaper
    Set objPaper = Nothing

End Function

'--- REMOVE method - Friend function
'--- Removes a Bin object from the collection

Friend Sub Remove(ByVal Index As Variant)
    
    mCol.Remove Index
    
End Sub

'--- Constructor sub

Private Sub Class_Initialize()
    
    'Initialise the collection
    Set mCol = New Collection
    
End Sub

'--- Destructor sub
Private Sub Class_Terminate()
    
    'Destroy the collection when the class goes out of existence
    Set mCol = Nothing
    
End Sub

Paul Bent
Northwind IT Systems

http://www.northwindit.co.uk

 

[SimonFinn]

Hi Guys

Sorry again for the delay in replying, I keep getting given other tasks to complete.

At last I have a few hours free to complete this!

I have created my class and collection, I have used the class builder and it has developed a similar set of code to yours Paul.

I now have to add my code to create each polygon, i have been looking at the Add function that has been created, which looks like this:

Public Function Add(colPolygon As colPolygon, Optional sKey As String) As clsPolygon
'create a new object
Dim objNewMember As clsPolygon
Set objNewMember = New clsPolygon

'set the properties passed into the method
Set objNewMember.colPolygon = colPolygon
If Len(sKey) = 0 Then
mCol.Add objNewMember
Else
mCol.Add objNewMember, sKey
End If

'return the object created
Set Add = objNewMember
Set objNewMember = Nothing

End Sub

I am assuming that i modify this code to include my function. If so how would I integrate my object poly with the objNewMember, as I am assuming that that when i have finished objNewMember and poly will be the same.

Thanks Si.

 

[paulbent]

I think you're going round in circles here. The Add method creates a new Polygon object, sets any passed in properties and adds it to the private collection. You shouldn't be passing a collection class into the Add method.

Either specify polygon properties in the Add method or set them later by returning a Polygon from the collection with the Item method:

Public Function Add( _
ByVal X As Long, _
ByVal Y As Long, _
Optional sKey As String) As clsPolygon
'create a new object
Dim objNewMember As clsPolygon
Set objNewMember = New clsPolygon

'set the properties passed into the method
objNewMember.X = X
objNewMember.Y = Y
'and so on for any other parameters
If Len(sKey) = 0 Then
mCol.Add objNewMember
Else
mCol.Add objNewMember, sKey
End If

'return the object created
Set Add = objNewMember
Set objNewMember = Nothing

End Function

Paul Bent
Northwind IT Systems

http://www.northwindit.co.uk

 

[SimonFinn]

Sorry im a little lost, so where would i be putting my create polygon code:

Dim c As Double
Dim d As Double
Dim poly(1 To 4) As COORD, NumCoords As Long, hBrush As Long, hRgn As Long .........

Sorry about the circles... Thanks Si

 

[DrJavaJoe]

Here's a link that you should read I think it'll help you better understand the collection object.

http://msdn.microsoft.com/library/d.../html/vbconthevisualbasiccollectionobject.asp

 

[strongm]

SimonFinn,
You may not have a final solution yet, but there are two people who seem to have been pretty helpful here. You might like to acknowledge the time and effort they've put in to help you out by awarding each of them a star...

 

[SimonFinn]

Sorry, I didnt actually realise that you could award stars.

Thanks so much for the help both of you... And thanks for the msdn link, i will have a good read.

Cheers Si