The Excel Development Platform: November 2018

Monday 19 November 2018

ATL C++ Automation Add-in gives another way to call C++ from worksheet

I discovered this by accident. I was attempting to get a C# Automation Add-in working (conceptually a very easy task but I keep hitting a barrier) and I got frustrated so I dropped down into C++ to try to get a feel for what is going on. I was surprised to find a simple ATL C++ COM component callable from the worksheet simply by adding the registry key "Programmable" to the registry entries for the COM class.

Automation Add-ins

So there have been various Office addins over the years. Microsoft keeps moving the goalposts as to what it wants developers to build to augment Excel's functionality. As I write, the latest Microsoft is pushing is JavaScript based. But years ago, Automation Add-Ins and COM Add-Ins were trendy.

An Automation Add-in allows developers to create COM components and make them callable from an Excel worksheet function with the addition of the registry key "Programmable" to the registry entries for the COM class. I must confess to associating this primarily with the .NET languages, C# and VB.Net. C++ programmers have always has the C++ Excel Software Development Kit, so I thought Automation Add-ins were pretty much was ignored by C++ developers. Certainly amongst my C++ colleagues they were overlooked.

So it was to my surprise that an ATL project is callable from the worksheet. I may very well post more examples on this. Below you will some simple code but also a video of a part of my investigations.

Incidentally, a COM Add-in goes one better than an Automation Add-in in that the developer can acquire the Application object and thus can script against the Excel COM object library. But that is not discussed in this blog post.

Simple ATL Object

So I added a single Simple ATL Object to a brand new ATL project. And then I declared the interface to have one single method called DivideBy2 for experimentation. The IDL is given here

ATLProject5.idl

// ATLProject5.idl : IDL source for ATLProject5
// Brought to you by the Excel Development Blog https://exceldevelopmentplatform.blogspot.com/2018/11/
// This file will be processed by the MIDL tool to
// produce the type library (ATLProject5.tlb) and marshalling code.
import "oaidl.idl";
import "ocidl.idl";
import "shobjidl.idl";
[
uuid(B4644DBF-2A3D-4CE7-8A01-B83AAFEBA1F2),
version(1.0)
]
library ATLProject5Lib
{
importlib("stdole2.tlb");
// Forward declare all types defined in this typelib
interface IATLSimpleObject;
[
uuid(1a4a53f8-5323-418f-8975-d05f47c1dceb),
version(1.0),
]
interface IATLSimpleObject : IDispatch
{
HRESULT DivideBy2([in]double dIn, [out,retval] double* dOut);
};
[
uuid(1ABD0403-A8D5-40F6-8D9E-E0343999CD65),
version(1.0)
]
coclass ATLSimpleObject
{
[default] interface IATLSimpleObject;
};
};

ATLSimpleObject.h

The edited class declaration is given here, in the video below I put a breakpoint in the interface map to see what gets interfaces get queried for.

// ATLSimpleObject.h : Declaration of the CATLSimpleObject
// Brought to you by the Excel Development Blog https://exceldevelopmentplatform.blogspot.com/2018/11/
using namespace ATL;
// CATLSimpleObject
class ATL_NO_VTABLE CATLSimpleObject :
public CComObjectRootEx<CComSingleThreadModel>,
public CComCoClass<CATLSimpleObject, &CLSID_ATLSimpleObject>,
public IDispatchImpl<IATLSimpleObject, &IID_IATLSimpleObject, &LIBID_ATLProject5Lib, /*wMajor =*/ 1, /*wMinor =*/ 0>
{
public:
CATLSimpleObject()
{
}
BEGIN_COM_MAP(CATLSimpleObject)
COM_INTERFACE_ENTRY(IATLSimpleObject)
COM_INTERFACE_ENTRY(IDispatch)
END_COM_MAP()
DECLARE_PROTECT_FINAL_CONSTRUCT()
HRESULT FinalConstruct()
{
return S_OK;
}
void FinalRelease()
{
}
public:
STDMETHOD(DivideBy2)(double dIn, double* dOut);
};
OBJECT_ENTRY_AUTO(__uuidof(ATLSimpleObject), CATLSimpleObject)

ATLSimpleObject.cpp

The class implementation is trivial

// ATLSimpleObject.cpp : Implementation of CATLSimpleObject
// Brought to you by the Excel Development Blog https://exceldevelopmentplatform.blogspot.com/2018/11/
#include "stdafx.h"
#include "ATLSimpleObject.h"
// CATLSimpleObject
STDMETHODIMP CATLSimpleObject::DivideBy2(double dIn, double* dOut)
{
*dOut = dIn / 2;
return S_OK;
}

Video of QueryInterface Investigation

So I discovered ATL being callable from the worksheet as I was investigating what interfaces neeed to be implemeneted. I made a video of my investigations where I set a breakpoint here...

Video Links

So there were some links in the video regarding the Sharepoint interface and the PowerBasic forum and these are given here

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

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
Private Declare Function CreateEnhMetaFileA Lib "gdi32.dll" ( _
ByVal hdcRef As Long, _
ByVal lpFileName As String, _
lpRect As RECT, _
ByVal lpDescription As String) As Long
Private Declare Function DeleteEnhMetaFile Lib "gdi32" (ByVal hemf As Long) As Long
Private Declare Function CloseEnhMetaFile Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
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 DrawUSAFlagToFile()
Dim uRect As RECT
uRect.Top = 0
uRect.Left = 0
uRect.Bottom = 10000
uRect.Right = 19000
Dim sMetaFilePath As String
sMetaFilePath = "N:\metafiles\flag1.wmf"
If Len(Dir(sMetaFilePath)) > 0 Then
Kill sMetaFilePath
End If
Dim dcDeviceContext As Long
dcDeviceContext = CreateEnhMetaFileA(0, sMetaFilePath, uRect, vbNullString)
Debug.Assert dcDeviceContext <> 0
DrawUSAFlagByGDI dcDeviceContext, 0.378
Dim lFileHandle As Long
lFileHandle = CloseEnhMetaFile(dcDeviceContext)
Call DeleteEnhMetaFile(lFileHandle)
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

Saturday 10 November 2018

VBA - Using defined name 'Me' in conditional formatting

Conditional formatting can be powerful. Here is a tip which helps writing conditional formatting functions. Often you want some format to be determined by the current cell rather than some other cell. In these cases it helps to define a named range called 'Me' which is defined in relative terms (i.e. using RC syntax) as just RC (theoretically R[0]C[0]). Then you can write formulas based on Me.

So the code below defines the name Me and then uses it to color in any cell than is non-empty, the formula is

=(LEN(Me)>0)

VBA source code

Option Explicit
Function TryItem(ByVal col As Object, ByVal sItem As String, ByRef pobjReturn As Object) As Boolean
On Error Resume Next
Set pobjReturn = col.Item(sItem)
TryItem = Not (pobjReturn Is Nothing)
End Function
Sub UsingMeInConditionalFormatting()
Dim wb As Excel.Workbook
Set wb = ThisWorkbook
Const sWorksheet As String = "Sheet1"
Dim ws As Excel.Worksheet
Set ws = wb.Worksheets(sWorksheet)
Dim objNameMe As Object
Dim namMe2 As Excel.Name
If Not TryItem(ws.Names, "Me", objNameMe) Then
'Stop
Set namMe2 = ws.Names.Add(Name:="Me", RefersToR1C1:="='" & sWorksheet & "'!RC")
Else
Set namMe2 = objNameMe
Set objNameMe = Nothing
End If
'Stop
Dim rngUsedRangeTopTenRows As Excel.Range
Set rngUsedRangeTopTenRows = ws.UsedRange.Rows("1:10")
rngUsedRangeTopTenRows.FormatConditions.Delete
Dim formatCond As FormatCondition
Set formatCond = rngUsedRangeTopTenRows.FormatConditions.Add(Type:=xlExpression, Formula1:= _
"=(Len(Me)>0)")
With formatCond.Interior
.PatternColorIndex = xlAutomatic
.Color = VBA.RGB(132, 190, 0) 'grass green
.TintAndShade = 0
End With
End Sub

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

VBA - SVG - USA Stars and Stripes

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 Function

modUSAFlagSVG 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