Showing posts with label GDI. Show all posts
Showing posts with label GDI. Show all posts

Sunday, 11 November 2018

VBA - GDI - Star and Stripes to File (Enhanced Windows MetaFile)

In this post we continue the USA flag series by giving VBA GDI code that creates a Windows MetaFile. So GDI works with device contexts, a device context could be a form, a printer or a file. This version of the code writes to a file.

modUSAFlagGDI Standard Module

In the code below a new procedure has been added, DrawUSAFlagToFile(). On line 65, you'll need to change the output path from "N:\metafiles\flag2.wmf".

New API functions have been declared CreateEnhMetaFileA(), DeleteEnhMetaFile() and CloseEnhMetaFile() to manage the meta file. CreateEnhMetaFileA() returns a device context that can be supplied to the drawing logic thus drawing to file.

You'll need the modUSAFlagSpecification module from a previous post.

modUSAFlagGDI Standard Module

  1. Option Explicit
  2.  
  3. '*
  4. '* Brought to you by the Excel Development Platform Blog
  5. '* http://exceldevelopmentplatform.blogspot.com/2018/11/
  6. '*
  7.  
  8. Private Declare Function CreatePen Lib "gdi32" _
  9.         (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
  10.  
  11. Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hDC As Long, ByVal hObject As Long) As Long
  12. Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
  13. Private Declare Function Polygon Lib "gdi32" (ByVal hDC As Long, lpPoint As POINTAPI, ByVal nCount As Long) As Long
  14. Private Declare Function Rectangle Lib "gdi32" (ByVal hDC As Long, ByVal X1 As Long, _
  15.             ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
  16.  
  17. Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hWnd As Long, ByVal hDC As Long) As Long
  18. Private Declare Function RestoreDC Lib "gdi32" (ByVal hDC As Long, ByVal nSavedDC As Long) As Long
  19.  
  20.  
  21. Private Declare Function FindWindow Lib "user32" _
  22.       Alias "FindWindowA" ( _
  23.       ByVal lpClassName As String, _
  24.       ByVal lpWindowName As String) As Long
  25.  
  26. Private Declare Function GetDC Lib "user32.dll" (ByVal hWnd As Long) As Long
  27. Private Declare Function SaveDC Lib "gdi32" (ByVal hDC As Long) As Long
  28.  
  29. Private Const PS_SOLID As Long = 0
  30.  
  31.  
  32. Private Declare Function CreateEnhMetaFileA Lib "gdi32.dll" ( _
  33.                  ByVal hdcRef As Long, _
  34.                  ByVal lpFileName As String, _
  35.                  lpRect As RECT, _
  36.                  ByVal lpDescription As String) As Long
  37.  
  38. Private Declare Function DeleteEnhMetaFile Lib "gdi32" (ByVal hemf As Long) As Long
  39.  
  40. Private Declare Function CloseEnhMetaFile Lib "gdi32" (ByVal hDC As Long) As Long
  41.  
  42. Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
  43.  
  44. Public Sub FindFormsDeviceContext(ByVal sFormCaption As String, ByRef hForm As Long, ByRef dcForm As Long, ByRef dcOldDeviceContext As Long)
  45.  
  46.     hForm = FindWindow("ThunderDFrame", sFormCaption)
  47.  
  48.     dcForm = GetDC(hForm)
  49.     dcOldDeviceContext = SaveDC(dcForm)
  50. End Sub
  51.  
  52. Public Sub ReleaseDeviceContexts(ByVal dcDeviceContext As Long, ByVal dcOldDeviceContext As Long, ByVal hForm As Long)
  53.     ReleaseDC hForm, dcDeviceContext
  54.     RestoreDC hForm, dcOldDeviceContext
  55. End Sub
  56.  
  57. Public Sub DrawUSAFlagToFile()
  58.     Dim uRect As RECT
  59.     uRect.Top = 0
  60.     uRect.Left = 0
  61.     uRect.Bottom = 10000
  62.     uRect.Right = 19000
  63.  
  64.     Dim sMetaFilePath As String
  65.     sMetaFilePath = "N:\metafiles\flag1.wmf"
  66.     If Len(Dir(sMetaFilePath)) > 0 Then
  67.         Kill sMetaFilePath
  68.     End If
  69.  
  70.     Dim dcDeviceContext As Long
  71.     dcDeviceContext = CreateEnhMetaFileA(0, sMetaFilePath, uRect, vbNullString)
  72.     Debug.Assert dcDeviceContext <> 0
  73.  
  74.     DrawUSAFlagByGDI dcDeviceContext, 0.378
  75.  
  76.     Dim lFileHandle As Long
  77.     lFileHandle = CloseEnhMetaFile(dcDeviceContext)
  78.  
  79.     Call DeleteEnhMetaFile(lFileHandle)
  80.  
  81. End Sub
  82.  
  83. Public Sub DrawUSAFlagByGDI(ByVal dcDeviceContext As Long, ByVal dScalar As Double)
  84.  
  85.     Dim auRects() As RECT
  86.  
  87.     Dim uBlue As RGB
  88.     Call modUSAFlagSpecification.GetOldGloryBlue(uBlue)
  89.  
  90.     Dim uRed As RGB
  91.     Call modUSAFlagSpecification.GetOldGloryRed(uRed)
  92.  
  93.     Dim uWhite As RGB
  94.     Call modUSAFlagSpecification.GetWhite(uWhite)
  95.  
  96.     Call modUSAFlagSpecification.BlueCanton(dScalar, auRects)
  97.     DrawRects dcDeviceContext, uBlue, auRects
  98.  
  99.     Call modUSAFlagSpecification.RedStripes(dScalar, auRects)
  100.     DrawRects dcDeviceContext, uRed, auRects
  101.  
  102.     Call modUSAFlagSpecification.WhiteStripes(dScalar, auRects)
  103.     DrawRects dcDeviceContext, uWhite, auRects
  104.  
  105.     DrawStars dcDeviceContext, dScalar
  106.  
  107. End Sub
  108.  
  109. Private Sub DrawStars(ByVal dcDeviceContext As Long, ByVal dScalar As Double)
  110.     Dim Pen As Long, OldPen As Long, Brush As Long, OldBrush As Long
  111.  
  112.     Dim auRects() As RECT
  113.     Call modUSAFlagSpecification.WhiteStars(dScalar, auRects)
  114.  
  115.     Dim uWhite As RGB
  116.     Call modUSAFlagSpecification.GetWhite(uWhite)
  117.  
  118.     Pen = CreatePen(PS_SOLID, 1, uWhite.R + (uWhite.G * 256) + (uWhite.B * 65536))
  119.     OldPen = SelectObject(dcDeviceContext, Pen)
  120.  
  121.     Brush = CreateSolidBrush(uWhite.R + (uWhite.G * 256) + (uWhite.B * 65536))
  122.     OldBrush = SelectObject(dcDeviceContext, Brush)
  123.  
  124.     Dim lStarLoop As Long
  125.     For lStarLoop = 0 To 49
  126.  
  127.         Dim uRect As RECT
  128.         uRect = auRects(lStarLoop)
  129.  
  130.         Dim auPoints() As POINTAPI, lPointCount As Long
  131.         Call modUSAFlagSpecification.FivePointedStar(dScalar, 30, uRect.Left, uRect.Top, auPoints, lPointCount)
  132.  
  133.         Call Polygon(dcDeviceContext, auPoints(0), 10)
  134.  
  135.     Next
  136.  
  137.     Call SelectObject(dcDeviceContext, OldPen)
  138.     Call SelectObject(dcDeviceContext, OldBrush)
  139.  
  140. End Sub
  141.  
  142. Private Sub DrawRects(ByVal dcDeviceContext As Long, ByRef uRGB As RGB, ByRef auRects() As RECT)
  143.  
  144.     Dim Pen As Long, OldPen As Long, Brush As Long, OldBrush As Long
  145.  
  146.     Pen = CreatePen(PS_SOLID, 1, uRGB.R + (uRGB.G * 256) + (uRGB.B * 65536))
  147.     OldPen = SelectObject(dcDeviceContext, Pen)
  148.  
  149.     Brush = CreateSolidBrush(uRGB.R + (uRGB.G * 256) + (uRGB.B * 65536))
  150.     OldBrush = SelectObject(dcDeviceContext, Brush)
  151.  
  152.     Dim lLoop As Long
  153.     For lLoop = LBound(auRects) To UBound(auRects)
  154.  
  155.         Call Rectangle(dcDeviceContext, auRects(lLoop).Left, auRects(lLoop).Top, auRects(lLoop).Right, auRects(lLoop).Bottom)
  156.  
  157.     Next lLoop
  158.  
  159.     Call SelectObject(dcDeviceContext, OldPen)
  160.     Call SelectObject(dcDeviceContext, OldBrush)
  161.  
  162. End Sub

Links

on No comments:
Labels: , , , , , , ,

Saturday, 10 November 2018

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
on No comments:
Labels: , , , , , , , ,
Subscribe to: Posts (Atom)