A popular post on this blog from a while back was some VBA code to generate an SVG of the British Flag . SVG stands for Scalable Vector Graphics and is a key part of HTML5. Here I give more VBA code to draw the national flag on the United States of America, the stars and stripes. The code for the USA flag here is more compact.
There are two code modules below. I have split the flag specifications into a separate module because I want to go on and give code that will allow the stars and stripes to be drawn onto a VBA form using the Windows GDI API. Also, because of the upcoming GDI implementation I have borrowed some GDI type definitions such as RECT and POINTAPI.
The project requires references to two libraries. Microsoft XML, v6.0 and Microsoft Scripting Runtime. This is because SVG is a type of Xml and best manipulated as an Xml document. The Scripting Runtime is there to create output files.
I won't replicate the Mozilla Developer Network (MDN) documentation on SVG because it is excellent. So only a little explanation. For more information, follow the hypertext links to MDN in the following text.
Code walkthrough
Instructions for adding the modules are given below in the sections marked modUSAFlagSpecification and modUSAFlagSVG.
To run the code, go to procedure modUSAFlagSVG.DrawUSAFlagWithSVG() and press F5
To begin, we write a root svg element to a file as this is the easiest way to get started with the processing instruction and the namespace attribute of the root element. From then on, we load and manipulate the document with standard Xml library.
We set the viewbox attribute, and a single containing graphics element. It is possible to scale using the graphics element or to directly manipulate the co-ordinates. I set the dScalar variable for to scale the flag so that it fits nicely into this web page.
Much of the stars and stripes is based on drawing rectangles. It is easy to translate the rectangle co-ordinates into d attribute path commands.
There is code generate a five pointed star for a given coordinate pair, and we call this this 50 times with unique co-ordinates to give the 50 stars. Original code to generate the stars was found at the Draw a US Flag using C# and GDI+ - The Code Project, there it is written in C#. I add value here by converting to VBA. My thanks to original author Jack J. H. Xu. It is again easy to convert the series of star point co-ordinates into a d attribute path.
modUSAFlagSpecification standard module
So in a new project add a standard module and name it 'modUSAFlagSpecification' then copy in the code below.
Option Explicit
'*
'* Brought to you by the Excel Development Platform Blog
'* http://exceldevelopmentplatform.blogspot.com/2018/11/
'*
'*
'* https://en.wikipedia.org/wiki/Flag_of_the_United_States#Specifications
'*
Private Const mlHeight As Double = 1000# '* A
Private Const mlWidth As Double = 1900# '* B
Private Const mlHoist As Double = mlHeight * 7 / 13 '* C
Private Const mlFly As Double = mlWidth * 2 / 5 '* D
Private Const mlHoistTenth As Double = mlHoist / 10 '* E,F
Private Const mlFlyTwelth As Double = mlFly / 12 '* G,H
Private Const mlStripeWidth = mlHeight / 13 '* L
Private Const mlStarDiameter = mlStripeWidth * 4 / 5 '* K
Public Type RGB
R As Long
G As Long
B As Long
End Type
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Type POINTAPI
x As Long
y As Long
End Type
Public Sub GetOldGloryRed(ByRef pURGB As RGB)
pURGB.R = &HB2 '* https://en.wikipedia.org/wiki/Flag_of_the_United_States#Colors
pURGB.G = &H22
pURGB.B = &H34
End Sub
Public Sub GetOldGloryBlue(ByRef pURGB As RGB)
pURGB.R = &H3C '* https://en.wikipedia.org/wiki/Flag_of_the_United_States#Colors
pURGB.G = &H3B
pURGB.B = &H6E
End Sub
Public Sub GetWhite(ByRef pURGB As RGB)
pURGB.R = &HFF '* https://en.wikipedia.org/wiki/Flag_of_the_United_States#Colors
pURGB.G = &HFF
pURGB.B = &HFF
End Sub
Public Sub FivePointedStar(ByVal dMultiplier As Double, ByVal dRadius As Double, _
ByVal dXCentre As Double, ByVal dYCentre As Double, _
ByRef pauPoint() As POINTAPI, ByRef plPointCount As Long)
ReDim auPoint(0 To 9) As POINTAPI
Const Pi As Double = 3.14159265358979
dRadius = dRadius * dMultiplier
'*
'* Algorithm by Jack J. H. Xu - https://www.codeproject.com/script/Membership/View.aspx?mid=3946205
'* Code Project https://www.codeproject.com/Articles/18149/Draw-a-US-Flag-using-C-and-GDI
'*
Dim dSin36 As Double, dSin72 As Double, dCos36 As Double, dCos72 As Double
dSin36 = Sin(36# * Pi / 180#)
dSin72 = Sin(72# * Pi / 180#)
dCos36 = Cos(36# * Pi / 180#)
dCos72 = Cos(72# * Pi / 180#)
Dim dInnerRadius As Double
dInnerRadius = dRadius * dCos72 / dCos36
auPoint(0).x = dXCentre
auPoint(0).y = dYCentre - dRadius
auPoint(1).x = dXCentre + dInnerRadius * dSin36
auPoint(1).y = dYCentre - dInnerRadius * dCos36
auPoint(2).x = dXCentre + dRadius * dSin72
auPoint(2).y = dYCentre - dRadius * dCos72
auPoint(3).x = dXCentre + dInnerRadius * dSin72
auPoint(3).y = dYCentre + dInnerRadius * dCos72
auPoint(4).x = dXCentre + dRadius * dSin36
auPoint(4).y = dYCentre + dRadius * dCos36
auPoint(5).x = dXCentre
auPoint(5).y = dYCentre + dInnerRadius
auPoint(6).x = dXCentre - dRadius * dSin36
auPoint(6).y = dYCentre + dRadius * dCos36
auPoint(7).x = dXCentre - dInnerRadius * dSin72
auPoint(7).y = dYCentre + dInnerRadius * dCos72
auPoint(8).x = dXCentre - dRadius * dSin72
auPoint(8).y = dYCentre - dRadius * dCos72
auPoint(9).x = dXCentre - dInnerRadius * dSin36
auPoint(9).y = dYCentre - dInnerRadius * dCos36
pauPoint = auPoint
plPointCount = 10
End Sub
Public Sub WhiteStars(ByVal dMultiplier As Double, ByRef pauRect() As RECT)
ReDim auRect(0 To 49) As RECT
Dim lLoop As Long
For lLoop = 0 To 49
Dim lMod As Long
lMod = lLoop Mod 11 '* Pattern repeats every 11 stars
Dim lBlock As Long
lBlock = lLoop \ 11
If lMod <= 5 Then
'*
'* we are in a row of six stars
'*
auRect(lLoop).Left = ((lMod * 2) + 1) * mlFlyTwelth * dMultiplier
auRect(lLoop).Right = auRect(lLoop).Left + (mlStarDiameter * dMultiplier)
auRect(lLoop).Top = (1 + lBlock * 2) * mlHoistTenth * dMultiplier
auRect(lLoop).Bottom = auRect(lLoop).Top + (mlStarDiameter * dMultiplier)
Else
'*
'* we are in a row of fives stars
'*
Dim lMod2 As Long
lMod2 = lMod Mod 6
auRect(lLoop).Left = ((lMod2 + 1) * 2) * mlFlyTwelth * dMultiplier
auRect(lLoop).Right = auRect(lLoop).Left + (mlStarDiameter * dMultiplier)
auRect(lLoop).Top = (((1 + lBlock) * 2)) * mlHoistTenth * dMultiplier
auRect(lLoop).Bottom = auRect(lLoop).Top + (mlStarDiameter * dMultiplier)
End If
Next lLoop
pauRect = auRect
End Sub
Public Sub WhiteStripes(ByVal dMultiplier As Double, ByRef pauRect() As RECT)
ReDim auRect(0 To 5) As RECT
Dim lLoop As Long
For lLoop = 0 To 5
auRect(lLoop).Left = VBA.IIf(lLoop <= 2, mlFly * dMultiplier, 0)
auRect(lLoop).Right = mlWidth * dMultiplier
auRect(lLoop).Top = mlStripeWidth * ((lLoop * 2) + 1) * dMultiplier
auRect(lLoop).Bottom = auRect(lLoop).Top + (mlStripeWidth * dMultiplier)
Next lLoop
pauRect = auRect
End Sub
Public Function RedStripes(ByVal dMultiplier As Double, ByRef pauRect() As RECT)
ReDim auRect(0 To 6) As RECT
Dim lLoop As Long
For lLoop = 0 To 6
auRect(lLoop).Left = VBA.IIf(lLoop <= 3, mlFly * dMultiplier, 0)
auRect(lLoop).Right = mlWidth * dMultiplier
auRect(lLoop).Top = mlStripeWidth * (lLoop * 2) * dMultiplier
auRect(lLoop).Bottom = auRect(lLoop).Top + (mlStripeWidth * dMultiplier)
Next lLoop
pauRect = auRect
End Function
Public Function BlueCanton(ByVal dMultiplier As Double, ByRef pauRect() As RECT)
ReDim auRect(0 To 0) As RECT
auRect(0).Left = 0
auRect(0).Top = 0
auRect(0).Right = mlFly * dMultiplier
auRect(0).Bottom = mlHoist * dMultiplier
pauRect = auRect '* copy over to return
End FunctionmodUSAFlagSVG standard module
Again, add a standard module, this time name it 'modUSAFlagSVG'. This module will call into module modUSAFlagSpecification so you should add that first. The following module also requires some libraries, Microsoft Scripting Runtime and Microsoft XML, v6.0. You will need to change the output filename.
Option Explicit
'*
'* Brought to you by the Excel Development Platform Blog
'* http://exceldevelopmentplatform.blogspot.com/2018/11/
'*
'* Tools->References: Microsoft Scripting Runtime
'* Tools->References: Microsoft XML, v6.0
'* Requires module modUSAFlagSpecification
Private Sub DrawUSAFlagWithSVG()
Dim fso As Scripting.FileSystemObject
Set fso = New Scripting.FileSystemObject
Dim sSVGPath As String
sSVGPath = "N:\StarsAndStripes.svg" '<--- change for you
Dim txtOut As Scripting.TextStream
Set txtOut = fso.CreateTextFile(sSVGPath)
txtOut.WriteLine "<?xml version=""1.0"" encoding=""UTF-8"" standalone=""no""?>"
txtOut.WriteLine "<svg:svg xmlns:svg=""http://www.w3.org/2000/svg"" />"
txtOut.Close
Set txtOut = Nothing
If fso.FileExists(sSVGPath) Then
Dim dom As MSXML2.DOMDocument60
Set dom = New MSXML2.DOMDocument60
dom.Load sSVGPath
Debug.Assert dom.parseError = 0
Dim uRed As RGB
Call modUSAFlagSpecification.GetOldGloryRed(uRed)
Dim sRed_Style As String
sRed_Style = "fill:#" & Hex$(uRed.R) & Hex$(uRed.G) & Hex$(uRed.B) & ";fill-opacity:1"
Dim uBlue As RGB
Call modUSAFlagSpecification.GetOldGloryBlue(uBlue)
Dim sBlue_Style As String
sBlue_Style = "fill:#" & Hex$(uBlue.R) & Hex$(uBlue.G) & Hex$(uBlue.B) & ";fill-opacity:1"
dom.setProperty "SelectionNamespaces", "xmlns:svg=""http://www.w3.org/2000/svg"""
Dim xmlSVG As MSXML2.IXMLDOMElement
Set xmlSVG = dom.SelectSingleNode("svg:svg")
Call xmlSVG.setAttribute("viewbox", "0 0 600 300")
'Call xmlSVG.setAttribute("width", "1200")
'Call xmlSVG.setAttribute("height", "600")
'Call xmlSVG.setAttribute("width", "210mm")
'Call xmlSVG.setAttribute("height", "297mm")
Call xmlSVG.setAttribute("version", "1.1")
Dim xmlGTranslate As MSXML2.IXMLDOMElement
Set xmlGTranslate = dom.createElement("svg:g")
Call xmlGTranslate.setAttribute("id", "TranslateToCentre")
Dim dScalar As Double
dScalar = 0.7
xmlSVG.appendChild xmlGTranslate
dom.Save sSVGPath
Dim auRects() As RECT
Call modUSAFlagSpecification.BlueCanton(dScalar, auRects)
DrawRects xmlGTranslate, "BlueCanton", sBlue_Style, auRects
Call modUSAFlagSpecification.RedStripes(dScalar, auRects)
DrawRects xmlGTranslate, "RedStripe", sRed_Style, auRects
Call modUSAFlagSpecification.WhiteStripes(dScalar, auRects)
DrawRects xmlGTranslate, "WhiteStripe", "fill:#FFFFFF;fill-opacity:1", auRects
Call modUSAFlagSpecification.WhiteStars(dScalar, auRects)
DrawStars xmlGTranslate, "WhiteStar", "fill:#FFFFFF;fill-opacity:1", auRects, dScalar
dom.Save sSVGPath
End If
End Sub
Private Sub DrawStars(ByVal xmlParentElement As MSXML2.IXMLDOMElement, ByVal sIdPrefix As String, ByVal sStyle As String, _
ByRef auRects() As RECT, ByVal dScalar As Double)
If xmlParentElement Is Nothing Then Err.Raise vbObjectError, , "#Null xmlParentElement!"
Dim dom As MSXML2.DOMDocument60
Set dom = xmlParentElement.OwnerDocument
'* This line break is purely so I can inspect the output easier
Dim xmlLineBreak As MSXML2.IXMLDOMText
Set xmlLineBreak = dom.createTextNode(vbNewLine)
Dim lStarLoop As Long
For lStarLoop = LBound(auRects) To UBound(auRects)
Dim uRect As RECT
uRect = auRects(lStarLoop)
Dim xmlStar As MSXML2.IXMLDOMElement
Set xmlStar = dom.createElement("svg:path")
Call xmlStar.setAttribute("id", sIdPrefix & lStarLoop)
Call xmlStar.setAttribute("style", sStyle)
Dim auPoints() As POINTAPI, lPointCount As Long
Call modUSAFlagSpecification.FivePointedStar(dScalar, 30, uRect.Left, uRect.Top, auPoints, lPointCount)
Dim uFirstPoint As POINTAPI, uSubsequentPointLoop As POINTAPI
uFirstPoint = auPoints(0)
Dim sPath As String
sPath = "M " & uFirstPoint.x & "," & uFirstPoint.y
Dim lPointLoop As Long
For lPointLoop = 1 To 9
uSubsequentPointLoop = auPoints(lPointLoop)
sPath = sPath & " L " & uSubsequentPointLoop.x & "," & uSubsequentPointLoop.y
Next
Call xmlStar.setAttribute("d", sPath)
xmlParentElement.appendChild xmlStar
xmlParentElement.appendChild xmlLineBreak
Next lStarLoop
End Sub
Private Sub DrawRects(ByVal xmlParentElement As MSXML2.IXMLDOMElement, ByVal sIdPrefix As String, ByVal sStyle As String, ByRef auRects() As RECT)
If xmlParentElement Is Nothing Then Err.Raise vbObjectError, , "#Null xmlParentElement!"
Dim dom As MSXML2.DOMDocument60
Set dom = xmlParentElement.OwnerDocument
'* This line break is purely so I can inspect the output easier
Dim xmlLineBreak As MSXML2.IXMLDOMText
Set xmlLineBreak = dom.createTextNode(vbNewLine)
Dim lLoop As Long
For lLoop = LBound(auRects) To UBound(auRects)
Dim uRect As RECT
uRect = auRects(lLoop)
Dim xmlRect As MSXML2.IXMLDOMElement
Set xmlRect = dom.createElement("svg:path")
Call xmlRect.setAttribute("id", sIdPrefix & lLoop)
Call xmlRect.setAttribute("style", sStyle)
Dim sPath As String
sPath = "M " & uRect.Left & "," & uRect.Top
sPath = sPath & " H " & uRect.Right
sPath = sPath & " V " & uRect.Bottom
sPath = sPath & " H " & uRect.Left
sPath = sPath & " V " & uRect.Top
Call xmlRect.setAttribute("d", sPath)
xmlParentElement.appendChild xmlRect
xmlParentElement.appendChild xmlLineBreak
Next lLoop
End Sub
No comments:
Post a Comment