Solved

To draw fill color parallelograms

Posted on 2000-04-07
3
494 Views
Last Modified: 2008-02-01
I need to draw simple fill color paralelograms (not rectangles), Are there any control that draw it?
0
Comment
Question by:abautistat
  • 2
3 Comments
 
LVL 10

Accepted Solution

by:
caraf_g earned 50 total points
Comment Utility
Are you comfortable with API calls?

It's relatively easy to do this with API calls.

What follows is an extract from a program I wrote. Advantage: It definitely works. Disadvantage: It's out of context so you'll have to take the code I provide and make it work for you. I can't give you all the code as it would impinge on copyright...


Here are some of the definitions you'll need... Again, this is out of context and I'll be pasting stuff in here that you will not need. you can take it out. Better to get too much than too little ;-)


Option Explicit

Private Const BLACKNESS = &H42 ' (DWORD) dest = BLACK
Private Const DSTINVERT = &H550009       ' (DWORD) dest = (NOT dest)
Private Const MERGECOPY = &HC000CA       ' (DWORD) dest = (source AND pattern)
Private Const MERGEPAINT = &HBB0226      ' (DWORD) dest = (NOT source) OR dest
Private Const NOTSRCCOPY = &H330008      ' (DWORD) dest = (NOT source)
Private Const NOTSRCERASE = &H1100A6     ' (DWORD) dest = (NOT src) AND (NOT dest)
Private Const PATCOPY = &HF00021 ' (DWORD) dest = pattern
Private Const PATINVERT = &H5A0049       ' (DWORD) dest = pattern XOR dest
Private Const PATPAINT = &HFB0A09        ' (DWORD) dest = DPSnoo
Private Const SRCAND = &H8800C6  ' (DWORD) dest = source AND dest
Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Private Const SRCERASE = &H440328        ' (DWORD) dest = source AND (NOT dest )
Private Const SRCINVERT = &H660046       ' (DWORD) dest = source XOR dest
Private Const SRCPAINT = &HEE0086        ' (DWORD) dest = source OR dest
Private Const WHITENESS = &HFF0062       ' (DWORD) dest = WHITE

Private Type BITMAP
        bmType As Long
        bmWidth As Long
        bmHeight As Long
        bmWidthBytes As Long
        bmPlanes As Integer
        bmBitsPixel As Integer
        bmBits As Long
End Type
Private Const IMAGE_BITMAP As Long = 0
Private Const IMAGE_ICON As Long = 1
Private Const IMAGE_CURSOR As Long = 2
Private Const LR_DEFAULTCOLOR      As Long = &H0
Private Const LR_MONOCHROME        As Long = &H1
Private Const LR_COLOR             As Long = &H2
Private Const LR_COPYRETURNORG     As Long = &H4
Private Const LR_COPYDELETEORG     As Long = &H8
Private Const LR_LOADFROMFILE      As Long = &H10
Private Const LR_LOADTRANSPARENT   As Long = &H20
Private Const LR_DEFAULTSIZE       As Long = &H40
Private Const LR_VGACOLOR          As Long = &H80
Private Const LR_LOADMAP3DCOLORS   As Long = &H1000
Private Const LR_CREATEDIBSECTION  As Long = &H2000
Private Const LR_COPYFROMRESOURCE  As Long = &H4000
Private Const LR_SHARED            As Long = &H8000
Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private Const pNull As Long = 0
Private Declare Function GetDIBColorTable Lib "gdi32" (ByVal hdc As Long, _
                                                       ByVal un1 As Long, _
                                                       ByVal un2 As Long, _
                                                       pRGBQuad As PALETTEENTRY) As Long
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, _
                                                                      ByVal nCount As Long, _
                                                                      lpObject As Any) As Long
Private Declare Function CreateHalftonePalette Lib "gdi32" (ByVal hdc As Long) As Long

Private Type PicBmp
    Size As Long
    Type As Long
    hBmp As Long
    hPal As Long
    Reserved As Long
End Type

Private Declare Function OleCreatePictureIndirect _
    Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, _
    ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type

Private Type PALETTEENTRY
    peRed As Byte
    peGreen As Byte
    peBlue As Byte
    peFlags As Byte
End Type
Private Type LOGPALETTE
    palVersion As Integer
    palNumEntries As Integer
    palPalEntry(255) As PALETTEENTRY  ' Enough for 256 colors.
End Type
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetDC Lib "user32" ( _
    ByVal hWnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" ( _
    ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" ( _
    ByVal hdc As Long, ByVal nWidth As Long, _
    ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" ( _
    ByVal hdc As Long, ByVal hObject As Long) As Long
Private Const RASTERCAPS As Long = 38
Private Const RC_PALETTE As Long = &H100
Private Const SIZEPALETTE As Long = 104
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
    ByVal hdc As Long, ByVal iCapabilitiy As Long) As Long
Private Declare Function GetSystemPaletteEntries Lib "gdi32" ( _
    ByVal hdc As Long, ByVal wStartIndex As Long, _
    ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) _
    As Long
Private Declare Function CreatePalette Lib "gdi32" ( _
    lpLogPalette As LOGPALETTE) As Long
Private Declare Function SelectPalette Lib "gdi32" ( _
    ByVal hdc As Long, ByVal hPalette As Long, _
    ByVal bForceBackground As Long) As Long
Private Declare Function RealizePalette Lib "gdi32" ( _
    ByVal hdc As Long) As Long
Private Declare Function BitBlt Lib "gdi32" ( _
    ByVal hDCDest As Long, ByVal XDest As Long, _
    ByVal YDest As Long, ByVal nWidth As Long, _
    ByVal nHeight As Long, ByVal hDCSrc As Long, _
    ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) _
    As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" ( _
    ByVal hdc As Long) As Long
Private Declare Function ReleaseDC Lib "user32" ( _
    ByVal hWnd As Long, ByVal hdc As Long) As Long
Type POINTAPI
        X As Long
        Y As Long
End Type
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, lpPoint As POINTAPI) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long

Private Declare Function FloodFill Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long

Private Declare Function Polygon Lib "gdi32" (ByVal hdc As Long, lpPoint As POINTAPI, ByVal nCount As Long) As Long

Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As POINTAPI, ByVal nCount As Long, ByVal nPolyFillMode 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 Const WINDING As Long = 2



0
 
LVL 10

Expert Comment

by:caraf_g
Comment Utility
And this is an extract of a bit of code that uses the above to draw filled-in shapes with black borders. Although I'm drawing squares you can draw any shape you like this way... Again, this refers to, for example, a collection you won't have but just take that bit out and make it work with something else. Important bit is the API calls and how to use them...

Sorry I can't give you a fully working stand-alone example, so you'll need to do a bit of work for yourself...

    Dim PolyGonPoints(0 To 3) As POINTAPI
    hpen = CreatePen(0, 3, vbBlack)
    old_pen = SelectObject(hEndResultDC, hpen)
    For lngCount1 = 1 To colDrawSquares.Count
        Set objSquare = colDrawSquares(lngCount1)
        With objSquare
            PolyGonPoints(0).X = .Point(1).XDraw
            PolyGonPoints(0).Y = .Point(1).YDraw
            PolyGonPoints(1).X = .Point(2).XDraw
            PolyGonPoints(1).Y = .Point(2).YDraw
            PolyGonPoints(2).X = .Point(3).XDraw
            PolyGonPoints(2).Y = .Point(3).YDraw
            PolyGonPoints(3).X = .Point(4).XDraw
            PolyGonPoints(3).Y = .Point(4).YDraw
            If .FaceNumber = 0 Then
                brush = CreateSolidBrush(vbGreen)
            Else
                brush = CreateSolidBrush(vbGreen)
            End If
            old_brush = SelectObject(hEndResultDC, brush)
            Polygon hEndResultDC, PolyGonPoints(0), 4
            brush = SelectObject(hEndResultDC, old_brush)
            DeleteObject brush
            dblX21 = .Point(2).NewX3d - .Point(1).NewX3d
            dblX41 = .Point(4).NewX3d - .Point(1).NewX3d
            dblY21 = .Point(2).NewY3d - .Point(1).NewY3d
            dblY41 = .Point(4).NewY3d - .Point(1).NewY3d
            dblZ21 = .Point(2).NewZ3d - .Point(1).NewZ3d
            dblZ41 = .Point(4).NewZ3d - .Point(1).NewZ3d
            dblXStart = .Point(1).NewX3d
            dblYStart = .Point(1).NewY3d
            dblZStart = .Point(1).NewZ3d
            For dblhSub = 1 To objSquare.hCount
                For dblvSub = 1 To objSquare.vCount
                    If .FaceNumber = 0 Then
                        brush = CreateSolidBrush(.Colour)
                    Else
                        brush = CreateSolidBrush(gobjRubik.SquareColour(.FaceNumber, .SquareNumber(dblhSub, dblvSub)))
                    End If
                    old_brush = SelectObject(hEndResultDC, brush)
                    dblX0 = (dblhSub - 1) / .hCount
                    dblX1 = dblhSub / .hCount
                    dblY0 = (dblvSub - 1) / .vCount
                    dblY1 = dblvSub / .vCount
                    With objPoint
                        .OrgX3d = dblXStart + dblX0 * dblX21 + dblY0 * dblX41
                        .OrgY3d = dblYStart + dblX0 * dblY21 + dblY0 * dblY41
                        .OrgZ3d = dblZStart + dblX0 * dblZ21 + dblY0 * dblZ41
                        PolyGonPoints(0).X = .XDraw
                        PolyGonPoints(0).Y = .YDraw
                        .OrgX3d = dblXStart + dblX1 * dblX21 + dblY0 * dblX41
                        .OrgY3d = dblYStart + dblX1 * dblY21 + dblY0 * dblY41
                        .OrgZ3d = dblZStart + dblX1 * dblZ21 + dblY0 * dblZ41
                        PolyGonPoints(1).X = .XDraw
                        PolyGonPoints(1).Y = .YDraw
                        .OrgX3d = dblXStart + dblX1 * dblX21 + dblY1 * dblX41
                        .OrgY3d = dblYStart + dblX1 * dblY21 + dblY1 * dblY41
                        .OrgZ3d = dblZStart + dblX1 * dblZ21 + dblY1 * dblZ41
                        PolyGonPoints(2).X = .XDraw
                        PolyGonPoints(2).Y = .YDraw
                        .OrgX3d = dblXStart + dblX0 * dblX21 + dblY1 * dblX41
                        .OrgY3d = dblYStart + dblX0 * dblY21 + dblY1 * dblY41
                        .OrgZ3d = dblZStart + dblX0 * dblZ21 + dblY1 * dblZ41
                        PolyGonPoints(3).X = .XDraw
                        PolyGonPoints(3).Y = .YDraw
                    End With
                    Polygon hEndResultDC, PolyGonPoints(0), 4
                    brush = SelectObject(hEndResultDC, old_brush)
                    DeleteObject brush
                Next
            Next
0
 
LVL 32

Expert Comment

by:Erick37
Comment Utility
Here is a function which draws parellograms.  It uses the Polygon API call.

Option Explicit

Private Type POINTAPI
    x As Long
    y As Long
End Type
Private Declare Function Polygon Lib "gdi32" _
    (ByVal hdc As Long, lpPoint As POINTAPI, _
    ByVal nCount As Long) As Long

Private Sub DrawParallelogram(ByVal x As Long, ByVal y As Long, _
        ByVal LineX As Long, ByVal LineY As Long, _
        ByVal Angle As Double)
    Dim pt(3) As POINTAPI
    Dim d As Double
    'convert degrees to radians
    Angle = -Angle / 180 * (4 * Atn(1))
    'Calculate the points
    pt(0).x = x
    pt(0).y = y
    d = x + (Cos(Angle) * LineX)
    pt(1).x = CLng(d)
    d = y + (Sin(Angle) * LineY)
    pt(1).y = CLng(d)
    pt(2).x = pt(1).x + LineX
    pt(2).y = pt(1).y
    pt(3).x = pt(0).x + LineX
    pt(3).y = pt(0).y
    'Draw it!
    Call Polygon(Me.hdc, pt(0), 4)
End Sub

Private Sub Form_Load()
    'Make sure Paint event fires
    Me.AutoRedraw = False
End Sub

Private Sub Form_Paint()
    Dim PrevScaleMode As Long
    Dim PrevFillColor As Long
    Dim PrevDrawStyle As Long
    'Save previous states
    PrevScaleMode = Me.ScaleMode
    PrevFillColor = Me.FillColor
    PrevDrawStyle = Me.DrawStyle
    'Change over to pixels
    ScaleMode = vbPixels
    'Set a color for the drawing
    FillColor = vbRed
    'Fill solid
    DrawStyle = vbSolid
   
    'Draw parellogram starting at x=100, y=100
    'Leg lengths are 75x, 50y
    'Angle 45 degrees
    Call DrawParallelogram(100, 100, 75, 50, 45)
   
    'Restore modes
    ScaleMode = PrevScaleMode
    FillColor = PrevFillColor
    DrawStyle = PrevDrawStyle
End Sub
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 I needed to skip over some file processing within a For...Next loop in some old production code and wished that VB (classic) had a statement that would drop down to the end of the current iteration, bypassing the statements that were c…
Introduction In a recent article (http://www.experts-exchange.com/A_7811-A-Better-Concatenate-Function.html) for the Excel community, I showed an improved version of the Excel Concatenate() function.  While writing that article I realized that no o…
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). U…
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…

763 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

15 Experts available now in Live!

Get 1:1 Help Now