VBA - GDI - USA Stars and Stripes

In the previous post I shows how to draw the stars and stripes in SVG, an HTML5 technology. But actually, I originally wanted an example of GDI code for this blog. GDI stands for Graphics Device Interface and is a venerable Windows technology for drawing.

SVG and GDI share similar approaches in that they are not pixel based images but instead a series of instructions as to how to draw the graphic. That is why I found it easy to ship a SVG version of the stars and stripes after I has originally specified the flag for GDI use. Below is a picture of the stars and stripes drawn onto a VBA form.

So the code in this blog shares the module modUSAFlagSpecification from the previous post. But you will need a userform and the gdi implementation module, modUSAFlagGDI given below.

There are plenty of GDI tutorials on the web so I won't replicate them here. This sample code should get you going and show you basic principles. Essentially, you need a "device context" which is an abstraction of a file, a printer, or a meta file. Then, given a device context, one creates pens and brushes and the draws standard shapes such as rectangles and ellipses. For non-standard shapes such as a 5 pointed star as found on USA flag one specifies an array of points and calls the Polygon() GDI function.

One pattern of note, when selecting a pen or a brush it is necessary to save the handle to the previous pen or brush and then restore them once your drawing is complete. Equally, device contexts have to be restored. So ensure you have the right tidy up code.

Also noteworthy, to get a VBA UserForm's device context it is necessary to use the Windows API FindWindow() function, specifying 'ThunderDFrame' as the class (this identifies VBA UserForms) and the userform's caption as the window text. Other development environments make finding the device context or the windows handle easier.

modUSAFlagGDI standard module

In a new project add a standard module and name it modUSAFlagGDI and copy in the following code

Option Explicit

'*
'* Brought to you by the Excel Development Platform Blog
'* http://exceldevelopmentplatform.blogspot.com/2018/11/
'*

Private Declare Function CreatePen Lib "gdi32" _
        (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long

Private Declare Function SelectObject Lib "gdi32.dll" (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 Polygon Lib "gdi32" (ByVal hDC As Long, lpPoint As POINTAPI, ByVal nCount As Long) As Long
Private Declare Function Rectangle Lib "gdi32" (ByVal hDC As Long, ByVal X1 As Long, _
            ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long

Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function RestoreDC Lib "gdi32" (ByVal hDC As Long, ByVal nSavedDC As Long) As Long


Private Declare Function FindWindow Lib "user32" _
      Alias "FindWindowA" ( _
      ByVal lpClassName As String, _
      ByVal lpWindowName As String) As Long

Private Declare Function GetDC Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function SaveDC Lib "gdi32" (ByVal hDC As Long) As Long

Private Const PS_SOLID As Long = 0

Public Sub FindFormsDeviceContext(ByVal sFormCaption As String, ByRef hForm As Long, ByRef dcForm As Long, ByRef dcOldDeviceContext As Long)

    hForm = FindWindow("ThunderDFrame", sFormCaption)

    dcForm = GetDC(hForm)
    dcOldDeviceContext = SaveDC(dcForm)
End Sub

Public Sub ReleaseDeviceContexts(ByVal dcDeviceContext As Long, ByVal dcOldDeviceContext As Long, ByVal hForm As Long)
    ReleaseDC hForm, dcDeviceContext
    RestoreDC hForm, dcOldDeviceContext
End Sub

Public Sub DrawUSAFlagByGDI(ByVal dcDeviceContext As Long, ByVal dScalar As Double)

    Dim auRects() As RECT

    Dim uBlue As RGB
    Call modUSAFlagSpecification.GetOldGloryBlue(uBlue)

    Dim uRed As RGB
    Call modUSAFlagSpecification.GetOldGloryRed(uRed)

    Dim uWhite As RGB
    Call modUSAFlagSpecification.GetWhite(uWhite)


    Call modUSAFlagSpecification.BlueCanton(dScalar, auRects)
    DrawRects dcDeviceContext, uBlue, auRects

    Call modUSAFlagSpecification.RedStripes(dScalar, auRects)
    DrawRects dcDeviceContext, uRed, auRects

    Call modUSAFlagSpecification.WhiteStripes(dScalar, auRects)
    DrawRects dcDeviceContext, uWhite, auRects

    DrawStars dcDeviceContext, dScalar

End Sub

Private Sub DrawStars(ByVal dcDeviceContext As Long, ByVal dScalar As Double)
    Dim Pen As Long, OldPen As Long, Brush As Long, OldBrush As Long

    Dim auRects() As RECT
    Call modUSAFlagSpecification.WhiteStars(dScalar, auRects)


    Dim uWhite As RGB
    Call modUSAFlagSpecification.GetWhite(uWhite)

    Pen = CreatePen(PS_SOLID, 1, uWhite.R + (uWhite.G * 256) + (uWhite.B * 65536))
    OldPen = SelectObject(dcDeviceContext, Pen)

    Brush = CreateSolidBrush(uWhite.R + (uWhite.G * 256) + (uWhite.B * 65536))
    OldBrush = SelectObject(dcDeviceContext, Brush)


    Dim lStarLoop As Long
    For lStarLoop = 0 To 49

        Dim uRect As RECT
        uRect = auRects(lStarLoop)

        Dim auPoints() As POINTAPI, lPointCount As Long
        Call modUSAFlagSpecification.FivePointedStar(dScalar, 30, uRect.Left, uRect.Top, auPoints, lPointCount)

        Call Polygon(dcDeviceContext, auPoints(0), 10)

    Next

    Call SelectObject(dcDeviceContext, OldPen)
    Call SelectObject(dcDeviceContext, OldBrush)

End Sub

Private Sub DrawRects(ByVal dcDeviceContext As Long, ByRef uRGB As RGB, ByRef auRects() As RECT)

    Dim Pen As Long, OldPen As Long, Brush As Long, OldBrush As Long

    Pen = CreatePen(PS_SOLID, 1, uRGB.R + (uRGB.G * 256) + (uRGB.B * 65536))
    OldPen = SelectObject(dcDeviceContext, Pen)

    Brush = CreateSolidBrush(uRGB.R + (uRGB.G * 256) + (uRGB.B * 65536))
    OldBrush = SelectObject(dcDeviceContext, Brush)

    Dim lLoop As Long
    For lLoop = LBound(auRects) To UBound(auRects)

        Call Rectangle(dcDeviceContext, auRects(lLoop).Left, auRects(lLoop).Top, auRects(lLoop).Right, auRects(lLoop).Bottom)

    Next lLoop

    Call SelectObject(dcDeviceContext, OldPen)
    Call SelectObject(dcDeviceContext, OldBrush)

End Sub

UserForm module

So add a new form and add a button, change the caption to Draw, do not rename. Then in the form's code copy in the code below. Run the form and press the button to draw the flag. Enjoy!

Option Explicit

'*
'* Brought to you by the Excel Development Platform Blog
'* http://exceldevelopmentplatform.blogspot.com/2018/11/
'*


Private Sub CommandButton1_Click()
    DrawFlag
End Sub

Private Sub DrawFlag()

    Dim hForm As Long, dcForm As Long, dcOldDeviceContext As Long
    FindFormsDeviceContext Me.Caption, hForm, dcForm, dcOldDeviceContext

    Dim dScalar As Double
    dScalar = 0.5

    modUSAFlagGDI.DrawUSAFlagByGDI dcForm, dScalar


    modUSAFlagGDI.ReleaseDeviceContexts dcForm, dcOldDeviceContext, hForm

End Sub