Thursday 28 December 2017

Convert Excel Table To JSON with VBA and Javascript running on ScriptControl

Today, I am reminded of a SO answer I gave some time ago which serialises an Excel table to JSON. The code is replicated below. I am reminded because it seems there is JavaScript library called SheetJS. SheetJS would require some time to evaluate to see what it is capable of, hopefully I'll blog about it soon. In the meantime, I am re-publishing the code I wrote to show that actually it is quite trivial and need not involve any VBA string operations. Instead, we leverage the JavaScript language and we call into the Excel object model (probably uses COM under the hood) to get each cell's value.

So I would pass in the range to a JavaScript function and let it iterate over the Excel object model and build the array in JavaScript. Then call a JavaScript library to convert array into a string (hat tip Douglas Crockford) and simply return the string to VBA. So no string operations in VBA.

The JavaScript function is given below but depends upon Douglas Crockford's library at https://raw.githubusercontent.com/douglascrockford/JSON-js/master/json2.js. Save this in a file and then amend VBA code with the correct file path so the JavaScript is loaded into the Microsoft Script Control.


function ExcelTableToJSON(rngTable) {
    try {
        if (rngTable && rngTable['Rows'] && rngTable['Columns']) {
            var rowCount = rngTable.Rows.Count;
            var columnCount = rngTable.Columns.Count;
            var arr = new Array();

            for (rowLoop = 1; rowLoop <= rowCount; rowLoop++) {
                arr[rowLoop - 1] = new Array();
                for (columnLoop = 1; columnLoop <= columnCount; columnLoop++) {
                    var rngCell = rngTable.Cells(rowLoop, columnLoop);
                    var cellValue = rngCell.Value2;
                    arr[rowLoop - 1][columnLoop - 1] = cellValue;
                }
            }
            return JSON.stringify(arr);
        }
        else {
            return { error: '#Either rngTable is null or does not support Rows or Columns property!' };
        }
    }
    catch(err) {
        return {error: err.message};
    }
}


Option Explicit

'In response to
'http://stackoverflow.com/questions/38100193/is-it-possible-in-vba-convert-excel-table-to-json?rq=1
'Is it possible in VBA convert Excel table to json

'Tools->References->
'Microsoft Script Control 1.0;  {0E59F1D2-1FBE-11D0-8FF2-00A0D10038BC}; C:\Windows\SysWOW64\msscript.ocx

Private Sub Test()

    Dim oScriptEngine As ScriptControl
    Set oScriptEngine = New ScriptControl
    oScriptEngine.Language = "JScript"

    oScriptEngine.AddCode GetJavaScriptLibraryFromWeb("https://raw.githubusercontent.com/douglascrockford/JSON-js/master/json2.js")

    Dim sJavascriptCode As String
    sJavascriptCode = CreateObject("Scripting.FileSystemObject").GetFile("<<<Your file path to javascript file>>>\ExcelTableToJSON.js").OpenAsTextStream.ReadAll

    oScriptEngine.AddCode sJavascriptCode

    Dim rngTable As Excel.Range
    Set rngTable = ThisWorkbook.Worksheets.Item("Sheet2").Range("A1:B2")

    rngTable.Cells(1, 1) = 1.2
    rngTable.Cells(1, 2) = "red"
    rngTable.Cells(2, 1) = True
    rngTable.Cells(2, 2) = "=2+2"


    Dim sStringified As String
    sStringified = oScriptEngine.Run("ExcelTableToJSON", rngTable)
    Debug.Assert sStringified = "[[1.2,""red""],[true,4]]"

    Stop

End Sub

Public Function GetJavaScriptLibraryFromWeb(ByVal sURL As String) As String

    Dim xHTTPRequest As Object 'MSXML2.XMLHTTP60
    Set xHTTPRequest = VBA.CreateObject("MSXML2.XMLHTTP.6.0")
    xHTTPRequest.Open "GET", sURL, False
    xHTTPRequest.send
    GetJavaScriptLibraryFromWeb = xHTTPRequest.responseText

End Function

Wednesday 27 December 2017

VBA Taking Screen Print and saving to file

So I've been pondering Screen Prints and how they work, in doing so I wondered how some VBA code would take a screen print and save to file. I found lots of fragments of code and then settled on an ideal candidate answer at StackOverflow.

But there is a bug in that code, when calling OleCreatePictureIndirect for the third parameter specify 1 (I define a constant) and not True which is -1. Otherwise, one suffers from "Out of Memory" error either immediately or eventually. Windows API True (1) is not the same as VBA's True (-1).

In addition to the bug fix there is some extra code to thrash the logic Test_ClearTestFiles() and TestMyPrintScreen()


Option Explicit

'* see - Stack Overflow - Is there a way to take a screenshot in MS-Access with vba_
'* https://stackoverflow.com/questions/2456998/is-there-a-way-to-take-a-screenshot-in-ms-access-with-vba/2457169#2457169

Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal _
  bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Private Const VK_SNAPSHOT = &H2C
Private Const VK_MENU = &H12
Private Const KEYEVENTF_KEYUP = &H2
Private Const WINAPI_TRUE As Long = 1

Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long

Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long

Private Declare Function EmptyClipboard Lib "User32.dll" () As Long

Private Declare Function CloseClipboard Lib "user32" () As Long

'https://msdn.microsoft.com/en-us/library/windows/desktop/ms694511(v=vs.85).aspx
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
(PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, _
IPic As IPicture) As Long

'\\ Declare a UDT to store a GUID for the IPicture OLE Interface
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

'\\ Declare a UDT to store the bitmap information
Private Type uPicDesc
    Size As Long
    Type As Long
    hPic As Long
    hPal As Long
    Reserved As Long '* added by S Meaden
End Type

Private Const CF_BITMAP = 2
Private Const PICTYPE_BITMAP = 1

Private Sub PrintScreen()
    keybd_event VK_SNAPSHOT, 1, 0, 0
    
    '* the old way
    'keybd_event VK_MENU, 0, 0, 0
    'keybd_event VK_SNAPSHOT, 0, 0, 0
    'keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0
    'keybd_event VK_MENU, 0, KEYEVENTF_KEYUP, 0
    
End Sub

Private Sub ClearClipboard()
    Dim lRet As Long

    lRet = OpenClipboard(0&)
    If lRet <> 0 Then lRet = EmptyClipboard
    CloseClipboard
End Sub

Private Function CreateIDispatchIID() As GUID
    ' IDispatch interface ID is defined as a GUID with
    ' the value of {00020400-0000-0000-C000-000000000046}.
    Dim IID_IDispatch As GUID
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    CreateIDispatchIID = IID_IDispatch

End Function


Private Sub Test_ClearTestFiles()
    Dim fso As Object
    Set fso = VBA.CreateObject("Scripting.FileSystemObject")

    Dim lLoop As Long
    For lLoop = 0 To 50

        Dim sFileName As String
        sFileName = "N:\Test" & lLoop & ".bmp"

        If fso.FileExists(sFileName) Then
            fso.DeleteFile sFileName
        End If
    Next lLoop

End Sub

Private Sub TestMyPrintScreen()

    Static suffix As Long
    suffix = suffix + 1

    'ClearClipboard
    MyPrintScreen "N:\test" & CStr(suffix) & ".bmp"
End Sub


Public Sub MyPrintScreen(FilePathName As String)

    Call PrintScreen

    Dim IID_IDispatch As GUID
    Dim uPicinfo As uPicDesc
    Dim IPic As IPicture
    Dim hPtr As Long

    OpenClipboard 0
    hPtr = GetClipboardData(CF_BITMAP)
    CloseClipboard

    '* Request IDispatch but it will be QueryInterfaced to IPicture by VBA runtime
    IID_IDispatch = CreateIDispatchIID

    '\\ Fill uPicInfo with necessary parts.
    With uPicinfo
        .Size = Len(uPicinfo) '\\ Length of structure.
        .Type = PICTYPE_BITMAP '\\ Type of Picture
        .hPic = hPtr '\\ Handle to image.
        .hPal = 0 '\\ Handle to palette (if bitmap).
    End With


   '\\ Create the Range Picture Object
   '* Bugfix: need WINAPI_TRUE (1) as not VBA True which is -1
   OleCreatePictureIndirect uPicinfo, IID_IDispatch, WINAPI_TRUE, IPic

    '\\ Save Picture Object
    stdole.SavePicture IPic, FilePathName

End Sub



Fake namespace! VBA MSXML2 XPath namespace looks like we need to fake a prefix for the default namespace

This is more a TODO post to myself to find a better solution to a VBA Xml programming program. Visitors are welcome to comment at the bottom if they know a better answer.

So a while ago, I had a problem with using XPath to get some elements out of an Xml Dom using VBA Xml library, MSXML2. You can see my SO question about it here. I expressed unhappiness about how we have to fake a prefix when setting the dom's SelectionNamespace.

Today a similar question arose but the twist here is that multiple namespaces have to be set. Here is my answer.

To set multiple namespaces simply space separate thus...


    dom.setProperty "SelectionNamespaces", "xmlns:sf='urn:sobject.enterprise.soap.sforce.com' xmlns:sf2='urn:enterprise.soap.sforce.com'"


(I omitted a couple of namespaces for formatting issues but you get the idea)

So I got some code working for the OP but I'd really like to find a way to not have to fake the prefix. In the source Xml note xmlns="urn:enterprise.soap.sforce.com" has no prefix but in our VBA we have to fake it with "sf2".

As a working resource I'm copying the Xml file here and the code below


<?xml version="1.0" encoding="UTF-8" ?>
<soapenv:Envelope xmlns:soapenv="http://schemas.xmlsoap.org/soap/envelope/" xmlns="urn:enterprise.soap.sforce.com" xmlns:sf="urn:sobject.enterprise.soap.sforce.com" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" >
  <soapenv:Header>
    <LimitInfoHeader>
      <limitInfo>
        <current>50</current>
        <limit>5000000</limit>
        <type>API REQUESTS</type>
      </limitInfo>
    </LimitInfoHeader>
  </soapenv:Header>
  <soapenv:Body>
    <queryResponse>
      <result>
        <done>true</done>
        <queryLocator xsi:nil="true"/>
        <records xsi:type="sf:Nodav">
          <sf:Id>a0S0E000000DMUg320</sf:Id>
          <sf:Name>Netta test 11</sf:Name>
        </records>
        <records xsi:type="sf:Nodav">
          <sf:Id>a0S0E000000DMUg321</sf:Id>
          <sf:Name>Netta test 32</sf:Name>
        </records>
        <size>2</size>
      </result>
    </queryResponse>
  </soapenv:Body>
</soapenv:Envelope>


Option Explicit


Sub TestCoreLogic()
    Dim dom As MSXML2.DOMDocument60
    Set dom = New MSXML2.DOMDocument60
    
    dom.Load "N:\xmlfile1.xml"
    Debug.Assert dom.parseError.ErrorCode = 0

    dom.setProperty "SelectionLanguage", "XPath"
    
    dom.setProperty "SelectionNamespaces", "xmlns:sf='urn:sobject.enterprise.soap.sforce.com' xmlns:sf2='urn:enterprise.soap.sforce.com' " & _
            "xmlns:soapenv='http://schemas.xmlsoap.org/soap/envelope/' xmlns:xsi='http://www.w3.org/2001/XMLSchema-instance' "
    
    CoreLogic dom
End Sub
'
Function CoreLogic(ByVal xmlDoc As MSXML2.DOMDocument60)

    Dim records As MSXML2.IXMLDOMElement
    Set records = xmlDoc.DocumentElement
    
    Dim lists As MSXML2.IXMLDOMNodeList
    
    'Debug.Assert records.SelectNodes("//soapenv:Envelope").Length = 1
    'Debug.Assert records.SelectNodes("//soapenv:Envelope/soapenv:Body").Length = 1
    'Debug.Assert records.SelectNodes("//soapenv:Envelope/soapenv:Body/sf2:queryResponse").Length = 1
    'Debug.Assert records.SelectNodes("//soapenv:Envelope/soapenv:Body/sf2:queryResponse/sf2:result").Length = 1
    '
    'Debug.Assert records.SelectNodes("//soapenv:Envelope/soapenv:Body/sf2:queryResponse/sf2:result/sf2:records").Length = 2
    'Set lists = records.SelectNodes("//soapenv:Envelope/soapenv:Body/sf2:queryResponse/sf2:result/sf2:records")
    
    Debug.Assert records.SelectNodes("//sf2:records").Length = 2
    Set lists = records.SelectNodes("//sf2:records")

    Dim listNode As MSXML2.IXMLDOMNode
    
    For Each listNode In lists
        Debug.Print "---Email---"
        
        Dim fieldNode As MSXML2.IXMLDOMNode
        For Each fieldNode In listNode.ChildNodes
            Debug.Print "[" & fieldNode.BaseName & "] = [" & fieldNode.Text & "]"
        Next fieldNode
    Next listNode

    Set records = Nothing
    Set lists = Nothing
    Set listNode = Nothing
    Set fieldNode = Nothing


End Function


Sunday 17 December 2017

WinAPI - there's a difference between Child windows and Popup windows - for controlling visibility at least

So there is currently a SO bounty where poster wants to hide all windows for a program. They launched the program using the Windows Script Host library (c:\Windows\SysWOW64\wshom.ocx). They use the Run method of the Shell object (another link). But despite specifying WshWindowStyle.WshHide, popups still appear. Because of the bounty I decided to investigate, but I started with C# (see bottom of page), then I translated my findings into VBA (see first listing ).

Firstly, a key reading resource is Windows Features which tells that all windows are created with CreateWindowEx but popups are create by specifying WS_POPUP and child windows are created by specifying WS_CHILD. So popups and child windows are different.

On the same page in the section Window Visibility it explains that we can set the visibility of a main window and the change will cascade down to all child windows but there is no mention of this cascade affecting popups.

The short answer to the investigation is that to hide popups it is required to call ShowOwnedPopups(hwnd,0). The VBA declaration is given here


Declare Function ShowOwnedPopups Lib "user32" Alias "ShowOwnedPopups" _
       (ByVal hwnd As Long, ByVal fShow As Long) As Long

And here is some final VBA code but which depends upon a simple C# demo program called VisibilityExperiment

Option Explicit

Private Declare Function ShowOwnedPopups Lib _
    "user32" (ByVal hwnd As Long, _
    ByVal fShow As Long) As Long

Private Declare Function EnumWindows _
    Lib "user32" ( _
        ByVal lpEnumFunc As Long, _
        ByVal lParam As Long) _
        As Long
        
Private Declare Function GetWindowThreadProcessId _
    Lib "user32" (ByVal hwnd As Long, lpdwprocessid As Long) As Long
    

    
Private mlPid As Long
Private mlHWnd As Variant


Private Function EnumAllWindows(ByVal hwnd As Long, ByVal lParam As Long) As Long
    
    Dim plProcID As Long
    GetWindowThreadProcessId hwnd, plProcID
    If plProcID = mlPid Then
        If IsEmpty(mlHWnd) Then
            mlHWnd = hwnd
            Debug.Print "HWnd:&" & Hex$(mlHWnd) & "  PID:&" & Hex$(mlPid) & "(" & mlPid & ")"
        End If
    End If

    EnumAllWindows = True
End Function

Private Function GetPID(ByVal sExe As String) As Long

    Static oServ As Object
    If oServ Is Nothing Then Set oServ = GetObject("winmgmts:\\.\root\cimv2")
    
    Dim cProc As Object
    Set cProc = oServ.ExecQuery("Select * from Win32_Process")
    
    Dim oProc As Object
    For Each oProc In cProc
        If oProc.Name = sExe Then
            Dim lPid As Long
            GetPID = oProc.ProcessID
        End If
    Next

End Function


Private Sub Test()
    '* Tools->References   "Windows Script Host library"

    Dim wsh As IWshRuntimeLibrary.WshShell
    Set wsh = New IWshRuntimeLibrary.WshShell

    Dim lWinStyle As WshWindowStyle
    lWinStyle = WshNormalFocus

    Dim sExe As String
    sExe = "VisibilityExperiment.exe"

    Dim sExeFullPath As String
    sExeFullPath = Environ$("USERPROFILE") & "\source\repos\VisibilityExperiment\VisibilityExperiment\bin\Debug\" & sExe

    Dim x As Long
    x = wsh.Run(sExeFullPath, lWinStyle, False)

    mlPid = GetPID(sExe)

    mlHWnd = Empty
    Call EnumWindows(AddressOf EnumAllWindows, 0)


    Stop
    Call ShowOwnedPopups(mlHWnd, 0)  '* o to hide, 1 to show

End Sub



To repeat, to hide popups one must call ShowOwnedPopups(). Sadly, I cannot see around this restriction. Even if we tried to use the Windows API directly to spawn the process there is nothing in the STARTUPINFO structure (Windows) which looks like it will help, there is nothing to specify the visibility of popups.

Here is the source code of the form to the C# program VisibilityExperiment.exe, it is a normal Windows Forms application and I have added a single button called button1,


using System;
using System.Windows.Forms;

namespace VisibilityExperiment
{
    public partial class VisibilityExperiment : Form
    {
        public VisibilityExperiment()
        {
            InitializeComponent();
        }

        private void button1_Click(object sender, EventArgs e)
        {
            MessageBox.Show("message", "caption", MessageBoxButtons.YesNo);
        }
    }
}

And here is my experiment program call VisibilityExperiment2.exe . It is again a simple WinForms Application. You run VisibilityExperiment manually and you can see the effect of calling different Windows API functions. You will see that the message box does will not be hidden unless you use ShowOwnedPopups.

Here is the form layout

.

You will have to rename the controls btnGetMainWindowHandle, btnShow, btnHide, grpShowHide, chkShowOwnedPopups, chkShowWindowAsync, chkSetWindowPos for the following form code to work...


using System;
using System.Diagnostics;
using System.Dynamic;
using System.Runtime.InteropServices;
using System.Windows.Forms;

namespace VisibilityExperiment2
{


    public partial class ShowerHider : Form
    {
        IntPtr mainWindowHandle;

        [DllImport("user32.dll")]
        static extern bool ShowWindowAsync(IntPtr hWnd, int nCmdShow);

        [DllImport("user32.dll")]
        static extern bool ShowOwnedPopups(IntPtr hWnd, int nCmdShow);

        [DllImport("user32.dll", SetLastError = true)]
        static extern bool SetWindowPos(IntPtr hWnd, IntPtr hWndInsertAfter, int X, int Y, int cx, int cy, SetWindowPosFlags uFlags);

        #region Constants

        enum SetWindowPosFlags
        {
            NOSIZE = 0x0001,
            NOMOVE = 0x0002,
            NOZORDER = 0x0004,
            NOREDRAW = 0x0008,
            NOACTIVATE = 0x0010,
            DRAWFRAME = 0x0020,
            FRAMECHANGED = 0x0020,
            SHOWWINDOW = 0x0040,
            HIDEWINDOW = 0x0080,
            NOCOPYBITS = 0x0100,
            NOOWNERZORDER = 0x0200,
            NOREPOSITION = 0x0200,
            NOSENDCHANGING = 0x0400,
            DEFERERASE = 0x2000,
            ASYNCWINDOWPOS = 0x4000
        };

        static readonly IntPtr HWND_TOPMOST = new IntPtr(-1);
        static readonly IntPtr HWND_NOTOPMOST = new IntPtr(-2);
        static readonly IntPtr HWND_TOP = new IntPtr(0);
        static readonly IntPtr HWND_BOTTOM = new IntPtr(1);

        private const int SW_HIDE = 0;
        private const int SW_SHOWNORMAL = 1;
        private const int SW_SHOW = 5;
        #endregion Constants

        public ShowerHider()
        {
            InitializeComponent();
        }



        private ExpandoObject CheckForPID()
        {
            dynamic retVal = new ExpandoObject();

            Process[] processes = Process.GetProcessesByName("VisibilityExperiment");
            if (processes.Length==0)
            {
                retVal.pid = -1;
                
            } else if (processes.Length == 1) {

                Process proc = processes[0];
                retVal.pid = proc.Id;
                retVal.hWnd = proc.MainWindowHandle;
                

            } else
            {
                retVal.pid = -2;
            }
            return retVal;
        }

        private void btnGetMainWindowHandle_Click(object sender, EventArgs e)
        {
            dynamic retVal = CheckForPID();

            if (retVal.pid>=0)
            {
                mainWindowHandle = retVal.hWnd;
                this.textBox1.Text = retVal.hWnd.ToString("X8");
                this.grpShowHide.Enabled = true;
            }

            
            
        }

        private void btnShow_Click(object sender, EventArgs e)
        {
            if (this.chkSetWindowPos.Checked == true)
            {
                SetWindowPos(mainWindowHandle, IntPtr.Zero, 0, 0, 0, 0,SetWindowPosFlags.SHOWWINDOW | 
                    SetWindowPosFlags.NOMOVE | SetWindowPosFlags.NOSIZE);
            }


            if (this.chkShowWindowAsync.Checked==true)
            { 
                ShowWindowAsync(mainWindowHandle, SW_SHOW);
                //* Need to call this twice of the first time
                //* TODO Eastablish first time versus subsequent time logic 
                ShowWindowAsync(mainWindowHandle, SW_SHOW);
            }

            if (this.chkShowOwnedPopups.Checked == true)
                ShowOwnedPopups(mainWindowHandle, 1);
        }

        private void btnHide_Click(object sender, EventArgs e)
        {

            if (this.chkSetWindowPos.Checked == true)
            {
                SetWindowPos(mainWindowHandle, IntPtr.Zero, 0, 0, 0, 0,SetWindowPosFlags.HIDEWINDOW |
                    SetWindowPosFlags.NOMOVE | SetWindowPosFlags.NOSIZE);
            }

            if (this.chkShowWindowAsync.Checked == true)
            {
                ShowWindowAsync(mainWindowHandle, SW_HIDE);
                //* Need to call this twice of the first time
                //* TODO Eastablish first time versus subsequent time logic 

                ShowWindowAsync(mainWindowHandle, SW_HIDE);
            }
            if (this.chkShowOwnedPopups.Checked == true)
                ShowOwnedPopups(mainWindowHandle, 0);



        }

        private void chkShowWindowAsync_CheckedChanged(object sender, EventArgs e)
        {

        }
    }
}



Friday 15 December 2017

Ubuntu - what do the colours in the console mean - Blue is Directory etc.

So I chanced upon a lovely Unix script which prints out a colour key in case a newbie is bamboozled by the coloured items. Copy the following in your terminal


eval $(echo "no:global default;fi:normal file;di:directory;ln:symbolic link;pi:named pipe;so:socket;do:door;bd:block device;cd:character device;or:orphan symlink;mi:missing file;su:set uid;sg:set gid;tw:sticky other writable;ow:other writable;st:sticky;ex:executable;"|sed -e 's/:/="/g; s/\;/"\n/g')           
{      
  IFS=:     
  for i in $LS_COLORS     
  do        
    echo -e "\e[${i#*=}m$( x=${i%=*}; [ "${!x}" ] && echo "${!x}" || echo "$x" )\e[m" 
  done       
} 

You will dark blue is a directory, normal file is white plus some others (run the script!)

Reproduced from Ask Ubuntu

Changing the bash prompt

So I really do not like so many colours in my bash prompt, here is an economical bash prompt that does not have colours and also does not have username and hostname.

PS1='\[\e]0;\u@\h: \w\a\]${debian_chroot:+($debian_chroot)}bash :\w\$'

To ensure this happens on each logon I changed my .bashrc file using nano. It lives in the home directory ~ and is hidden by default.

cd ~
nano .bashrc

In nano add the PS1= line to the end, then attempt to exit, it will prompt for a save before exiting to which you say yes.

If you forget your password

Thankfully there is askubuntu.com and this answer works.

Changing the Ubuntu's Window Caption

So if I am making a video I do not want my user name and hostname appearing in the bash prompt (see above) or in the Ubuntu window's title. I'm sure it is configurable but I knew how to use a Windows API call to set the window caption and this code below will suffice. It's for a C# console.

using System;
using System.Collections.Generic;
using System.Diagnostics;
using System.Runtime.InteropServices;
using System.Text;

namespace UbuntuWindowTitleRenamer
{
    class Program
    {
        [DllImport("user32.dll")]
        static extern bool SetWindowText(IntPtr hWnd, string text);

        [DllImport("user32.dll", CharSet = CharSet.Unicode, SetLastError = true)]
        static extern int GetWindowText(IntPtr hWnd, StringBuilder lpString, int nMaxCount);

        [DllImport("user32.dll", SetLastError = true, CharSet = CharSet.Auto)]
        static extern int GetWindowTextLength(IntPtr hWnd);

        static void Main(string[] args)
        {
            Process[] processes = null;
            string bashPrompt = Environment.GetEnvironmentVariable("BASH_WINDOW_TITLE_PREFIX");
            while (!Console.KeyAvailable)
            {
                processes = Process.GetProcessesByName("ubuntu");
                LoopThruProcesses(processes, bashPrompt);
                processes = Process.GetProcessesByName("bash");
                LoopThruProcesses(processes, bashPrompt);
            }
        }

        static void LoopThruProcesses(Process[] processes, string bashPrompt)
        {
            foreach (var procLoop in processes)
            {
                long ProcId = procLoop.Id;
                string hexProcId = ProcId.ToString("x8");

                {
                    List consoleWindows = Accessibility.GetConsoleWindowsByProcessId(ProcId);
                    foreach (IntPtr consoleWindow in consoleWindows)
                    {
                        int textLength = GetWindowTextLength(consoleWindow);

                        StringBuilder sb = new StringBuilder(textLength+1);
                        GetWindowText(consoleWindow, sb, sb.Capacity);

                        string windowCaption = sb.ToString();

                        if (windowCaption.StartsWith(bashPrompt))
                        {
                            string newCaption = "bash " + windowCaption.Substring(bashPrompt.Length);
                            SetWindowText(consoleWindow, newCaption);
                            Console.WriteLine("changing window caption:" + newCaption);
                        }
                    }
                }

                {
                    string originalCaption = procLoop.MainWindowTitle;
                    if (originalCaption.StartsWith(bashPrompt))
                    {
                        string newCaption = "bash " + originalCaption.Substring(bashPrompt.Length);
                        SetWindowText(procLoop.MainWindowHandle, newCaption);
                        Console.WriteLine("changing window caption:" + newCaption);
                    }
                }
            }
        }
    }

    public class Accessibility
    {
        [DllImport("user32.dll", SetLastError = true)]
        static extern IntPtr FindWindowEx(IntPtr hwndParent, IntPtr hwndChildAfter, string lpszClass, string lpszWindow);

        [DllImport("user32.dll")]
        static extern uint GetWindowThreadProcessId(IntPtr hWnd, out int processId);

        public static List GetConsoleWindowsByProcessId(long processId)
        {
            List retVal = new List();

            IntPtr hWnd = FindWindowEx(IntPtr.Zero, IntPtr.Zero, "ConsoleWindowClass", null);
            while (hWnd != IntPtr.Zero)
            {
                //Console.WriteLine("Window handle:" + hWnd.ToString("x8"));
                retVal.Add(hWnd);
                hWnd = FindWindowEx(IntPtr.Zero, hWnd, "ConsoleWindowClass", null);
            }
            return retVal;
        }
    }
}

Ubuntu (Windows Subsystem for Linux) Apache2 Configuration Overview

So Apache2 running on Ubuntu running on Windows Subsystem for Linux (WSL) on Windows 10 has a different configuration from other Apache2 installs. So there is a mismatch between documentation, if for example one is following Dedoimedo's Apache Web server Complete Guide. The config details are hiding in plain sight on the default index page that appears after a fresh install. Because we are meant to replace that page I am keeping a copy here.

Configuration Overview

Ubuntu's Apache2 default configuration is different from the upstream default configuration, and split into several files optimized for interaction with Ubuntu tools. The configuration system is fully documented in /usr/share/doc/apache2/README.Debian.gz. Refer to this for the full documentation. Documentation for the web server itself can be found by accessing the manual if the apache2-doc package was installed on this server.

The configuration layout for an Apache2 web server installation on Ubuntu systems is as follows:

/etc/apache2/
|-- apache2.conf
|       `--  ports.conf
|-- mods-enabled
|       |-- *.load
|       `-- *.conf
|-- conf-enabled
|       `-- *.conf
|-- sites-enabled
|       `-- *.conf
          
  • apache2.conf is the main configuration file. It puts the pieces together by including all remaining configuration files when starting up the web server.
  • ports.conf is always included from the main configuration file. It is used to determine the listening ports for incoming connections, and this file can be customized anytime.
  • Configuration files in the mods-enabled/, conf-enabled/ and sites-enabled/ directories contain particular configuration snippets which manage modules, global configuration fragments, or virtual host configurations, respectively.
  • They are activated by symlinking available configuration files from their respective *-available/ counterparts. These should be managed by using our helpers a2enmod, a2dismod, a2ensite, a2dissite, and a2enconf, a2disconf . See their respective man pages for detailed information.
  • The binary is called apache2. Due to the use of environment variables, in the default configuration, apache2 needs to be started/stopped with /etc/init.d/apache2 or apache2ctl. Calling /usr/bin/apache2 directly will not work with the default configuration.
Document Roots

By default, Ubuntu does not allow access through the web browser to any file apart of those located in /var/www, public_html directories (when enabled) and /usr/share (for web applications). If your site is using a web document root located elsewhere (such as in /srv) you may need to whitelist your document root directory in /etc/apache2/apache2.conf.

The default Ubuntu document root is /var/www/html. You can make your own virtual hosts under /var/www. This is different to previous releases which provides better security out of the box.

Ubuntu on WSL piping output to the host OS's drives - convert LFs to CRLFs

So continuing on the Ubuntu theme. I need to configure Apache. So I am not used to Linux because it has been a dozen years ago since I trained for certification on Linux. I still want to use my favourite Windows apps not mention the windowed environment; it takes a while to acclimatise to console culture. Specifically, whilst poking around the Linux file system, I need to find a way to pipe output of a command to a file on the host OS’s drive and then handle the line feed issue.

In Linux line feeds are one character ASC 10, whilst in Windows line feeds are in fact two, ASC 13 + ASC 10. If you don’t believe me then in VBA Immediate window try ?ASC(MID$(vbNewLine,1,1)) and then ?ASC(MID$(vbNewLine,2,1)) .

So in the Linux console a typical command would be sudo find / -name apache2.conf &> /mnt/n/findapache.txt which searches for Apache2 configuration file (it’s not where my Apache book says it should be!). The above command pipes output both stdout and stderr (hence “&>”) to /mnt/n which is where my N: drive is mounted into the unified Linux file system.

So here is some code to process the line feeds


Option Explicit

'* Tools->References->Microsoft Scripting Runtime

Sub Test()
    'ConvertLinuxLineFeedsToWindowsCRAndLineFeeds "n:\findapache.txt"
    ConvertLinuxLineFeedsToWindowsCRAndLineFeeds "n:\apache2.conf"
End Sub

Sub ConvertLinuxLineFeedsToWindowsCRAndLineFeeds(ByVal sLinuxFile As String, _
                        Optional ByVal sWindowsFile As String)

    sWindowsFile = Trim(sWindowsFile)
    If LenB(sWindowsFile) = 0 Then
        Dim vSplit As Variant
        vSplit = VBA.Split(sLinuxFile, ".")
        
        Dim lCount As Long
        lCount = UBound(vSplit)
        ReDim Preserve vSplit(0 To lCount + 1)
        vSplit(lCount + 1) = vSplit(lCount)
        vSplit(lCount) = "winLfCr"
        
        sWindowsFile = VBA.Join(vSplit, ".")
    
    End If

    Dim oFSO As New Scripting.FileSystemObject
    
    
    Debug.Assert oFSO.FileExists(sLinuxFile)
    Dim oTxtIn As Scripting.TextStream
    Set oTxtIn = oFSO.OpenTextFile(sLinuxFile)

    Dim oTxtOut As Scripting.TextStream
    Set oTxtOut = oFSO.CreateTextFile(sWindowsFile)

    While Not oTxtIn.AtEndOfStream
        Dim sLine As String
        sLine = oTxtIn.ReadLine
        Debug.Print sLine
        
        oTxtOut.WriteLine sLine
        
    Wend
    
    oTxtOut.Close
    oTxtIn.Close
    
    Set oTxtOut = Nothing
    Set oTxtIn = Nothing

End Sub


Now one can use Notepad to view the contents. Without the windows line feeds the whole file looks like it has no line breaks!

Wednesday 13 December 2017

Installing Apache into Ubuntu running on Windows Subsystem for Linux on Windows 10

Part A - Installing WSL

So in the previous post I discussed the merits of Apache and whilst installable directly onto Windows 10 there is a good case for running it on Linux. But fortunately we don't have to thanks to a new component of Windows 10 called Windows Subsystem for Linux (Wikipedia article) (hereafter WSL) which is more lightweight than a fully virtualised machine (though a VM remains an option).

Microsoft's own documentation is here. To install one can follow instruction on this web page Microsoft - Install the Linux Subsystem on Windows 10 - Microsoft Docs. However, I can supplement with some extra info and a few screenshots because not everything is spelt out and indeed some of it I didn't follow at all :) .

To install 'Windows Subsystem for Linux' one needs to go to the Control Panel->Programs and Features->Turn Windows features on or off

Taking the above update requires a reboot.

Then I opened the Windows Store. Then I searched for Ubuntu and made sure to match the one shown on the Microsoft installation web page, the correct app is published by Canonical Group Limited. Then I clicked Install and it began downloading. Ubuntu is the leading leading distribution or "Distro". Once installed I pinned to Start menu and then clicked the Launch button. A command windows opens and the installation continues

After a while I get a prompt to create a new UNIX username which I did, on the first machine I tried this there was such a long dealy I though the process had hung, but please be patient it will get there. Then it asks for a password which I entered and then confirmed. then I am dropped into a console session. Yea! Try 'cd /' and then 'ls' to see the contents of your root folder.

Part B - Installing Apache

So next we install Apache, and I followed (roughly) the instructions from Digital Ocean and at the prompt I did the following

sudo apt-get update

sudo apt-get install apache2

this completes the install. Now we start the server with

sudo /etc/init.d/apache2 start

Then in a browser naviaget to

http://127.0.0.1

and one should see the Apache2 Ubuntu Default page

By the way, to fans of Virtual Machines (VMs) who are not convinced all I can say in parting is that I had to tidy a user profile of late because it grew massive and I discovered huge VM disk images. WSL allows the native disk filing system to be mounted so there is no need for a separate disk image with WSL.

Installing Apache directly onto Windows 10

So, this blog gets many hits regarding how to use HTTP(S) and also how to parse JSON. It seems that using Excel as a web service client is quite trendy. The REST Api is an increasingly popular web service paradigm. Excel developers should seriously consider structuring their applications and solutions around a smart client GUI interacting with a middle and data tier sitting behind a web server.

In such an architecture, should we use Microsoft IIS for the web server? Well for developers running a desktop edition of Windows, e.g. Windows 10, the version of IIS is not representative of the version of IIS on a Windows Server edition but then Windows Server costs at least a thousand dollars/pounds/euros. The desktop edition will ALWAYS ship with fewer features which can be very frustrating. And there will ALWAYS be a look and feel difference between developer edition and server edition. In this blog post, we'll explore the open source alternative, Apache.

Installing Apache directly onto Windows is a cinch, the XAMPP technology stack which includes not only Apache but also MariaDB (formerly MySql), PHP and Perl. With XAMPP you even get a nice control panel applet to start and stop your server

However, there are two drawbacks with this configuration. Firstly, if you move from your computer to a web hosting company then you will still need Windows; your hosting company might be puzzled as to why after having accepted Apache you chose Windows and not Linux as the OS. Secondly, one will find that a huge amount of Apache documentation is written for a Unix implementation. At this point I will end this post because the next post shows how to install Linux-like Apache.

Sunday 10 December 2017

VBA - Using WorksheetFunction in code doesn't have to throw an error

So one can use worksheet function from code from two different points in the object model (i) Application (ii) Application.WorksheetFunction. If you use the latter any errors will throw an error which you must catch with On Error. If you want to run with the error in the same way that the worksheet does then use the former and test with IsError. Here is some code which illustrates

Option Explicit

Sub Test_Application_WorksheetFunction_VLookup()
    Dim rng As Excel.Range
    Set rng = ThisWorkbook.Sheets.Item(1).Range("A1:b3")
    
    rng.Value = Application.Evaluate("{""Red"",1;""Green"",2;""Blue"",4}")


    Debug.Assert Application.WorksheetFunction.VLookup("Red", rng.Value, 2, False) = 1
    Debug.Assert Application.WorksheetFunction.VLookup("Green", rng.Value, 2, False) = 2
    Debug.Assert Application.WorksheetFunction.VLookup("Blue", rng.Value, 2, False) = 4
    
    Dim lSavedError As Long, sSavedError As String
    On Error Resume Next
    Dim vLU As Variant
    vLU = Application.WorksheetFunction.VLookup("Yellow", rng.Value, 2, False)
    sSavedError = Err.Description
    lSavedError = Err.Number
    On Error GoTo 0

    Debug.Assert lSavedError = 1004
    Debug.Assert sSavedError = "Unable to get the VLookup property of the WorksheetFunction class"
    Debug.Assert IsEmpty(vLU)

End Sub


Sub Test_Application_VLookup()
    Dim rng As Excel.Range
    Set rng = ThisWorkbook.Sheets.Item(1).Range("A1:b3")
    
    rng.Value = Application.Evaluate("{""Red"",1;""Green"",2;""Blue"",4}")


    Debug.Assert Application.WorksheetFunction.VLookup("Red", rng.Value, 2, False) = 1
    Debug.Assert Application.WorksheetFunction.VLookup("Green", rng.Value, 2, False) = 2
    Debug.Assert Application.WorksheetFunction.VLookup("Blue", rng.Value, 2, False) = 4
    
    Dim vLU As Variant
    vLU = Application.VLookup("Yellow", rng.Value, 2, False)

    Debug.Assert Not IsEmpty(vLU)
    Debug.Assert IsError(vLU)

End Sub



C++ Internationalisation - Twelve steps to Unicode-enabling

Some great advice about ensuring Unicode...

From Developing International Applications pages 109-111, Microsoft Press:
  1. Modify your code to use generic data types.
    Determine which variables declared as char or char* are text, and not pointers to buffers or binary byte arrays. Change these types to TCHAR and TCHAR*, as defined in the Win32 file windows.h, or to _TCHAR as defined in the VC++ file tchar.h. Replace LPSTR and LPCH with LPTSTR and LPTCH. Make sure to check all local variables and return types. Using generic data types is a good transition strategy because you can compile both ANSI and Unicode versions of your program without sacrificing the readability of the code. Don't use generic data types, however, for data that will always be Unicode or always ANSI. For example, one of the string parameters of MutliByteToWideChar and WideCharToMultiByte should always be in ANSI and the other should always be in Unicode.
  2. Modify your code to use generic function prototypes.
    For example, use the C run-time call _tclen instead of strlen, and use the Win32 API GetLocaleInfo instead of GetLocaleInfoA. If you are also porting from 16 bits to 32 bits, most Win32 generic function prototypes conveniently have the same name as the corresponding Windows 3.1 API calls (TextOut is one good example). Besides, the Win32 API is documented using generic types. If you plan to use Visual C++ 2.x or higher, become familiar with the available wide-character functions so that you'll know what kind of function calls you need to change. Always use generic data types when using generic function prototypes.
  3. Surround any character or string literal with the TEXT macro. The TEXT macro conditionally places an L in front of a character literal or a string literal. The C run-time equivalents are _T and _TEXT. Be careful with escape sequence specifying a 16-bit Unicode double-quote character, not as the beginning of a Unicode string. Visual C++ 2 treats anything within L" " quotes as a multibyte string and translates it to Unicode byte by byte, based on the current locale, using mbtowc. One possible way to create a string with Unicode hex values is to create a regular string and then coerce it to a Unicode string (while paying attention to byte order).
       char foo[4] = 0x40,0x40,0x40,0x41;
       wchar_t *wfoo = (wchar_t *)foo;
  4. Create generic versions of your data structures.
    Type definitions for string or character fields in structure should resolve correctly based on the UNICODE compile-time flag. If you write your own string-handling and character-handling functions, or functions that take strings as parameters, create Unicode versions of them and define generic prototypes for them.

  5. Change your make process.
    When you want to build a Unicode version of your application, both the Win32 compile-time flag -DUNICODE and the C run-time compile-time flag -D_UNICODE must be defined.

  6. Adjust pointer arithmetic.
    Subtracting char* values yields an answer in terms of bytes; subtracting wchar_t values yields an answer in terms of 16-bit chunks. When determining the number of bytes (for example, when allocating memory), multiply by sizeof(TCHAR). When determining the number of characters from the number of bytes, divide by sizeof(TCHAR). You can also create macros for these two operations, if you prefer. C makes sure that the + + and - - operators increment and decrement by the size of the data type.

  7. Check for any code that assumes a character is always 1 byte long.
    Code that assumes a character's value is always less than 256 (for example, code that uses a character value as an index into a table of size 256) must be changed. Remember that the ASCII subset of Unicode is fully compatible with 7-bit ASCII, but be smart about where you assume that character will be limited to ASCII. Make sure your definition of NULL is 16 bits long.

  8. Add Unicode-specific code if necessary.
    In particular, add code to map data "at the boundary" to and from Unicode using the Win32 functions WideCharToMultiByte and MutliByteToWideChar, or using the C run-time functions mbtowc, mbstowcs, wctomb, and wcstombs. Boundary refers to systems such as Windows 95, to old files, or to output calls, all of which might expect or provide non-Unicode encoded characters.

  9. Add code to support special Unicode characters.
    These include Unicode character in the compatibility zone, character in the private-use zone, combining characters, and character with directionality. Other special characters include the private-use-zone non-character U+FFFF, which can be used as a sentinel, and the byte order marks U+FEFF and U+FFFE, which can serve as flags that indicate a file is stored as Unicode. The byte order marks are used to indicate whether a text stream is little-Endian or big-Endian - that is, whether the high-order byte is stored first or last. In plaintext, the line separator U+2028 marks an unconditional end of line. Inserting a paragraph separator, U+2029, between paragraphs makes it easier to lay out text at different line widths.

  10. Determine how using Unicode will affect file I/O.
    If your application will exist in both Unicode and non-Unicode variations, you'll need to consider whether you want them to share a file format. Standardizing on an 8-bit character set data file will take away some of the benefits of having a Unicode application. Having different file formats and adding a conversion layer so each version can read the other's files is another alternative. Even if you choose a Unicode file format, you might have to support reading in old non-Unicode files or saving files in non-Unicode format for backward compatibility. Also, make sure to use the correct printf-style format specifiers for Visual C++, shown here:

       Specifier printf Expects wprintf expects
       %s SBCS or MBCS Unicode
       %S Unicode SBCS or MBCS
       %hs SBCS or MBCS SBCS or MBCS
       %ls Unicode Unicode

  11. Double-check the way in which you retrieve command line arguments.
    Use the function GetCommandLine rather than the lpCmdLine parameter (an ANSI string) that is passed to WinMain. WinMain cannot accept Unicode input because it is called before a window class is registered.

  12. Debug your port by enabling your compiler's type-checking.
    Do this (using W3 on Microsoft compilers) with and without the UNICODE flag defined. Some warnings that you might be able to ignore in the ANSI world will cause problems with Unicode. If your original code compiles cleanly with type-checking turned on, it will be easier to port. The warnings will help you make sure that you are not passing the wrong data type to code that expects wide-character data types. Use the Win32 NLSAPI or equivalent C run-time calls to get character typing and sorting information. Don't try to write your own logic - your application will end up carrying very large tables!
From Microsoft Typography|Developer Information|Character sets

Friday 1 December 2017

Use MSHTML to parse local HTML file without using Internet Explorer (Microsoft HTML Object Library)

So an excellent question came up today on StackOverflow about the parsing of HTML in VBA for when Internet Explorer is unavailable.

Anyone who has done some web scraping will be familiar with creating an instance of Internet Explorer (IE) and the navigating to a web address and then once the page is ready start navigating the DOM using the 'Microsoft HTML Object Library' (MSHTML) type library. The question asks if IE is unavailable what to do. I am in the same situation for my box running Windows 10.

I had suspected it was possible to spin up an instance of MSHTML.HTMLDocument but its creation is not obvious. Thanks to the questioner for asking this now. The answer lies in the MSHTML.IHTMLDocument4.createDocumentFromUrl method. One needs a local file to work with (EDIT: actually one can put a webby url in as well!) but we have a nice tidy Windows API function called URLDownloadToFile to download a file.

This codes runs on my Windows 10 box where Microsoft Edge is running and not Internet Explorer. This is an important find and thanks to the questioner for raising it.


Option Explicit

'* Tools->Refernces Microsoft HTML Object Library


'* MSDN - URLDownloadToFile function - https://msdn.microsoft.com/en-us/library/ms775123(v=vs.85).aspx
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
        (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _
        ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Sub Test()

    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    Dim sLocalFilename As String
    sLocalFilename = Environ$("TMP") & "\urlmon.html"
    
    Dim sURL As String
    sURL = "https://stackoverflow.com/users/3607273/s-meaden"
    
    
    Dim bOk As Boolean
    bOk = (URLDownloadToFile(0, sURL, sLocalFilename, 0, 0) = 0)
    If bOk Then
        If fso.FileExists(sLocalFilename) Then
        
            '* Tools->References Microsoft HTML Object Library
            Dim oHtml4 As MSHTML.IHTMLDocument4
            Set oHtml4 = New MSHTML.HTMLDocument
            
            Dim oHtml As MSHTML.HTMLDocument
            Set oHtml = Nothing
            
            '* IHTMLDocument4.createDocumentFromUrl
            '* MSDN - IHTMLDocument4 createDocumentFromUrl method - https://msdn.microsoft.com/en-us/library/aa752523(v=vs.85).aspx
            Set oHtml = oHtml4.createDocumentFromUrl(sLocalFilename, "")
            
            '* need to wait a little whilst the document parses
            '* because it is multithreaded
            While oHtml.readyState <> "complete"
                DoEvents  '* do not comment this out it is required to break into the code if in infinite loop
            Wend
            Debug.Assert oHtml.readyState = "complete"
            

            Dim sTest As String
            sTest = Left$(oHtml.body.outerHTML, 100)
            Debug.Assert Len(Trim(sTest)) > 50  '* just testing we got a substantial block of text, feel free to delete
            
            '* this is where the page specific logic now goes, here I am getting info from a StackOverflow page
            Dim htmlAnswers As Object 'MSHTML.DispHTMLElementCollection
            Set htmlAnswers = oHtml.getElementsByClassName("answer-hyperlink")
    
            Dim lAnswerLoop As Long
            For lAnswerLoop = 0 To htmlAnswers.Length - 1
                Dim vAnswerLoop
                Set vAnswerLoop = htmlAnswers.Item(lAnswerLoop)
                Debug.Print vAnswerLoop.outerText
            
            Next
    
        End If
    End If
End Sub



Sunday 26 November 2017

Use WinAPI (Crypt32) to convert string to Base64 from VBA

Following on from previous post which used MSXML to convert a string to a binary byte array base64 encoding. Here we abolish that dependency and go straight to the Windows API, specifically the Crypt32 module. Here again we make good use of StrConv.


Option Explicit
Option Private Module

Private Declare Function CryptBinaryToString Lib "Crypt32.dll" Alias _
                        "CryptBinaryToStringW" (ByRef pbBinary As Byte, _
                        ByVal cbBinary As Long, ByVal dwFlags As Long, _
                        ByVal pszString As Long, ByRef pcchString As Long) As Long

Private Declare Function CryptStringToBinary Lib "Crypt32.dll" Alias _
                        "CryptStringToBinaryW" (ByVal pszString As Long, _
                        ByVal cchString As Long, ByVal dwFlags As Long, _
                        ByVal pbBinary As Long, ByRef pcbBinary As Long, _
                        ByRef pdwSkip As Long, ByRef pdwFlags As Long) As Long


'* Refactored from vbforums.com -
'* VB6 - Base64 Encoding -
'* http://www.vbforums.com/showthread.php?850055-VB6-Base64-Encoding
'*
'* with thanks to users  "J.A. Coutts" and "LaVolpe"

Private Sub TestBase64Encode()
    
    Dim sPlainText As String
    sPlainText = "Hello world"
    
    Dim byt() As Byte
    byt = StrConv(sPlainText, vbFromUnicode)
    Dim sEncoded As String
    sEncoded = Base64Encode(byt)
    
    Dim sAnswer As String
    sAnswer = "SGVsbG8gd29ybGQ="
    Debug.Assert Len(sEncoded) = Len(sAnswer)
    Debug.Assert sEncoded = sAnswer
    'Dim lPos
    'For lPos = 1 To Len(sEncoded)
    '    Debug.Assert Mid$(sEncoded, lPos, 1) = Mid$(sEncoded, lPos, 1)
    'Next
    
    
    Dim bytDecoded() As Byte
    bytDecoded = Base64Decode(sEncoded)
    
    Dim sDecoded As String
    sDecoded = StrConv(bytDecoded, vbUnicode)
    
    Debug.Assert sPlainText = sDecoded
    
    Stop

End Sub


Private Function Base64Encode(ByRef byt() As Byte) As String
    Const CRYPT_STRING_BASE64 As Long = 1
    Const CBS As String = "CryptBinaryToString"
    Const Routine As String = "Base64.Base64Encode"
    Dim lLen As Long
    'Determine Base64 output String length required.
    If CryptBinaryToString(byt(0), UBound(byt) + 1, CRYPT_STRING_BASE64, StrPtr(vbNullString), lLen) = 0 Then
        'RaiseEvent Error(Err.LastDllError, CBS, Routine)
        Err.Raise Err.LastDllError, CBS, Routine
        GoTo ReleaseHandles
    End If
    'Convert binary to Base64.
    Dim sBase64Buf As String
    sBase64Buf = String$(lLen - 1, Chr$(0))
    If CryptBinaryToString(byt(0), UBound(byt) + 1, CRYPT_STRING_BASE64, StrPtr(sBase64Buf), lLen) = 0 Then
        'RaiseEvent Error(Err.LastDllError, CBS, Routine)
        Err.Raise Err.LastDllError, CBS, Routine
        GoTo ReleaseHandles
    End If
    Base64Encode = Left$(sBase64Buf, lLen - 2)
ReleaseHandles:
End Function

Private Function Base64Decode(ByVal sBase64Buf As String) As Byte()
    Const CRYPT_STRING_BASE64 As Long = 1
    Const CSB As String = "CryptStringToBinary"
    Const Routine As String = "Base64.Base64Decode"
    
    Const CRYPT_STRING_NOCRLF As Long = &H40000000
    
    Dim bTmp() As Byte
    Dim lLen As Long
    Dim dwActualUsed As Long
    'Get output buffer length
    If CryptStringToBinary(StrPtr(sBase64Buf), Len(sBase64Buf), CRYPT_STRING_BASE64, StrPtr(vbNullString), lLen, 0&, dwActualUsed) = 0 Then
        'RaiseEvent Error(Err.LastDllError, CSB, Routine)
        Err.Raise Err.LastDllError, CSB, Routine
        GoTo ReleaseHandles
    End If
    'Convert Base64 to binary.
    ReDim bTmp(lLen - 1)
    If CryptStringToBinary(StrPtr(sBase64Buf), Len(sBase64Buf), CRYPT_STRING_BASE64, VarPtr(bTmp(0)), lLen, 0&, dwActualUsed) = 0 Then
        'RaiseEvent Error(Err.LastDllError, CSB, Routine)
        Err.Raise Err.LastDllError, CSB, Routine
        GoTo ReleaseHandles
    Else

        Base64Decode = bTmp
    End If
ReleaseHandles:
End Function


Use MSXML2 to encode bytes or String to Base64

So I want to be able to decode and encode a byte array to and from base64. A canonical answer is given at SO (thanks!) but it converts to and from strings; the byte array element is buried in the code. I would like the option to pass byte arrays and so I have rearranged the code to make this more explicit. Also we use StrConv instead of the ADO.Stream trick. Here is my version.


Option Explicit
Option Private Module

'* Tools->References
'* Microsoft XML, v6.0


'* External Docs
'* MSDN - How to Encode XML Data  - https://msdn.microsoft.com/en-us/library/aa468560.aspx
'* MSDN - nodeTypedValue Property - https://msdn.microsoft.com/en-us/library/ms762308(v=vs.85).aspx
'* SO - Base64 Encode String in VBScript - https://stackoverflow.com/questions/496751/base64-encode-string-in-vbscript#answer-506992

Private Sub TestBase64Encode()
    Dim sOriginal As String
    sOriginal = "Hello world"
    
    Dim sBase64 As String
    sBase64 = Base64EncodeString(sOriginal)
    
    Dim sDecoded As String
    sDecoded = Base64DecodeString(sBase64)
    
    Debug.Assert sOriginal = sDecoded

End Sub


Function Base64EncodeString(ByVal sText As String) As String
    Dim byt() As Byte
    
    byt = VBA.StrConv(sText, VbStrConv.vbFromUnicode, 1033)
    
    Base64EncodeString = Base64EncodeFromBytes(byt)
End Function



Function Base64EncodeFromBytes(ByRef byt() As Byte) As String

    Dim oXML  As MSXML2.DOMDocument60
    Set oXML = New MSXML2.DOMDocument60
    
    Dim oNode As MSXML2.IXMLDOMNode

    Set oNode = oXML.createElement("base64")
    oNode.DataType = "bin.base64"
    
    oNode.nodeTypedValue = byt
    Base64EncodeFromBytes = oNode.Text
    
    Debug.Assert TypeName(Base64EncodeFromBytes) = "String"
    Set oNode = Nothing
    Set oXML = Nothing
End Function


Function Base64DecodeString(ByVal sText As String) As String

    Dim byt() As Byte
    byt = Base64DecodeToBytes(sText)
    

    Base64DecodeString = VBA.StrConv(byt(), VbStrConv.vbUnicode, 1033)

End Function

Function Base64DecodeToBytes(ByVal sEncoded As String) As Byte()
    
    Debug.Assert TypeName(sEncoded) = "String"
    
    Dim oXML  As MSXML2.DOMDocument60
    Set oXML = New MSXML2.DOMDocument60
    
    Dim oNode As MSXML2.IXMLDOMNode
    Set oNode = oXML.createElement("base64")
    
    oNode.DataType = "bin.base64"
    oNode.Text = sEncoded
    
    Base64DecodeToBytes = oNode.nodeTypedValue
    
    Set oNode = Nothing
    Set oXML = Nothing
End Function


Friday 24 November 2017

VBScript file to unzip a zip file

My main development machine continues to have problems, it is very slow. This is quite a challenge. I need to download tools to fix but these downloads are zipped. Right-clicking and selecting Extract All now no longer works. Excel VBA and Word VBA are currently broken. So I need to unzip a file using a VBScript file. Here it is.



Extract "c:\Users\Simon\Downloads\PendMoves.zip"

Private Sub Extract (sItemName)

    Dim objFSO 'As New Scripting.FileSystemObject
    set objFSO = CreateObject("Scripting.FileSystemObject")

    if not objFSO.FileExists(sItemName) then
 Wscript.Echo  sItemName + " does not exist"
    else
     Wscript.Echo  sItemName

 dim oFile 
        set oFile = objFSO.GetFile(sItemName)
 
 

        Dim sFullItemName 'As String
        sFullItemName = objFSO.GetAbsolutePathName(sItemName)
 
 dim sName
        sName = objFSO.GetFile(sFullItemName).name 

 dim sLeafName
        sLeafName = split(sName,".")(0)

 dim sParentFolder 
 sParentFolder = oFile.ParentFolder.path

 
 dim sExtractFolder 
 sExtractFolder = objFSO.BuildPath(sParentFolder,sLeafName)

        Wscript.Echo "sParentFolder: " + sParentFolder + "   sLeafname: " + sLeafname + "  sExtractFolder:" + sExtractFolder

 dim oExtractFolder
 if not objFSO.FolderExists(sExtractFolder ) then
     dim oParentFolder 
     Set oParentFolder =  objFSO.GetFolder(sParentFolder)

     set oExtractFolder = oParentFolder.SubFolders.Add(sLeafName)

     'Wscript.Echo "created extract folder: " + sExtractFolder


        else
     'Wscript.Echo "acquiring extract folder: " + sExtractFolder             
     set oExtractFolder = objFSO.GetFolder(sExtractFolder )

        end if

 if not oExtractFolder is nothing then

     'Wscript.Echo "acquired extract folder: " + sExtractFolder       
            
            Dim oApp
            set oApp = CreateObject("Shell.Application")

            oApp.Namespace(sExtractFolder).CopyHere oApp.namespace(sItemName).items
            
            Wscript.Echo "copied to extract folder: " + sExtractFolder             

        end if



    end if

End Sub


Tuesday 21 November 2017

Patch Tuesday Nightmare - "We're sorry, but Excel has run into an error ... would you like us to repair now?"

Every Month I dread Patch Tuesday where Microsoft forces me to take updates because after the update the virus scanner runs and the whole computer is slow. This month took a nasty turn and my main development PC is running very slow for shell operations such as browsing the Control Panel (which is broken) or getting right click menu options up in Windows Explorer.

Another nasty symptom post patch is being told that "We're sorry, but Excel has run into an error that is preventing it from working correctly. Excel will need to be closed as a result. Would you like us to repair now?

Here is the dialog box screenshot

If one takes the repair Excel then works.

Nevertheless this really does contribute to the sense that this month's patch (Nov 2017) is rogue!

C'mon Microsoft don't break my computer!

Note Patch Tuesday was last week and tried rolling back some of the patches to reverse my difficulties such as the following...

Install Date LinkRestart timeResult
16/11/2017 KB4048958 Restarted 14:58 Result:Not fixed
16/11/2017 KB4041777 Restarted 16:33 Result:Not fixed
16/11/2017 KB2976978 Restarted 17:25 Result:Not fixed
15/11/2017 KB4048951 Restarted 19:33 Result:Not fixed

After rolling back the above (to no relief), today Microsoft insisted upon reinstalling. Good grief!

To run the Add or Remove Programs control panel app without browsing the Control Panel (which is broken for me) use from a command line 'control.exe appwiz.cpl'

Monday 20 November 2017

Use Shell API to VBA Script OneDrive Sync

So my computer is very slow in the Windows Explorer and I was looking to use the OneDrive (SkyDrive) to backup files. To force a synchronisation one right clicks on the OneDrive icon and selects 'Sync' but this menu is very very slow to appear to for me currently and I was wondering if it could be coded in VBA.

I found a StackOverflow answer which points to a nice JavaScript file on GitHub that uses the 'Microsoft Shell Controls and Automation' type library (albeit late binding). I have converted the code to VBA. The code gets the OneDrive folder item, and uses the Verbs method to get the list that appears when one right clicks to get context menu. To mimic pressing a menu option one calls DoIt on the Verb object.

I am curious to investigate how to add functionality to the Shell namespace now that I have discovered how to invoke such functionality. In the meantime here is some code.


Option Explicit
Option Private Module

'*Tools->References
'* Microsoft Scripting Runtime                      C:\Windows\sysWOW64\scrrun.dll
'* Microsoft Shell Controls and Automation          C:\Windows\sysWOW64\shell32.dll

Private Sub TestSyncItem()
    SyncItem ""
End Sub

Private Sub SyncItem(Optional ByVal sItemName As String)

    '* Based on https://github.com/npocmaka/batch.scripts/blob/master/hybrids/jscript/oneDriveSync.bat

    Dim objFSO As New Scripting.FileSystemObject
    Dim objShell As New Shell32.Shell  'ActiveXObject("Shell.Application");
    
    If LenB(sItemName) = 0 Then sItemName = GetOneDrivePathFromReg

    
    If objFSO.FolderExists(sItemName) Or objFSO.FileExists(sItemName) Then
    
        Dim sFullItemName As String
        sFullItemName = objFSO.GetAbsolutePathName(sItemName)
        
        Dim sNamespace As String
        sNamespace = objFSO.GetParentFolderName(sFullItemName)
        
        Dim sName As String
        sName = objFSO.GetFolder(sFullItemName).name
    
        '* Introduction to the Shell Namespace
        '* https://msdn.microsoft.com/en-us/library/windows/desktop/cc144090(v=vs.85).aspx
        Dim objFolder As Shell32.Folder
        Set objFolder = objShell.namespace(sNamespace)
        
    
        Dim objItem As Shell32.FolderItem
        Set objItem = objFolder.ParseName(sName)
        
        Dim oFolderItemVerb As Shell32.FolderItemVerb
        Set oFolderItemVerb = Nothing
        
        Dim vVerbLoop As Variant
        For Each vVerbLoop In objItem.Verbs
            If vVerbLoop.name = "Sync" Then
                Set oFolderItemVerb = vVerbLoop
                Exit For
            End If
        
        Next vVerbLoop
        If Not oFolderItemVerb Is Nothing Then
            Call oFolderItemVerb.DoIt
        
        End If
        Stop
    End If
    
End Sub

Private Function GetOneDrivePathFromReg() As String
    Const HKCU As Long = &H80000001
    
    Dim registryObject As Object
    Set registryObject = VBA.GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
             ".\root\default:StdRegProv")
    
    Dim sRet As String
    registryObject.GetStringValue HKCU, "Software\Microsoft\OneDrive", "UserFolder", sRet
    GetOneDrivePathFromReg = sRet
End Function




Tuesday 14 November 2017

Use CreateObject with CLSID (when ProgID is unavailable)

So CreateObject usually takes a ProgId which is a human language string which is then looked up in the registry. However, sometimes the ProgId is not available, only a clsid is available. In such cases, it is still possible to instantiate the class using CreateObject one uses the syntax below.


Option Explicit

Sub Test()
    
    Dim dic As Object
    'Set dic = CreateObject("Scripting.Dictionary")
    Set dic = CreateObject("new:{EE09B103-97E0-11CF-978F-00A02463E06F}")
    
    dic.Add "blue", 5
    dic.Add "red", 7
    dic.Add "green", 11

    Debug.Assert dic.Count = 3

End Sub

Friday 3 November 2017

Use VBA to shell OpenSSL console commands

I've got to ask a long and involved StackOverflow question and paste a load of code but first I'll paste it here and use this as a drafting board.

The use case is using OpenSSL on a Linux server to sign a license (plain text) file with a 384 bit Elliptic Curve Digital Server Algorithm (ECDSA), the verification of the digital signature takes place on a customer's Windows desktop OS running full (Windows) .NET Framework.

The license file and a Base 64 encoded digital signature are emailed to the customer (who is not on a shared corporate network).  The customer is running a C# written .NET Framework (Windows edition) application and verification of the the licence and digital signature unlocks paid-for features.

Now, I say Linux but the example server side code given below is not yet in a Linux scripting language.  I'm prototyping with VBA running on Windows 8, eventually I will convert over to a Linux scripting language but bear with me for the time being. 

The point is I am using OpenSSL console commands and not compiling against any OpenSSL software development kit (C++ headers etc.).

One tricky part (and perhaps is the best place to begin code review) is the digging out of the X and Y co-ordinates that form the public key from the DER file. A DER key file is a binary encoded file that uses Abstract Syntax Notation (ASN1), there are free GUI programs out there such as ASN1. Editor on the Code Project that allows easy inspection, here is a screenshot of a public key file

Luckily, OpenSSL has its own inbuilt ASN1 parser so the same details are written to the console as the following


C:\OpenSSL-Win64\bin\openssl.exe asn1parse -inform DER -in n:\ECDSA\2017-11-03T193106\ec_pubkey.der
    0:d=0  hl=2 l= 118 cons: SEQUENCE          
    2:d=1  hl=2 l=  16 cons: SEQUENCE          
    4:d=2  hl=2 l=   7 prim: OBJECT            :id-ecPublicKey
   13:d=2  hl=2 l=   5 prim: OBJECT            :secp384r1
   20:d=1  hl=2 l=  98 prim: BIT STRING        

So at offset 20 there are 98 bytes which contain the X and Y co-ordinates, at byte 20 is a tag (0x03) indicating a string is following and at byte 21 is the length, 98 (any length below 127 needs only one byte). So actually the real 98 bytes of data begin at byte 22 , so I read 100 bytes in total (98+2). At byte 22 is 0x00 which is how BIT STRINGS begin (see Point 5). At byte 23 is 0x04 which indicates that both X and Y follow which is known as uncompressed form (it is possible to give the X value and compute the Y in which case use 0x02 or 0x03). After the 0x04 comes the X and Y coordinates, 48 bytes each because 8 bits in a byte and 8*48=384.

So one digs out two (X & Y) very long hexadecimal numbers as strings. The next pain comes in creating the Xml file suitable for the C# code. The key class is C#'s ECDsaCng and the method to import is FromXmlString and it expected the file to implement standard Rfc4050. The Xml file that C#'s ECDsaCng imports requires X and Y to be in decimal and not hexadecimal so we have to write another function to convert, I translated from another language taken from another Stack Overflow question.

Here is the VBA code (there's quite a lot) and you'll need to change where it will write its working files. The two code blocks to run are EntryPoint1_RunECDSAKeyGenerationBatch_RunOnce and EntryPoint2_RunHashAndSignBatch

It should be taken as read that OpenSSL has been installed, my version is at C:\OpenSSL-Win64\



Option Explicit
Option Private Module

'******* Requires Tools->References to the following libraries
'* Microsoft ActiveX Data Objects 6.1 Library           C:\Program Files (x86)\Common Files\System\ado\msado15.dll
'* Microsoft Scripting Runtime                          C:\Windows\SysWOW64\scrrun.dll
'* Microsoft XML, v.6.0                                 C:\Windows\SysWOW64\msxml6.dll
'* Windows Script HostObject Model                      C:\Windows\SysWOW64\wshom.ocx
'* Microsoft VBScript Regular Expressions 5.5           C:\Windows\SysWOW64\vbscript.dll\3
'* Microsoft Script Control 1.0                         C:\Windows\SysWOW64\msscript.ocx

Private fso As New Scripting.FileSystemObject
Private Const sOPENSSL_BIN As String = "C:\OpenSSL-Win64\bin\openssl.exe"  '* installation for OpenSSL
Private msBatchDir As Variant '* hold over so we can sign multiple times

Private Property Get BatchDir() As String
    '* the point of this property procedure is to interpret the contents of
    '* the module level variable msBatchDir, which is a Variant and which
    '* when empty signals not yet set.  If not yet set then we return a default
    '* for testing convenience

    If IsEmpty(msBatchDir) Then
        '* place your favourite default here
        msBatchDir = "n:\ECDSA\2017-11-05T225657\"
    End If
    BatchDir = msBatchDir
End Property

Private Sub TestLoop()

    Dim l
    For l = 1 To 3
        EntryPoint1_RunECDSAKeyGenerationBatch_RunOnce
        EntryPoint2_RunHashAndSignBatch
    Next l

End Sub


'* KEY ENTRY POINT 1 OF 2
Private Sub EntryPoint1_RunECDSAKeyGenerationBatch_RunOnce()
    '* Notes:
    '* during development I felt it convenient to start afresh whilst
    '* experimenting with different flags.  The best way to start afresh I
    '* found was to give myself a new directory for each run
    '* so here you'll find we create a directory based on timestamp
    


    '* you'll need to change this and create your own folder
    Const sROOT_DIRECTORY As String = "n:\ECDSA\"
    
    '* create a timestamped and thus unique folder to do our work in
    msBatchDir = sROOT_DIRECTORY & Format(Now(), "yyyy-MM-ddTHHnnss")
    Debug.Print "Creating batch directory :" & msBatchDir
    
    '* zap anything previous (unlikely)
    If fso.FolderExists(msBatchDir) Then fso.DeleteFolder msBatchDir
    fso.CreateFolder msBatchDir
    
    Dim bReturn As Boolean
    bReturn = RunECDSAKeyGenerationBatch_RunOnce(msBatchDir)
    
    
End Sub

'* KEY ENTRY POINT 2 OF 2
Private Sub EntryPoint2_RunHashAndSignBatch()
    
    '* using the same folder as the license key creation logic
    Dim sBatchDir As String
    sBatchDir = BatchDir()
    
    Dim sSignableFile As String
    sSignableFile = fso.BuildPath(sBatchDir, "license.txt")
    
    
    
    '* we write a trivial 5 bytes to a file
    '* as a simple substitute for our license file
    Dim bReturn As Boolean
    
    If Not True Then
        bReturn = WriteStringToFile("Hello World", sSignableFile)
    
    Else
        Dim sRandomText As String
        sRandomText = RandomText2
        
        Debug.Print sRandomText
        bReturn = WriteStringToFile(sRandomText, sSignableFile)
    
    End If
    

    If bReturn Then
    
        '* we need a file to contain bothe private and public keys
        '* this will live on the server
        Dim sKeyFile As String
        sKeyFile = fso.BuildPath(sBatchDir, "ec_key.pem")
    
        '* we need a file that contains only the public keys
        '* so we can distribute to customers for digital
        '* signature verification
        Dim sPublicKeyFile As String
        sPublicKeyFile = fso.BuildPath(sBatchDir, "ec_pubkey.pem")
    
        '* hash file was for debugging, not stricly necessary
        Dim sHashFile As String
        sHashFile = fso.BuildPath(sBatchDir, "license.sha256")
    
        '* the binary version of the license signature
        '* this is an interim file because not good for emails
        Dim sSignatureFile As String
        sSignatureFile = fso.BuildPath(sBatchDir, "license.sig")
    
        '* this base 64 version of license.sig allows contents to be pasted into
        '* an email.
        Dim sSignatureFileBase64 As String
        sSignatureFileBase64 = fso.BuildPath(sBatchDir, "license.sigb64")
    
    
    
        bReturn = RunHashAndSignBatch(sKeyFile, sPublicKeyFile, sSignableFile, sHashFile, sSignatureFile, sSignatureFileBase64)
    
        Debug.Assert bReturn
        
        RunCSharp "", "", ""
        
    End If
End Sub

Private Function RandomText2() As String
    
    'http://www.randomtext.me/api/
    Dim oXHR As MSXML2.XMLHTTP60
    Set oXHR = New MSXML2.XMLHTTP60
    
    'oXHR.Open "GET", "http://www.randomtext.me/api/"
    oXHR.Open "GET", "http://www.randomtext.me/api/gibberish/p-5/25-45"
    '#
    oXHR.send
    
    Dim oParseJSON As Object
    Set oParseJSON = ParseJSON(oXHR.responseText)
    
    RandomText2 = VBA.CallByName(oParseJSON, "text_out", VbGet)
    
End Function

Function ParseJSON(ByVal sJSON As String) As Object

    '* Tools->References->Microsoft Script Control 1.0   (msscript.ocx)
    Static oScriptControl As MSScriptControl.ScriptControl
    If oScriptControl Is Nothing Then
        Set oScriptControl = New MSScriptControl.ScriptControl
        oScriptControl.Language = "javascript"
    End If
    
    Dim oParsed As Object
    Set ParseJSON = oScriptControl.Eval("(" & sJSON & ")")
End Function


Private Function RunECDSAKeyGenerationBatch_RunOnce(ByVal sBatchDir As String) As Boolean

    '* generates paths for all our files
    Dim sECDSA_KEYFILE As String
    sECDSA_KEYFILE = fso.BuildPath(sBatchDir, "ec_key.pem")
    
    '* this is a pretty print file for debugging where
    '* OpenSSL outputs in a hexadecimal
    Dim sECDSA_KEYFILE_Text As String
    sECDSA_KEYFILE_Text = fso.BuildPath(sBatchDir, "ec_key.txt")
    
    '* the PEM files is in a text format cut and pastable into an email
    Dim sECDSA_PublicKeyPemFile As String
    sECDSA_PublicKeyPemFile = fso.BuildPath(sBatchDir, "ec_pubkey.pem")
    
    '* the DER file is required for debugging verification on the server
    '* and not strictly required for production
    Dim sECDSA_PublicKeyDerFile As String
    sECDSA_PublicKeyDerFile = fso.BuildPath(sBatchDir, "ec_pubkey.der")
    
    '* generate the keys by calling shelling subroutine
    Dim bReturn As Boolean
    bReturn = OpenSSL_GenECDSAKeys(sECDSA_KEYFILE, sECDSA_PublicKeyDerFile, sECDSA_PublicKeyPemFile)

    If bReturn Then

        '* only for debugging do we output the private key in plain text
        If Len(Trim(sECDSA_KEYFILE_Text)) > 0 Then
            
            '* for debugging generate the text "pretty print"
            OpenSSL_PrettyPrintKey sECDSA_KEYFILE, sECDSA_KEYFILE_Text
        End If

        '* The ECDsaCng C# class has a FromXmlString import method
        '* which consumes an Xml file conforming to standard Rfc4050
        Dim sECDSA_XmlExport As String
        sECDSA_XmlExport = fso.BuildPath(sBatchDir, "ec_pubkey.xml")
        
        bReturn = ExportECDSAToXml(sECDSA_PublicKeyDerFile, sECDSA_XmlExport)


    End If
    RunECDSAKeyGenerationBatch_RunOnce = bReturn
End Function



Private Function RunHashAndSignBatch(ByVal sKeyFile As String, ByVal sPublicKeyFile As String, ByVal sSignableFile As String, _
                                    ByVal sHashFile As String, ByVal sSignatureFile As String, ByVal sSignatureFileBase64 As String) As Boolean
    
    '* the hash is for debugging, not strictly necessary
    Dim bReturn As Boolean
    bReturn = OpenSSL_Hash(sKeyFile, sSignableFile, sHashFile)
    

    If bReturn Then
        '* we really need the base64 signature so we can cut and paste
        '* contents into an email
        bReturn = OpenSSL_SignDigest(sKeyFile, sSignableFile, sSignatureFile, sSignatureFileBase64)
    
    
        If bReturn Then
            '* as a debugging/sanity check we verify the signature
            bReturn = OpenSSL_VerifySignature(sPublicKeyFile, sSignatureFile, sSignableFile)
        
        End If
    
    
    End If

    RunHashAndSignBatch = bReturn
End Function




Private Function OpenSSL_PrettyPrintKey(ByVal sEcdsaKeyFile As String, _
                                    ByVal sEcdsaPrettyPrintFile As String) As Boolean
                                    
    '* ordinarily OpenSSL spits out a binary file but if yopu want to inspect the contents
    '* in a text file viewer then use this routine to create a viewable file
    
    '* sample output ...
    
    'Private-Key: (384 bit)
    'priv:
    '    54:ba:af:0d:dd:65:15:96:c6:33:ad:c8:2e:b5:3f:
    '    d3:c4:80:59:d3:50:9d:81:71:ea:bd:49:b5:14:cc:
    '    6a:e2:d9:43:1f:48:d9:35:ec:00:fa:5d:71:be:7a:
    '    c6:0a:a7
    'pub:
    '    04:1b:aa:e5:53:22:cd:d0:d7:da:fd:da:35:46:5a:
    '    ed:d3:0c:b3:6c:04:ad:69:3a:a3:3e:3a:47:ea:1e:
    '    9a:ca:9d:5b:7a:7d:29:f3:84:bd:b2:df:d4:79:de:
    '    8e:e7:1b:68:b7:61:b7:32:54:78:ef:5f:9b:8c:4f:
    '    a3:73:50:cf:1b:90:7c:2e:cf:24:5e:aa:54:ad:19:
    '    82:b6:26:f3:86:df:b6:d4:4a:45:01:02:76:fc:44:
    '    86:58:ee:eb:6d:f3:db
    'ASN1 OID: secp384r1
    'NIST CURVE: P -384
                                    
                                    
                                    
    Debug.Assert fso.FileExists(sOPENSSL_BIN)
    Debug.Assert fso.FileExists(sEcdsaKeyFile)
    
    If fso.FileExists(sEcdsaPrettyPrintFile) Then fso.DeleteFile sEcdsaPrettyPrintFile
    Debug.Assert Not fso.FileExists(sEcdsaPrettyPrintFile)
    
    Dim sPrettyPrintKeyCmd As String
    sPrettyPrintKeyCmd = sOPENSSL_BIN & " ec -noout -text -in " & sEcdsaKeyFile & " -out " & sEcdsaPrettyPrintFile
    
    Dim ePrettyPrintKeyStatus As WshExecStatus, sPrettyPrintKeyStdOut As String, sPrettyPrintKeyStdErr As String
    ePrettyPrintKeyStatus = RunShellAndWait(sPrettyPrintKeyCmd, sPrettyPrintKeyStdOut, sPrettyPrintKeyStdErr)
    
    If ePrettyPrintKeyStatus = WshFailed Then
        Debug.Print sPrettyPrintKeyStdErr
    Else
        Debug.Print sPrettyPrintKeyStdOut
        Debug.Assert fso.FileExists(sEcdsaPrettyPrintFile)
        Debug.Print fso.OpenTextFile(sEcdsaPrettyPrintFile).ReadAll
        OpenSSL_PrettyPrintKey = True
    End If
        'Stop
    
    

End Function

'

Private Function RunCSharp(ByVal sEcdsaKeyFile As String, _
                                    ByVal sEcdsaPublicKeyDerFile As String, _
                                    ByVal sEcdsaPublicKeyPemFile As String) As Boolean

    '* this routine generates the key pair (private and public) file which resides on
    '* the server and also the public key only file (in two formats here for debugging)
    Const sCSHARP As String = "C:\Users\Simon\Documents\Visual Studio 2017\Projects\ECDSAVerifySignature\ECDSAVerifySignature\bin\Debug\ECDSAVerifySignature.exe"
    Debug.Assert fso.FileExists(sCSHARP)
    
    Dim sBatchDir As String
    sBatchDir = BatchDir()
    Debug.Assert fso.FolderExists(sBatchDir)

    Dim sWinFile As String
    sWinFile = fso.BuildPath(sBatchDir, "win.txt")
    
    If fso.FileExists(sWinFile) Then fso.DeleteFile sWinFile
    Debug.Assert Not fso.FileExists(sWinFile)

    Dim sCSharpCmd As String
    sCSharpCmd = sCSHARP & " " & sBatchDir

    Dim eCSharpStatus As WshExecStatus, sCSharpStdOut As String, sCSharpStdErr As String
    eCSharpStatus = RunShellAndWait(sCSharpCmd, sCSharpStdOut, sCSharpStdErr)
    
    If eCSharpStatus = WshFailed Then
        Debug.Print sCSharpStdErr
    Else
        Debug.Print sCSharpStdOut
        'Debug.Assert fso.FileExists(sWinFile)
    End If

End Function


Private Function OpenSSL_GenECDSAKeys(ByVal sEcdsaKeyFile As String, _
                                    ByVal sEcdsaPublicKeyDerFile As String, _
                                    ByVal sEcdsaPublicKeyPemFile As String) As Boolean

    '* this routine generates the key pair (private and public) file which resides on
    '* the server and also the public key only file (in two formats here for debugging)

    Debug.Assert fso.FileExists(sOPENSSL_BIN)

    If fso.FileExists(sEcdsaKeyFile) Then fso.DeleteFile sEcdsaKeyFile
    Debug.Assert Not fso.FileExists(sEcdsaKeyFile)

    Dim sGenKeyCmd As String
    sGenKeyCmd = sOPENSSL_BIN & " ecparam -genkey -name secp384r1 -out " & sEcdsaKeyFile

    Dim eGenKeyStatus As WshExecStatus, sGenKeyStdOut As String, sGenKeyStdErr As String
    eGenKeyStatus = RunShellAndWait(sGenKeyCmd, sGenKeyStdOut, sGenKeyStdErr)
    
    If eGenKeyStatus = WshFailed Then
        Debug.Print sGenKeyStdErr
    Else
        Debug.Print sGenKeyStdOut
        Debug.Assert fso.FileExists(sEcdsaKeyFile)
        'Stop
    
        If fso.FileExists(sEcdsaPublicKeyDerFile) Then fso.DeleteFile sEcdsaPublicKeyDerFile
        Debug.Assert Not fso.FileExists(sEcdsaPublicKeyDerFile)
    
        Dim sPublicKeyDerCmd As String
        sPublicKeyDerCmd = sOPENSSL_BIN & " ec -pubout -outform DER -in " & sEcdsaKeyFile & " -out " & sEcdsaPublicKeyDerFile
    
        Dim ePublicKeyDerStatus As WshExecStatus, sPublicKeyDerStdOut As String, sPublicKeyDerStdErr As String
        ePublicKeyDerStatus = RunShellAndWait(sPublicKeyDerCmd, sPublicKeyDerStdOut, sPublicKeyDerStdErr)
        Debug.Assert Len(Trim(sPublicKeyDerStdErr))
        Debug.Assert fso.FileExists(sEcdsaPublicKeyDerFile)
    
    
    
        Dim sPublicKeyPemCmd As String
        sPublicKeyPemCmd = sOPENSSL_BIN & " ec -pubout -outform PEM -in " & sEcdsaKeyFile & " -out " & sEcdsaPublicKeyPemFile
    
        Dim ePublicKeyPemStatus As WshExecStatus, sPublicKeyPemStdOut As String, sPublicKeyPemStdErr As String
        ePublicKeyPemStatus = RunShellAndWait(sPublicKeyPemCmd, sPublicKeyPemStdOut, sPublicKeyPemStdErr)
        Debug.Assert Len(Trim(sPublicKeyPemStdErr))
        Debug.Assert fso.FileExists(sEcdsaPublicKeyPemFile)
        
        If ePublicKeyPemStatus = WshFailed Then
            Debug.Print sPublicKeyPemStdErr
        Else
            Debug.Print sPublicKeyPemStdOut
            Debug.Assert fso.FileExists(sEcdsaPublicKeyDerFile)
            Debug.Assert fso.FileExists(sEcdsaPublicKeyPemFile)
            OpenSSL_GenECDSAKeys = True
        End If
    End If

End Function

Private Function OpenSSL_Hash(ByVal sEcdsaKeyFile As String, _
                                    ByVal sFileToSign As String, _
                                    ByVal sHashFile As String) As Boolean
    '* this generates a hash file, I needed this because I'm trying to diagnose
    '* a problem with some C# code which also hashes some bytes
                                    
    Debug.Assert fso.FileExists(sFileToSign)
    Debug.Assert fso.FileExists(sEcdsaKeyFile)
    Debug.Assert fso.FileExists(sOPENSSL_BIN)

    If fso.FileExists(sHashFile) Then fso.DeleteFile sHashFile
    Debug.Assert Not fso.FileExists(sHashFile)

    Dim sHashCmd As String
    sHashCmd = sOPENSSL_BIN & " dgst -sha256 -out " & sHashFile & " " & sFileToSign
    Dim eHashStatus As WshExecStatus, sHashStdOut As String, sHashStdErr As String
    eHashStatus = RunShellAndWait(sHashCmd, sHashStdOut, sHashStdErr)
    
    If eHashStatus = WshFailed Then
        Debug.Print sHashStdErr
    Else
    
        Debug.Print sHashStdOut
        Debug.Assert fso.FileExists(sHashFile)
        
        Debug.Print fso.OpenTextFile(sHashFile).ReadAll
        
        OpenSSL_Hash = True
        
    End If

End Function


Private Function OpenSSL_SignDigest(ByVal sEcdsaKeyFile As String, _
                                    ByVal sFileToSign As String, _
                                    ByVal sSignatureFile As String, _
                                    ByVal sSignatureFileBase64 As String) As Boolean

    '* this code takes a signable file, hashes it to a digest and then signs the digest
    '* further, it creates a base 64 version of the signature file the contents
    '* of which can be cut and pasted into an email.

    Debug.Assert fso.FileExists(sFileToSign)
    Debug.Assert fso.FileExists(sEcdsaKeyFile)
    Debug.Assert fso.FileExists(sOPENSSL_BIN)

    If fso.FileExists(sSignatureFile) Then fso.DeleteFile sSignatureFile
    Debug.Assert Not fso.FileExists(sSignatureFile)

    Dim sSignCmd As String
    sSignCmd = sOPENSSL_BIN & " dgst -sha256 -sign " & sEcdsaKeyFile & " -out " & sSignatureFile & " " & sFileToSign
    Dim eSignStatus As WshExecStatus, sSignStdOut As String, sSignStdErr As String
    eSignStatus = RunShellAndWait(sSignCmd, sSignStdOut, sSignStdErr)
    
    If eSignStatus = WshFailed Then
        Debug.Print sSignStdErr
    Else
        Debug.Print sSignStdOut
        Debug.Assert fso.FileExists(sSignatureFile)
        'OpenSSL_SignDigest = True
        
        Dim sEditedSignatureFile As String
        sEditedSignatureFile = VBA.Replace(sSignatureFile, ".sig", ".siged")
        
        ExtractSignatureFromDerFile sSignatureFile, sEditedSignatureFile
        Debug.Assert fso.FileExists(sEditedSignatureFile)
        
        Dim sBase64Cmd As String
        sBase64Cmd = sOPENSSL_BIN & " base64 -in " & sEditedSignatureFile & " -out " & sSignatureFileBase64

        Dim eBase64Status As WshExecStatus, sBase64StdOut As String, sBase64StdErr As String
        eBase64Status = RunShellAndWait(sBase64Cmd, sBase64StdOut, sBase64StdErr)

        If eBase64Status = WshFailed Then
            Debug.Print sBase64StdErr
        Else
            Debug.Print sBase64StdOut
            Debug.Assert fso.FileExists(sSignatureFileBase64)

            OpenSSL_SignDigest = True
        End If
        
    End If

End Function



Private Function OpenSSL_VerifySignature(ByVal sEcdsaKeyFile As String, _
                                        ByVal sSignatureFile As String, _
                                        ByVal sFileToSign As String) As Boolean
    '* this was for debugging only because I'm trying to diagnose a C#
    '* problem and was wondering if I was calling the OpenSSL commands wrong.
                                        
    Debug.Assert fso.FileExists(sSignatureFile)
    Debug.Assert fso.FileExists(sEcdsaKeyFile)
    Debug.Assert fso.FileExists(sFileToSign)
    
    
    Dim sVerifyCmd As String
    sVerifyCmd = sOPENSSL_BIN & " dgst -sha256 -verify " & sEcdsaKeyFile & " -signature " & sSignatureFile & " " & sFileToSign
    
    Dim eVerifyStatus As WshExecStatus, sVerifyStdOut As String, sVerifyStdErr As String
    eVerifyStatus = RunShellAndWait(sVerifyCmd, sVerifyStdOut, sVerifyStdErr)
    
    If StrComp(Left$(sVerifyStdOut, 11), "Verified OK") = 0 Then
        Debug.Print "Verification success"
    Else
        Debug.Print "Verification failed"
        Debug.Print "err:" & sVerifyStdErr
    End If
    
    OpenSSL_VerifySignature = True
    
End Function





Private Function RunShellAndWait(ByVal sCmdLine As String, _
                                ByRef psStdOut As String, _
                                ByRef psStdErr As String) As IWshRuntimeLibrary.WshExecStatus
    
    '* This is a better Shell routine than the in built VBA.Shell function as it allows up
    '* to easily capture the standard out and standard error pipes which is essential
    '* for console commands
    
    Static oShell As IWshRuntimeLibrary.WshShell
    If oShell Is Nothing Then
        Set oShell = New IWshRuntimeLibrary.WshShell
    End If
    
    Debug.Print sCmdLine
    Dim oExec As IWshRuntimeLibrary.WshExec
    Set oExec = oShell.Exec(sCmdLine)

    While oExec.Status = WshRunning
        DoEvents
    Wend
    
    psStdOut = oExec.StdOut.ReadAll
    psStdErr = oExec.StdErr.ReadAll

    RunShellAndWait = oExec.Status
    Set oExec = Nothing
End Function


Private Function RegExpOffsetAndLengthFromASN1Parse(ByVal sLine As String, ByRef plOffset As Long, ByRef plLength As Long) As Boolean

    '* use regular expressions to dig out numbers from ASN1 parse results
    '* if always using 384 bit then we always be 20 and 98
    '* but for future use we may use 512 bit or a change of curve etc.

    Dim oRE As VBScript_RegExp_55.RegExp
    Set oRE = New VBScript_RegExp_55.RegExp
    oRE.Pattern = "(\d.):d=1  hl=2 l=  (\d.) prim: BIT STRING"
    Debug.Assert oRE.Test("20:d=1  hl=2 l=  98 prim: BIT STRING")  '* should always be this but for future use ....
    
    Dim oMatchCol As VBScript_RegExp_55.MatchCollection
    Set oMatchCol = oRE.Execute(sLine)
    
    Dim oMatch As VBScript_RegExp_55.Match
    Set oMatch = oMatchCol.Item(0)
    
    plOffset = oMatch.SubMatches(0)
    plLength = oMatch.SubMatches(1)
    
    RegExpOffsetAndLengthFromASN1Parse = True
End Function


Private Sub TestExtractSignatureFromDerFile()
    Dim sSigFile As String
    sSigFile = "N:\ecdsa\2017-11-05T225657\license.sig"
    Debug.Assert fso.FileExists(sSigFile)
    
    Dim sSigFileEd As String
    sSigFileEd = "N:\ecdsa\2017-11-05T225657\license.siged"
    
    ExtractSignatureFromDerFile sSigFile, sSigFileEd

End Sub

Private Function ExtractSignatureFromDerFile(ByVal sSignatureFile As String, ByVal sEditedSignatureFile As String)

    Dim sASN1ParseSigCmd As String
    sASN1ParseSigCmd = sOPENSSL_BIN & " asn1parse -inform DER -in " & sSignatureFile

    Dim eASN1ParseSigStatus As WshExecStatus, sASN1ParseSigStdOut As String, sASN1ParseSigStdErr As String
    eASN1ParseSigStatus = RunShellAndWait(sASN1ParseSigCmd, sASN1ParseSigStdOut, sASN1ParseSigStdErr)
    Debug.Print sASN1ParseSigStdOut


    Dim vOutputSplit As Variant
    vOutputSplit = VBA.Split(sASN1ParseSigStdOut, vbNewLine)
    
    '* remove the traling blank line
    If Trim(vOutputSplit(UBound(vOutputSplit))) = "" Then ReDim Preserve vOutputSplit(0 To UBound(vOutputSplit) - 1)



    Dim lIntegerLoop As Long: lIntegerLoop = 0

    Dim alOffsets(0 To 1) As Long
    Dim alLengths(0 To 1) As Long
    Dim asIntegers(0 To 1) As String
    

    Dim lTotalBytes As Long: lTotalBytes = 0
    Dim vLoop As Variant
    For Each vLoop In vOutputSplit
        Dim sSigInt As String: sSigInt = vbNullString
        Dim lOffset As Long: lOffset = 0
        Dim lLength As Long: lLength = 0
        If RegExpSignatureInteger(vLoop, lOffset, lLength, sSigInt) Then
            
            alOffsets(lIntegerLoop) = lOffset
            alLengths(lIntegerLoop) = lLength
            asIntegers(lIntegerLoop) = sSigInt
            
            lTotalBytes = lTotalBytes + lLength
            
            lIntegerLoop = lIntegerLoop + 1
        End If
    Next vLoop
    
    Dim abytSig() As Byte
    Dim asSigHexs() As String  '* for debugging

    '* read in the whole file into a byte array
    ReadFileAsBytes sSignatureFile, abytSig
    
    '* for debugging create an array of hexadecimals
    ByteArrayToHexStringArray abytSig, asSigHexs
    
    For lIntegerLoop = 0 To 1
        fso.CreateTextFile fso.BuildPath(BatchDir(), lIntegerLoop & "_" & alLengths(lIntegerLoop))
        If alLengths(lIntegerLoop) = 49 Then
            
            '* silly null byte
            'Debug.Assert abytSig(3) = 0
            
            '* ignore the null byte
            alLengths(lIntegerLoop) = 48
            alOffsets(lIntegerLoop) = alOffsets(lIntegerLoop) + 1
        
        End If
    Next
    
    Dim abytInteger0() As Byte
    CopyArraySlice abytSig, alOffsets(0) + 2, alLengths(0), abytInteger0()
    
    Dim abytInteger1() As Byte
    CopyArraySlice abytSig, alOffsets(1) + 2, alLengths(1), abytInteger1()
    
    
    ReDim abytIntegers0And1(0 To alLengths(0) + alLengths(1) - 1) As Byte
    
    
    Dim lConcatByteLoop As Long: lConcatByteLoop = 0
    lIntegerLoop = 0
    For lIntegerLoop = 0 To 1
        Dim lByteLoop As Long
        For lByteLoop = 0 To alLengths(lIntegerLoop) - 1
            Dim byt As Byte
            If lIntegerLoop = 0 Then
                byt = abytInteger0(lByteLoop)
            Else
                byt = abytInteger1(lByteLoop)
            End If
        
            abytIntegers0And1(lConcatByteLoop) = byt
            lConcatByteLoop = lConcatByteLoop + 1
        Next lByteLoop
    
    Next lIntegerLoop
    
    'Dim lByteLoop As Long
    'for lByteLoop-
    
    'Stop
    
'    Dim bitString() As Byte
'    '* need extra 2 bytes because of leading type and length bytes
'    CopyArraySlice abytes, lOffset, lLength + 2, bitString()
'
'    '* some asserts which pin down structure of the bytes
'    Debug.Assert bitString(0) = 3  '* TAG for BIT STRING
'    Debug.Assert bitString(1) = lLength
'
    
    
    
    'Stop
    
    'Debug.Assert dicIntegers.Count = 2
    'sIntegers(0) = dicIntegers(dicIntegers.Keys()(0))
    'sIntegers(1) = dicIntegers(dicIntegers.Keys()(1))
    
    'Debug.Assert Len(sIntegers(0)) = Len(sIntegers(1))
    'Debug.Assert Len(sIntegers(0)) Mod 2 = 0
    
'    Dim lStringLen As Long
'    lStringLen = Len(sIntegers(0))
'
'    Dim lByteLen As Long
'    lByteLen = lStringLen / 2
'
'
'    ReDim byt(0 To lTotalBytes - 1) As Byte
'
'    Dim lIntegerLoop As Long
'    For lIntegerLoop = 0 To 1
'        Dim lCharLoop As Long
'        For lCharLoop = 0 To lByteLen - 1
'
'            Dim sChar2 As String
'            sChar2 = Mid$(sIntegers(lIntegerLoop), (lCharLoop * 2) + 1, 2)
'
'            Debug.Assert Len(sChar2) > 0
'
'            Dim bChar2 As Byte
'            bChar2 = Val("&h" & sChar2)
'
'            byt(lCharLoop + lIntegerLoop * lByteLen) = bChar2
'
'        Next lCharLoop
'    Next
    
    If fso.FileExists(sEditedSignatureFile) Then fso.DeleteFile sEditedSignatureFile
    SaveBytesAsFile sEditedSignatureFile, abytIntegers0And1()
    
    Debug.Assert fso.FileExists(sEditedSignatureFile)
    

End Function


Private Function RegExpSignatureInteger(ByVal sLine As String, ByRef plOffset As Long, ByRef plLength As Long, ByRef psSignatureInterger As String) As Boolean
    

    '* use regular expressions to dig out numbers from ASN1 parse results
    '* if always using 384 bit then we always be 20 and 98
    '* but for future use we may use 512 bit or a change of curve etc.

    Dim oRE As VBScript_RegExp_55.RegExp
    Set oRE = New VBScript_RegExp_55.RegExp
    oRE.Pattern = "^\s*(\d+):d=1  hl=2 l=  (\d+) prim: INTEGER\s*:(.+)"
    
    
    Debug.Assert oRE.Test("    2:d=1  hl=2 l=  49 prim: INTEGER           :ADFF05570D228E657E98F5455D1772F23224389641F9FA8DCC37B39816BE0C9F871BBABAF4F73ECDDB7BA6814502A85D")
    Debug.Assert oRE.Test("   53:d=1  hl=2 l=  49 prim: INTEGER           :83A977122AF40623AF0C1C64CDEA761E77C534FCA267F2DA6F340CE6AB371F8419464DCC38C5F41729EB421F384A72A1")
    Debug.Assert oRE.Test("    2:d=1  hl=2 l=  48 prim: INTEGER           :195848488FC6A5888D6433E5B714A45A515EE6CBF1B0C952EE35E51F6D678A2623170AE9DE2E0A29B7D47EDC8F95C264")
    Debug.Assert oRE.Test("   52:d=1  hl=2 l=  48 prim: INTEGER           :4789B87BFFC7AC24DA6A9223805EC25EDD6444B483689B2CDBA73056F939C0127228F2632A387BDF6AF93B9A3EAC548E")
    
    If oRE.Test(sLine) Then
    
        Dim oMatchCol As VBScript_RegExp_55.MatchCollection
        Set oMatchCol = oRE.Execute(sLine)
        
        Dim oMatch As VBScript_RegExp_55.Match
        Set oMatch = oMatchCol.Item(0)
        
        plOffset = oMatch.SubMatches(0)
        plLength = oMatch.SubMatches(1)
        psSignatureInterger = oMatch.SubMatches(2)
        
        
        RegExpSignatureInteger = True
    End If
End Function


Private Function ExportECDSAToXml(ByVal sPublicKeyFile As String, ByVal sXmlFile As String) As Boolean

    '* C#'s ECDsaCng class has a FromXmlString method which imports public key from a xml file Rfc4050
    '* In this subroutine we use OpenSSL's asn1parse command to determine where the X and Y coordinates
    '* are to be found, we dig them out and then markup an Xml file

    '* sample output
    
    '
    '  
    '    
    '  
    '  
    '    
    '    
    '  
    '


    Dim sASN1ParseCmd As String
    sASN1ParseCmd = sOPENSSL_BIN & " asn1parse -inform DER -in " & sPublicKeyFile

    Dim eASN1ParseStatus As WshExecStatus, sASN1ParseStdOut As String, sASN1ParseStdErr As String
    eASN1ParseStatus = RunShellAndWait(sASN1ParseCmd, sASN1ParseStdOut, sASN1ParseStdErr)
    Debug.Print sASN1ParseStdOut
    
    '* sample output from standard out pipe is given blow.
    '* we need to dig into the BIT STRING which is the final item
    '* we need offset and length which is always 20 and 98 for 384 bit ECDSA
    '* but I have written logic in case we want to upgrade to 512 or change of curve etc.
    '    0:d=0  hl=2 l= 118 cons: SEQUENCE
    '    2:d=1  hl=2 l=  16 cons: SEQUENCE
    '    4:d=2  hl=2 l=   7 prim: OBJECT            :id-ecPublicKey
    '   13:d=2  hl=2 l=   5 prim: OBJECT            :secp384r1
    '   20:d=1  hl=2 l=  98 prim: BIT STRING
    
    
    
    Dim vOutputSplit As Variant
    vOutputSplit = VBA.Split(sASN1ParseStdOut, vbNewLine)
    
    '* remove the traling blank line
    If Trim(vOutputSplit(UBound(vOutputSplit))) = "" Then ReDim Preserve vOutputSplit(0 To UBound(vOutputSplit) - 1)

    '* final line should be the long bit string, i.e. contain 'BIT STRING'
    Debug.Assert StrComp("BIT STRING", Right$(Trim(vOutputSplit(UBound(vOutputSplit))), 10)) = 0

    '* use regular expression to dig out offset and length
    Dim lOffset As Long, lLength As Long
    RegExpOffsetAndLengthFromASN1Parse Trim(vOutputSplit(UBound(vOutputSplit))), lOffset, lLength
    
    Dim abytes() As Byte
    Dim asHexs() As String  '* for debugging

    '* read in the whole file into a byte array
    ReadFileAsBytes sPublicKeyFile, abytes
    
    '* for debugging create an array of hexadecimals
    ByteArrayToHexStringArray abytes, asHexs
    
    
    Dim bitString() As Byte
    '* need extra 2 bytes because of leading type and length bytes
    CopyArraySlice abytes, lOffset, lLength + 2, bitString()
    
    '* some asserts which pin down structure of the bytes
    Debug.Assert bitString(0) = 3  '* TAG for BIT STRING
    Debug.Assert bitString(1) = lLength

    '* From Point 5 at http://certificate.fyicenter.com/2221_View_Website_Server_Certificate_in_Google_Chrome.html
    '* "ASN.1 BIT STRING value is stored with DER encoding as the value itself with an extra leading byte of 0x00. "
    Debug.Assert bitString(2) = 0
    
    '* 0x04 means by x and y values follow, i.e. uncompressed
    '* (instead of just one from which the other can be derived, leading with 0x02 or 0x03)
    '* https://en.bitcoin.it/wiki/Elliptic_Curve_Digital_Signature_Algorithm
    Debug.Assert bitString(3) = 4
    'Stop
    

    
    Dim x() As Byte
    Dim y() As Byte
    
    '* slice out the 48 bits for nopth x and y
    '* why 48?  because 48*8=384 bits(change for 512)
    CopyArraySlice bitString, 4, 48, x()
    CopyArraySlice bitString, 52, 48, y()
    
    '* convert bytes to hex string for x coord
    Dim sHexX As String
    sHexX = ByteArrayToHexString(x(), "")
    
    Debug.Print "sHexX:" & sHexX
    
    '* convert bytes to hex string for y coord
    Dim sHexY As String
    sHexY = ByteArrayToHexString(y(), "")
    
    Debug.Print "sHexY:" & sHexY
    
    '* convert hexadeciumal to plain decimal
    '* as Xml file requires it
    Dim sDecX As String
    sDecX = HexToDecimal(sHexX)
    
    Debug.Print "sDecX:" & sDecX
    
    '* convert hexadeciumal to plain decimal
    '* as Xml file requires it
    Dim sDecY As String
    sDecY = HexToDecimal(sHexY)
    
    Debug.Print "sDecY:" & sDecY
    
    
    '* create the xml file from a template
    Dim dom2 As MSXML2.DOMDocument60
    Set dom2 = New MSXML2.DOMDocument60
    dom2.LoadXML ECDSAXml(sDecX, sDecY)
    Debug.Assert dom2.parseError.ErrorCode = 0
    
    
    dom2.Save sXmlFile
    
    Debug.Print dom2.XML
    Set dom2 = Nothing
    
    
    Debug.Assert CreateObject("Scripting.FileSystemObject").FileExists(sXmlFile)
    

End Function

Private Function CopyArraySlice(ByRef abOriginal() As Byte, _
            ByVal lStart As Long, ByVal lLength As Long, ByRef abNewSlice() As Byte) As Boolean
            
    '* this copies a slice of an array of bytes to another
    '* caller declares the result array and this code re-dimensions it
            
    Debug.Assert lLength >= 1
    Debug.Assert lStart >= 0
    ReDim abNewSlice(0 To lLength - 1)

    Dim lLoop As Long
    For lLoop = 0 To lLength - 1
        Dim lLoop2 As Long
        lLoop2 = lLoop + lStart
    
        abNewSlice(lLoop) = abOriginal(lLoop2)
    Next lLoop
End Function


Private Function ReadFileAsBytes(ByVal sFile As String, ByRef abytes() As Byte)

    '* ActiveX Data Objects has a binary load to byte array feature ....

    Dim strm As ADODB.Stream
    Set strm = New ADODB.Stream
    With strm
        .Open
        .Type = adTypeBinary
        .LoadFromFile sFile
        abytes = .Read
        .Close
    End With
    Set strm = Nothing

End Function

Private Function SaveBytesAsFile(ByVal sFile As String, ByRef abytes() As Byte)

    Dim lFile As Long
    lFile = FreeFile
    
    Open sFile For Binary Access Write Lock Write As #lFile
    Put #lFile, , abytes()
    Close #lFile

'
'    Dim strm As ADODB.Stream
'    Set strm = New ADODB.Stream
'    With strm
'        .Open
'        .Type = adTypeBinary
'        .Write abytes
'        .SaveToFile sFile
'        '.LoadFromFile sFile
'        'abytes = .Read
'        .Close
'    End With
'    Set strm = Nothing
'
End Function


Private Function ByteArrayToHexStringArray(ByRef abytes() As Byte, ByRef asHexs() As String)
    '* used for debugging

    ReDim asHexs(LBound(abytes) To UBound(abytes))
    
    Dim lLoop As Long
    For lLoop = LBound(abytes) To UBound(abytes)
        asHexs(lLoop) = Hex$(abytes(lLoop))

    Next lLoop
End Function


Private Function ByteArrayToHexString(ByRef ab() As Byte, Optional sDelimiter As String = " ") As String
    '* used to create very long hex numbers as strings
    '* cryptography has long numbers for keys
    Dim sSegment As String
    sSegment = ""
    
    Dim lLoop As Long
    For lLoop = 0 To UBound(ab)
        sSegment = sSegment & sDelimiter & Right$("0" & Hex$(ab(lLoop)), 2)
    Next
    
    ByteArrayToHexString = Trim(sSegment)

End Function

Private Function HexToDecimal(ByVal sHex As String) As String
    '* takes a long hexadecimal number (as a string) and converts
    '* to a long decimal number (as a string)
    
    '* translated from StackOverflow answer
    '* https://stackoverflow.com/questions/16965915/convert-a-big-hex-number-string-format-to-a-decimal-number-string-format-w/46817799
    
    '* tested against websites such as
    '* http://www.statman.info/conversions/hexadecimal.php
    
    Dim dec() As Long
    ReDim dec(0 To 0) As Long
    
    Dim lCharLoop As Long
    For lCharLoop = 1 To Len(sHex)
        
        Dim char As String * 1
        char = Mid$(sHex, lCharLoop, 1)
        
        Dim carry As Long
        carry = Val("&h" & char)
        
        Dim i As Long
        For i = 0 To UBound(dec)
            Dim lVal As Long
            lVal = dec(i) * 16 + carry
            dec(i) = lVal Mod 10
            carry = lVal \ 10
        Next i
    
        While (carry > 0)
            ReDim Preserve dec(0 To UBound(dec) + 1) As Long
            dec(UBound(dec)) = carry Mod 10
            carry = carry \ 10
        Wend
    Next
    
    For lCharLoop = UBound(dec) To LBound(dec) Step -1
        Dim sDecimal As String
        sDecimal = sDecimal & Chr$(48 + dec(lCharLoop))
    
    Next
    
    HexToDecimal = sDecimal

End Function

Private Function ECDSAXml(ByVal sXValue As String, ByVal sYValue As String, Optional ByVal sCurveOid As String = "1.3.132.0.34") As String

    '* sample output
    
    '
    '  
    '    
    '  
    '  
    '    
    '    
    '  
    '

    Dim dom As MSXML2.DOMDocument60
    Set dom = New MSXML2.DOMDocument60
    dom.LoadXML "" & _
                "" & _
                "" & _
                "" & _
                "" & _
                "" & _
                ""
    Debug.Assert dom.parseError.ErrorCode = 0

    '* namespace selection glitch requires us to declare namespace prefix
    '* to use XPath even though original document does not
    dom.setProperty "SelectionNamespaces", "xmlns:ec=""http://www.w3.org/2001/04/xmldsig-more#"""
    
    
    Dim attrCurveId As MSXML2.IXMLDOMAttribute
    Set attrCurveId = dom.SelectSingleNode("ec:ECDSAKeyValue/ec:DomainParameters/ec:NamedCurve/@URN")
    Debug.Assert attrCurveId.Text = "urn:oid:" & sCurveOid  '  secp384r1 – {1.3.132.0.34}
    
    Dim attrXValue As MSXML2.IXMLDOMAttribute
    Set attrXValue = dom.SelectSingleNode("ec:ECDSAKeyValue/ec:PublicKey/ec:X/@Value")
    Debug.Assert Not attrXValue Is Nothing
    attrXValue.Text = sXValue
    
    Dim attrYValue As MSXML2.IXMLDOMAttribute
    Set attrYValue = dom.SelectSingleNode("ec:ECDSAKeyValue/ec:PublicKey/ec:Y/@Value")
    Debug.Assert Not attrYValue Is Nothing
    attrYValue.Text = sYValue
    
    
    ECDSAXml = PrettyPrintXml(dom)
    'ECDSAXml = dom.XML
End Function

Private Function PrettyPrintXml(ByVal dom As MSXML2.DOMDocument60) As String
    '* this routine inserts line breaks between elements

    Dim reader As MSXML2.SAXXMLReader60
    Set reader = New MSXML2.SAXXMLReader60
    
    Dim writer As MSXML2.MXXMLWriter60
    Set writer = New MSXML2.MXXMLWriter60
    writer.omitXMLDeclaration = True
    writer.indent = True
    
    Set reader.contentHandler = writer
    reader.Parse dom.XML
   
    PrettyPrintXml = writer.output
End Function


Private Function WriteStringToFile(ByVal sContents As String, ByVal sFileName As String) As Boolean
    '* this ought to be a one-liner but with so much other code
    '* I felt it necessary to break out so I can debug and check what is happening
    
    If fso.FileExists(sFileName) Then fso.DeleteFile sFileName
    
    Dim txtSignableContent As Scripting.TextStream
    Set txtSignableContent = fso.CreateTextFile(sFileName)
    txtSignableContent.Write sContents
    txtSignableContent.Close
    Set txtSignableContent = Nothing
    
    Debug.Assert fso.FileExists(sFileName)

    WriteStringToFile = True

End Function






Here is the output to the VBA immediate window which illustrates the console commands and the responses for running EntryPoint1_RunECDSAKeyGenerationBatch_RunOnce.


Creating batch directory :n:\ECDSA\2017-11-03T193106
C:\OpenSSL-Win64\bin\openssl.exe ecparam -genkey -name secp384r1 -out n:\ECDSA\2017-11-03T193106\ec_key.pem

C:\OpenSSL-Win64\bin\openssl.exe ec -pubout -outform DER -in n:\ECDSA\2017-11-03T193106\ec_key.pem -out n:\ECDSA\2017-11-03T193106\ec_pubkey.der
C:\OpenSSL-Win64\bin\openssl.exe ec -pubout -outform PEM -in n:\ECDSA\2017-11-03T193106\ec_key.pem -out n:\ECDSA\2017-11-03T193106\ec_pubkey.pem

C:\OpenSSL-Win64\bin\openssl.exe ec -noout -text -in n:\ECDSA\2017-11-03T193106\ec_key.pem -out n:\ECDSA\2017-11-03T193106\ec_key.txt

Private-Key: (384 bit)
priv:
    00:98:78:0d:c7:29:10:1c:9f:4d:75:b2:95:01:01:
    a9:d2:36:72:0d:77:6a:5c:57:8d:51:a0:53:27:05:
    9b:22:1c:c9:0a:1e:e1:27:06:92:c1:6c:2a:c4:bb:
    46:91:98:f6
pub: 
    04:bd:4a:38:04:69:d5:ba:fa:11:27:0f:a8:ef:70:
    3f:11:8d:e0:0f:e7:fd:26:ac:4d:40:32:7a:b5:9c:
    97:71:c1:80:72:1b:42:25:f8:a4:49:4d:8f:89:bf:
    1b:e9:6c:8c:f3:0b:02:db:89:b3:f7:92:e8:c4:a6:
    ce:04:88:10:51:cc:17:0b:b8:9c:9a:a6:3d:fd:ec:
    d4:99:c3:31:6b:22:1d:b6:41:fa:3c:0e:51:fe:86:
    67:bb:7e:86:ce:06:6c
ASN1 OID: secp384r1
NIST CURVE: P-384

C:\OpenSSL-Win64\bin\openssl.exe asn1parse -inform DER -in n:\ECDSA\2017-11-03T193106\ec_pubkey.der
    0:d=0  hl=2 l= 118 cons: SEQUENCE          
    2:d=1  hl=2 l=  16 cons: SEQUENCE          
    4:d=2  hl=2 l=   7 prim: OBJECT            :id-ecPublicKey
   13:d=2  hl=2 l=   5 prim: OBJECT            :secp384r1
   20:d=1  hl=2 l=  98 prim: BIT STRING        

sHexX:BD4A380469D5BAFA11270FA8EF703F118DE00FE7FD26AC4D40327AB59C9771C180721B4225F8A4494D8F89BF1BE96C8C
sHexY:F30B02DB89B3F792E8C4A6CE04881051CC170BB89C9AA63DFDECD499C3316B221DB641FA3C0E51FE8667BB7E86CE066C
sDecX:29134384736743232303148959866907873847020585008044539704341734517362687803911673703523083044584737202030832217844876
sDecY:37407743276271579329804703064876533532537408218368858949720169306023437854945515421210341789026319167790678153234028

    
        
    
    
        
        
    





Here is the VBA immediate window output for running EntryPoint2_RunHashAndSignBatch ...


C:\OpenSSL-Win64\bin\openssl.exe dgst -sha256 -out n:\ECDSA\2017-11-03T193106\license.sha256 n:\ECDSA\2017-11-03T193106\license.txt

SHA256(n:\ECDSA\2017-11-03T193106\license.txt)= 185f8db32271fe25f561a6fc938b2e264306ec304eda518007d1764826381969

C:\OpenSSL-Win64\bin\openssl.exe dgst -sha256 -sign n:\ECDSA\2017-11-03T193106\ec_key.pem -out n:\ECDSA\2017-11-03T193106\license.sig n:\ECDSA\2017-11-03T193106\license.txt

C:\OpenSSL-Win64\bin\openssl.exe base64 -in n:\ECDSA\2017-11-03T193106\license.sig -out n:\ECDSA\2017-11-03T193106\license.sigb64

C:\OpenSSL-Win64\bin\openssl.exe dgst -sha256 -verify n:\ECDSA\2017-11-03T193106\ec_pubkey.pem -signature n:\ECDSA\2017-11-03T193106\license.sig n:\ECDSA\2017-11-03T193106\license.txt
Verification success


Next we create a C# classic console application and paste in the following code to verify the digital signature remembering that the customer will be in receipt of a base64 version of the digital signature.


using System;
using System.IO;
using System.Security.Cryptography;
using System.Xml;

namespace ECDSAVerSig
{
    class Program
    {
        static Action feedback { get; set; }
        static byte[] fileContents = null;
        static byte[] signatureContents = null;

        static ECDsaCng client = null;
        static HashAlgorithm hashAlgo = new SHA256Managed();

        static String parentDirectory = null;

        static void Main(string[] args)
        {
            //* the following will be different for you!!!
            //* and will need to match what was output by the VBA script
            if (args.Length == 0)
            {
                parentDirectory = "n:\\ECDSA\\2017-11-06T212507\\";
            }
            else
            {
                parentDirectory = args[0];
            }
            feedback = Console.WriteLine; // Abstract away 


            if (Directory.Exists(parentDirectory))
            {


                feedback("Processing directory " + parentDirectory);

                if (LoadSignature())
                {
                    VerifySignature();
                }
            }
            else
            {
                feedback("#ERROR: directory '" + parentDirectory + "' does not exist!");
            }


        }



        static private Boolean VerifySignature()
        {
            try
            {
                // a byte array to store hash value
                byte[] hashedData = null;

                hashedData = hashAlgo.ComputeHash(fileContents);

                //* the following is consistently wrong though it is my best guess
                Boolean verified = client.VerifyHash(hashedData, signatureContents); //<-- Help required here StackOverflowers

                feedback("Verification:" + verified);

                if (verified)
                {
                    feedback("Hooray you got this 384 bit ECDSA code working! You absolute star!");
                    System.IO.File.Create(Path.Combine(parentDirectory, "win.txt"));
                }
                else
                {
                    feedback("Oh dear, still does not work.  Please keep twiddling.");
                    System.IO.File.Create(Path.Combine(parentDirectory, "lose.txt"));
                }

                return true;

            }
            catch (XmlException ex)
            {
                feedback("Problem with verification (Xml parse error):" + ex.ToString());
                return false;
            }
            catch (Exception ex)
            {
                feedback("Problem with verification :" + ex.ToString());
                return false;
            }
        }

        static private Boolean LoadSignature()
        {

            client = new ECDsaCng();
            try
            {

                System.Xml.XmlDocument dom = new System.Xml.XmlDocument();

                dom.Load(Path.Combine(parentDirectory, "ec_pubkey.xml"));

                string xml = dom.OuterXml;
                feedback(xml);
                client.FromXmlString(xml, ECKeyXmlFormat.Rfc4050);

                fileContents = System.IO.File.ReadAllBytes(Path.Combine(parentDirectory, "license.txt"));

                string base64SignatureContents = System.IO.File.ReadAllText(Path.Combine(parentDirectory, "license.sigB64"));
                signatureContents = Convert.FromBase64String(base64SignatureContents);


                byte[] hashedData = hashAlgo.ComputeHash(fileContents);


                return true;
            }
            catch (XmlException ex)
            {
                feedback("Problem with reading digital signature (Xml parse error):" + ex.ToString());
                return false;
            }

            catch (Exception ex)
            {
                feedback("Problem with reading digital signature:" + ex.ToString());
                return false;
            }
        }
    }
}

I have triple checked this code. I've made the license file a very short "Hello" and checked bytes and encoding. I do not know what next to do. Please assist. Thanks in advance