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
Labels: , , , , , , ,

No comments:

Post a Comment

Subscribe to: Post Comments (Atom)