Friday 17 February 2017

Converting VBA 2-Dimensional vector to 1-Dimensional Array

Well, I would have like to have contributed to Stack Overflow's VBA Documentation, specifically an array example but that section is full!   So I will deposit the code here.

This code will take a vector, either a column vector or a row vector and convert to 1 dimensional array.  So to be precise, the vector is in fact a 2 dimensional variant array where either the number of rows is one or the number of columns is one.

This finding arose from an exchange of comments on a solution by yowe3k (http://stackoverflow.com/users/6535336/yowe3k).

Option Explicit
Option Private Module

Private Function ConvertColumnOrRowVectorToOneDimensionalArray(vVector As Variant) As Variant
    '* from an answer from yowe3k (http://stackoverflow.com/users/6535336/yowe3k) , transferred to documentation by S Meaden (http://stackoverflow.com/users/3607273/s-meaden)
    Const sERROR_MSG_CORE As String = "Please pass a 2d variant array with one dimension of one element size"
    
    If IsObject(vVector) Then Err.Raise vbObjectError, , "#" & sERROR_MSG_CORE & "(you passed an object)!"  '* if you pass a Range, please pass Range.Value instead
    If Not IsArray(vVector) Then Err.Raise vbObjectError, , "#" & sERROR_MSG_CORE & "!"
    
    Dim lColumnLBound As Long: lColumnLBound = LBoundOERN(vVector, 2)
    If lColumnLBound = -1 Then Err.Raise vbObjectError, , "#" & sERROR_MSG_CORE & "(you passed a 1d array)!"

    If Not (UBound(vVector, 1) - LBound(vVector, 1) = 0 Or UBound(vVector, 2) - LBound(vVector, 2) = 0) Then Err.Raise vbObjectError, , "#" & sERROR_MSG_CORE & "(you passed a matrix)!"
    
    If UBound(vVector, 1) - LBound(vVector, 1) = 0 Then
        ConvertColumnOrRowVectorToOneDimensionalArray = Application.Transpose(Application.Transpose(vVector))
    Else
        ConvertColumnOrRowVectorToOneDimensionalArray = Application.Transpose(vVector)
    End If
    
End Function

Private Function LBoundOERN(v, n) As Long
    LBoundOERN = -1
    On Error Resume Next
    LBoundOERN = LBound(v, n)
End Function

'***************************************************************
'* TESTS - also illustrative as to how to call the function
'***************************************************************

Private Sub TestConvertColumnOrRowVectorToOneDimensionalArray_All()
    
    TestConvertColumnOrRowVectorToOneDimensionalArray_NonErrors
    TestConvertColumnOrRowVectorToOneDimensionalArrayTestErrorThrowing
End Sub

Private Sub TestConvertColumnOrRowVectorToOneDimensionalArray_NonErrors()
    
    
    Sheet1.Cells(1, 1) = "foo"  '* set up the data
    Sheet1.Cells(2, 1) = "bar"  '* in a vertical block of three
    Sheet1.Cells(3, 1) = "baz"  '* cells
    
    Dim v1DFromColumnVector
    v1DFromColumnVector = ConvertColumnOrRowVectorToOneDimensionalArray(Sheet1.Range("A1:A3").Value)
    Debug.Assert v1DFromColumnVector(1) = "foo"  '* now
    Debug.Assert v1DFromColumnVector(2) = "bar"  '* one-
    Debug.Assert v1DFromColumnVector(3) = "baz"  '* dimensional
    
    
    Sheet1.Cells(1, 3) = "foo"   '* set up the data
    Sheet1.Cells(1, 4) = "bar"   '* in a horizontal block of three
    Sheet1.Cells(1, 5) = "baz"   '* cells
    
    Dim v1DFromRowVector
    v1DFromRowVector = ConvertColumnOrRowVectorToOneDimensionalArray(Sheet1.Range("C1:E1").Value)
    
    Debug.Assert v1DFromRowVector(1) = "foo"    '* now
    Debug.Assert v1DFromRowVector(2) = "bar"    '* one-
    Debug.Assert v1DFromRowVector(3) = "baz"    '* dimensional
    
    
End Sub


Private Sub TestConvertColumnOrRowVectorToOneDimensionalArrayTestErrorThrowing()
    On Error Resume Next  '* On Error ... resets the error object and its properties
    Debug.Assert Err.Number = 0
    ConvertColumnOrRowVectorToOneDimensionalArray Sheet1.Cells(1, 1)
    Debug.Assert Err.Number = vbObjectError
    Debug.Assert Err.Description = "#Please pass a 2d variant array with one dimension of one element size(you passed an object)!"
    
    On Error Resume Next  '* On Error ... resets the error object and its properties
    Debug.Assert Err.Number = 0
    ConvertColumnOrRowVectorToOneDimensionalArray "FOO"
    Debug.Assert Err.Number = vbObjectError
    Debug.Assert Err.Description = "#Please pass a 2d variant array with one dimension of one element size!"
    
    On Error Resume Next  '* On Error ... resets the error object and its properties
    Dim vOneDim(1 To 3) As Variant
    vOneDim(1) = "luke": vOneDim(2) = "leia": vOneDim(3) = "han":
    ConvertColumnOrRowVectorToOneDimensionalArray vOneDim
    Debug.Assert Err.Number = vbObjectError
    Debug.Assert Err.Description = "#Please pass a 2d variant array with one dimension of one element size(you passed a 1d array)!"
    
    
    On Error Resume Next  '* On Error ... resets the error object and its properties
    Debug.Assert Err.Number = 0
    ConvertColumnOrRowVectorToOneDimensionalArray Sheet1.Range("A1:B2").Value
    Debug.Assert Err.Number = vbObjectError
    Debug.Assert Err.Description = "#Please pass a 2d variant array with one dimension of one element size(you passed a matrix)!"
    
    
    On Error Resume Next  '* On Error ... resets the error object and its properties
    Debug.Assert Err.Number = 0
    ConvertColumnOrRowVectorToOneDimensionalArray [{"Jonh","Snow","President";"Ygritte","Wild","Vice-President"}]
    Debug.Assert Err.Number = vbObjectError
    Debug.Assert Err.Description = "#Please pass a 2d variant array with one dimension of one element size(you passed a matrix)!"
    
    
End Sub

Monday 13 February 2017

BSTRs should be treated as data exchange format, hence no LTrim for BSTR

So, VBA uses COM types and the string is in fact a BSTR.  There are a whole multitude of C/C++ string types and string classes because of the 8 bit/16 bit baggage and various libraries such as MFC, ATL and STL.  One wonders how best to interact with a BSTR.

One also wonders why a BSTR does not come with its own functions such as trim etc.  Here, I can quote an exchange on this subject at http://computer-programming-forum.com/77-vc-atl/5b5e3637cb0be00e.htm.

P.S. Very ruefully that neither _bstr_t nor CComBSTR doesn't support real string interface with [R|L]Trim, SubString, UpperCase and others.
to which is given an extremely interesting reply
There is a very good reason for this. Most of those operations cannot be performed in-place, you need to reallocate memory. And allocating a BSTR is expensive, since it must come from task memory allocator that is known to be slow. If you need to perform string manipulations, it is recommended to convert a BSTR to your favorite string class, perform string manipulations with it, and only allocate a new BSTR when you need to return the string to the client or something like that. In other words, BSTRs should be treated as data exchange format, not as general-purpose string representation and manipulation format. Reduce the operations on them to a minimum.
wow, "BSTRs should be treated as data exchange format", very interesting.

Ok so the MSDN article on Programming with CComBSTR (ATL) also gives a similar warning 
As the CComBSTR class allocates a buffer to perform certain operations, such as the += operator or Append method, it is not recommended that you perform string manipulation inside a tight loop. In these situations, CStringT provides better performance.
So it seems Microsoft are tipping CStringT as a good class for Unicode and lo and behold this class has a Trim function CStringT::Trim

Saturday 11 February 2017

VBA - Brackets around a variable executes default member, useful for worksheet functions

So, you may be aware that if you place round brackets around a variable it will execute the default member. 'So what?' you may say. I have never used this because it requires the reader of the code to know their default members. However today, I can see one good usage.

When one writes a function callable from a worksheet it very often needs to be called from VBA as well. I often would like the function to accept a multi-cell Range object and process the cell values, I often would like to call the same function from VBA passing in a two-dimensional Variant array.

To handle the two different types of input parameter one solution could be to use TypeName to establish if argument is a "Range" and then call Range.Value on it and just pass through if TypeName is "Variant()".

However, using round brackets handles both cases.

Function UseRoundBrackets(v As Variant) As Variant
    Dim v2 As Variant
    v2 = (v)
    
    '* Do some work on v2 safe that is always a Variant()
End Function

If you want some code to analyze what is going on then try this

'* This function is designed to accept either a range or 
'* a variant array containing the content of a range (.Value2)
Function WorksheetAndVBACallable1(v As Variant) As Variant
    '*  didactic/illustrative (not for production)
    Debug.Assert TypeName(v) = "Range" Or TypeName(v) = "Variant()"  
    
    Dim v2 As Variant
    v2 = (v)
    
    '*  didactic/illustrative (not for production)
    Debug.Assert TypeName(v2) = "Variant()"   
    
    '* Do some work on v2
    WorksheetAndVBACallable1 = DoWork(v2)

End Function

'* This function is designed to accept either a range or 
'* a variant array containing the content of a range (.Value2)
Function WorksheetAndVBACallable2(v As Variant) As Variant
    '*  didactic/illustrative (not for production)
    Debug.Assert TypeName(v) = "Range" Or TypeName(v) = "Variant()"  
    
    Dim v2 As Variant
    If TypeName(v) = "Range" Then
        v2 = v.Value2
    Else
        v2 = v
    End If

    '*  didactic/illustrative (not for production)
    Debug.Assert TypeName(v2) = "Variant()"  

    '* Do some work on v2
    WorksheetAndVBACallable2 = DoWork(v2)
    
End Function

Thursday 9 February 2017

Get All Running Excel Instances By Windows Handle (not ROT)

Very interesting code over at Florent Breheret's SeleniumBasic

This caught my eye.



Private Declare PtrSafe Function FindWindowExA Lib "user32.dll" ( _
  ByVal hwndParent As LongPtr, _
  ByVal hwndChildAfter As LongPtr, _
  ByVal lpszClass As String, _
  ByVal lpszWindow As String) As Long

Private Declare PtrSafe Function AccessibleObjectFromWindow Lib "oleacc.dll" ( _
  ByVal hwnd As LongPtr, _
  ByVal dwId As Long, _
  ByRef riid As Any, _
  ByRef ppvObject As IAccessible) As Long


''
' Returns all the active instances of Excel
''
Public Function GetExcelInstances() As Collection
  Dim guid&(0 To 4), app As Object, hwnd
  guid(0) = &H20400
  guid(1) = &H0
  guid(2) = &HC0
  guid(3) = &H46000000
  
  Set GetExcelInstances = New Collection
  Do
    hwnd = FindWindowExA(0, hwnd, "XLMAIN", vbNullString)
    If hwnd = 0 Then Exit Do
    hwnd = FindWindowExA(hwnd, 0, "XLDESK", vbNullString)
    If hwnd Then
      hwnd = FindWindowExA(hwnd, 0, "EXCEL7", vbNullString)
      If hwnd Then
        If AccessibleObjectFromWindow(hwnd, &HFFFFFFF0, guid(0), app) = 0 Then
          GetExcelInstances.Add app.Application
        End If
      End If
    End If
  Loop
End Function

Breaking Into (Your Own and nobody else's!) VBA Project If Password Forgotten

So, sometimes I am asked by a client to unlock an Excel VBA project because a prior developer has left the project locked and left the client's employment.

Clearly, there is a legal duty to establish that they do own the code, if not then I believe this is a criminal offence under some jurisdictions (certainly UK) and one should refuse.

Once legal issues are resolved then there is the technology.  One once used to be able to use a Hex editor and edit some bytes in an Excel file to crack open the VBA.   This SO post is remarkably ingenuous in that hacks the password dialog box, quite extraordinary.

ThisWorkbook looks good as a central entry point

So, another successful StackOverflow Bounty today and one where I learnt something.

You'll see my answer evolves. Originally, I gave the COM analogous solution, so an external workbook has classes just like a VB6 project but one cannot use the New keyword, so we have to write something analogous to IClassFactory. Then I gave both a late bound and an early bound aspect to the sample code.

The questioner asked why one was in ThisWorkbook and not the other? I was stumped initially, then I remembered how ThisWorkbook allows extensibility, this is explored in another SO question.

Experimenting with ThisWorkbook, I discovered useful features that the OP wanted and of use to others as well. So placing functions in ThisWorkbook hides them from the user when they enter cell formulae. Also the Subs cannot be accessed using Application.Run so this hides them from the global scope which is surely good practice.

Investigating another SO question (sorry no ref) I chanced upon some MSDN article where some C# VSTO code is called into from VBA. Given this article and the VBA example above it looks like ThisWorkbook is a good central entry point. I recommend.

Sunday 5 February 2017

Using HTTPS with Excel VBA

So, no doubt people are familiar with using MSXML2.XMLHTTP60 to make HTTP calls, this can be for web-scraping or even programming against a REST interface. Ideally, you want transport security for these requests but you'll need a different library for that {"Microsoft WinHTTP Services, version 5.1",C:\Windows\system32\winhttp.dll} and you'll need to call SetClientCertificate with a digital certificate.

Digital certificates are a big topic and not for this post, to get going use the Local Machine certificate and suppress warnings, see code below.

To have confidence it is working why not try the HTTP sniffing tool Fiddler, some extra code is added to facilitate this.


Attribute VB_Name = "modHTTPS"
Option Explicit

'* Tools->References: Microsoft WinHTTP Services, version 5.1

Sub Test()

    Dim oXHR As WinHttp.WinHttpRequest
    Set oXHR = New WinHttp.WinHttpRequest
    
    
    'http://stackoverflow.com/questions/1264303/https-post-request-using-vba-for-excel
    Call oXHR.SetClientCertificate("LOCAL_MACHINE\Personal\My Certificate")
    
    '** next line is because we're using the self-generated certificate, in prod purchase a propert certificate
    oXHR.Option(WinHttp.WinHttpRequestOption_SslErrorIgnoreFlags) = WinHttp.WinHttpRequestSslErrorFlags.SslErrorFlag_Ignore_All
        
    Const bUSE_FIDDLER_PROXY As Boolean = False
    If bUSE_FIDDLER_PROXY Then
        Const HTTPREQUEST_PROXYSETTING_PROXY As Long = 2
        oXHR.SetProxy HTTPREQUEST_PROXYSETTING_PROXY, "127.0.0.1:8888", ""
    End If
    
    Call oXHR.Open("GET", "https://www.google.co.uk", False)
    
    oXHR.Send
    
    oXHR.WaitForResponse

    Debug.Print oXHR.ResponseText
    Stop

End Sub

Using 2007 Office System Driver to query Worksheets

So many questions pop up on Stack Overflow asking how to match data that is relational, i.e. write code that mimic SQL functionality.  Here we post how ADO and the 2007 Office System Driver can be used to do queries based on worksheet data.

The first sub will write the test data which is some soccer statistics, run this once only. The second sub does the query and you will see that it successfully does a join.

Here is the standard module

Attribute VB_Name = "modADOExample"
Option Explicit


'*Tools->References : Microsoft ActiveX Data Object 2.8 Library

Sub RunOnceToSetupTestData()
    '* assumes a fresh new workbook
    Dim shNew(1 To 3) As Excel.Worksheet
    Dim lLoop As Long
    For lLoop = 1 To 3
        
        Set shNew(lLoop) = Nothing
        On Error Resume Next
        Set shNew(lLoop) = ThisWorkbook.Worksheets.Item("Sheet" & lLoop)
        
        On Error GoTo 0
        If shNew(lLoop) Is Nothing Then
            If lLoop = 1 Then
                Set shNew(lLoop) = ThisWorkbook.Worksheets.Add
            Else
                Set shNew(lLoop) = ThisWorkbook.Worksheets.Add(After:=shNew(lLoop - 1))
            End If
            shNew(lLoop).Name = ("Sheet" & lLoop)
        End If
        
    Next lLoop


    Dim sh As Excel.Worksheet: Set sh = shNew(1)
    sh.Name = "Players"

    ReDim v(1 To 5) As Variant
    v(1) = [{"Player","Club","Nationality","Goals";"Diego Costa","Chelsea","Spain",15;"Alexis Sánchez","Arsenal","Chile",15;"Jermain Defoe","Sunderland","England",14;"Zlatan Ibrahimovic","Manchester United","Sweden",14}]
    v(2) = [{"Romelu Lukaku","Everton","Belgium",14;"Harry Kane","Tottenham Hotspur","England",13;"Sergio Agüero","Manchester City","Argentina",11;"Dele Alli","Tottenham Hotspur","England",11;"Eden Hazard","Chelsea","Belgium",10}]
    v(3) = [{"Christian Benteke","Crystal Palace","Belgium",9;"Sadio Mané","Liverpool","Senegal",9;"Michail Antonio","West Ham United","England",8;"Roberto Firmino","Liverpool","Brazil",8;"Olivier Giroud","Arsenal","France",8}]
    v(4) = [{"Fernando Llorente","Swansea City","Spain",8;"Theo Walcott","Arsenal","England",8;"Troy Deeney","Watford","England",7;"Adam Lallana","Liverpool","England",7;"Salomón Rondón","West Bromwich Albion","Venezuela",7}]
    v(5) = [{"Gylfi Sigurdsson","Swansea City","Iceland",7;"","","",""}]
    Dim lRowIndex As Long: lRowIndex = 0
    Dim lChunkLoop As Long
    For lChunkLoop = 1 To 5
        Dim vWrite As Variant
        vWrite = v(lChunkLoop)
        Dim lChunkRowsCount As Long
        lChunkRowsCount = UBound(vWrite, 1) - LBound(vWrite, 1) + 1
        sh.Cells(1, 1).Offset(lRowIndex).Resize(lChunkRowsCount, UBound(vWrite, 2) - LBound(vWrite, 2) + 1).Value2 = vWrite
        lRowIndex = lRowIndex + lChunkRowsCount
    Next
    
    Set sh = shNew(2)
    sh.Name = "Clubs"

    ReDim v(1 To 5) As Variant
    v(1) = [{"Club","Wins";"Chelsea",19;"Arsenal",14;"Manchester City",14;"Liverpool",13}]
    v(2) = [{"Tottenham Hotspur",13;"Manchester United",11;"Everton",10;"Burnley",9;"West Bromwich Albion",9}]
    v(3) = [{"West Ham United",8;"AFC Bournemouth",7;"Southampton",7;"Stoke City",7;"Watford",7}]
    v(4) = [{"Swansea City",6;"Crystal Palace",5;"Leicester City",5;"Hull City",4;"Middlesbrough",4}]
    v(5) = [{"Sunderland",4;"",""}]
    lRowIndex = 0
    
    For lChunkLoop = 1 To 5
        
        vWrite = v(lChunkLoop)
        
        lChunkRowsCount = UBound(vWrite, 1) - LBound(vWrite, 1) + 1
        sh.Cells(1, 1).Offset(lRowIndex).Resize(lChunkRowsCount, UBound(vWrite, 2) - LBound(vWrite, 2) + 1).Value2 = vWrite
        lRowIndex = lRowIndex + lChunkRowsCount
    Next
    
    shNew(3).Name = "Join"
    'ThisWorkbook.Save
End Sub

    




Sub Test2()

    Dim oConn As ADODB.Connection
    Set oConn = New ADODB.Connection
    
    Debug.Assert UBound(Split(ThisWorkbook.Name, ".")) > 0  '* Workbook needs to be saved
    
    oConn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
           "Data Source=" & ThisWorkbook.FullName & ";" & _
           "Extended Properties='Excel 12.0 Macro'"


    Dim rsPlayers As ADODB.Recordset
    Set rsPlayers = New ADODB.Recordset
    
    rsPlayers.Open "Select * from [Players$] AS P", oConn, adOpenStatic

    Dim rsJoinExample As ADODB.Recordset
    Set rsJoinExample = New ADODB.Recordset
    
    rsJoinExample.Open "Select P.* ,C.Wins from [Players$] AS P inner join [Clubs$] as C on P.Club=C.Club", oConn, adOpenStatic

    Dim rngOutput As Excel.Range
    Set rngOutput = ThisWorkbook.Worksheets.Item("Join").Cells(1, 1)
    
    Dim fldLoop As ADODB.Field
    Dim lIndex As Long: lIndex = 0
    For Each fldLoop In rsJoinExample.Fields
        lIndex = lIndex + 1
    
        rngOutput.Cells(1, lIndex).Value2 = fldLoop.Name
    
    Next fldLoop
    
    rngOutput.Offset(1).CopyFromRecordset rsJoinExample
    oConn.Close

End Sub

Saturday 4 February 2017

Hunting for Image Files On Your Computer

So on my PC everything disk based is really really slow, the idea that Windows Explorer search can find a complete list of image files is wholly unrealistic.  Fortunately, I have some code that does something similar looking for VBA code files.  We can adapt this program easily.

We'll also add value by creating shortcuts in a shortcut folder.  When a shortcut of an image is created Windows Explorer will use the image itself.  This means you can leave all the image files in situ but collate one large folder with copies of the image.

A curious note about the code is the multiplicity of Scripting libraries out there.  I nearly always use Microsoft Scripting Runtime for its dictionaries.  There is another scripting library called {"Microsoft Shell Controls and Automation",shell32.dll} which I thought I'd need to create a shortcut.  It turns out the CreateShortcut method is in {"Windows Script Host Object Model",wshom.ocx}

TODO: compile an exhaustive list of all the scripting libraries to make sure I miss no goodies.

Here is the standard module modLookForPictureFiles.bas


Option Explicit
Option Private Module

'* Tool->References  Microsoft Scripting Runtime
'* Tool->References  Windows Script Host Object Model

Private m_fso As New Scripting.FileSystemObject
Private m_oWsh As New WshShell
Private msDIR As String

Private Sub Test()

    '* my blog does not like angle brackets - grrrr!
    msDIR = " " & Chr$(60) & "DIR" & Chr$(62) & " "

    '* ASSUMES YOU HAVE DONE c:\dir *.* /s > c:\temp\cdrive_star_dot_star_20170203.txt

    Dim sImageShortcutsFolder As String
    sImageShortcutsFolder = "n:\ImageShortcuts"
    Debug.Assert m_fso.FolderExists(sImageShortcutsFolder)


    Sheet1.Cells.Clear
    Dim sPipedOutputPath As String
    sPipedOutputPath = "c:\temp\cdrive_star_dot_star_20170203.txt"
    
    Dim dicLongListResults As Scripting.Dictionary
    
    
    Debug.Assert m_fso.FileExists(sPipedOutputPath)
    
    'Dim dic As Scripting.Dictionary
    ReadDirForwardSlashSCreateImageShortcuts sImageShortcutsFolder, sPipedOutputPath, dicLongListResults
    
    Debug.Assert dicLongListResults.Count = Sheet1.Cells(1, 1).CurrentRegion.Rows.Count
    
    'PasteResults dicLongListResults, 1
    
    'Debug.Print VBA.Join(dicLongListResults.Keys, vbNewLine)
    'Stop
    
End Sub

Private Sub PasteResults(ByVal dicLongListResults As Scripting.Dictionary, ByVal lResultIndex As Long)
    
    If dicLongListResults.Count > 0 Then
    
        Dim vResults As Variant
        vResults = Application.Transpose(dicLongListResults.Keys)
        
        Dim rngOrigin As Excel.Range
        Set rngOrigin = Sheet1.Cells(lResultIndex, 1)
        Debug.Assert IsEmpty(rngOrigin.Value)
        
        rngOrigin.Resize(dicLongListResults.Count) = vResults
        dicLongListResults.RemoveAll
    End If

End Sub

Private Function ReadDirForwardSlashSCreateImageShortcuts(ByVal sImageShortcutsFolder As String, ByVal sPipedOutputPath As String, _
                ByRef pdicLongListResults As Scripting.Dictionary)

    Dim lResultIndex As Long: lResultIndex = 1
    Dim lSavedResultIndex As Long: lSavedResultIndex = 1
    
    Dim dicInterimResults As Scripting.Dictionary
    Set dicInterimResults = New Scripting.Dictionary
    
    If m_fso.FileExists(sPipedOutputPath) Then
    
        Dim txtIn As Scripting.TextStream
        Set txtIn = m_fso.OpenTextFile(sPipedOutputPath)
        
        Set pdicLongListResults = New Scripting.Dictionary
        
        Dim lLineNumber As Long
        lLineNumber = 0
        
        Dim sLine As String
        sLine = txtIn.ReadLine
        While Not txtIn.AtEndOfStream
            DoEvents
            lLineNumber = lLineNumber + 1
            
            Dim bIsFileHeader As Boolean
            bIsFileHeader = IsFileHeader(sLine, lLineNumber)
            
            Dim bIsBlankLine As Boolean
            bIsBlankLine = IsBlankLine(sLine)
            
            Dim sDirectory As String
            Dim bIsDirectoryHeader As Boolean
            bIsDirectoryHeader = IsDirectoryHeader(sLine, sDirectory)
            
            Dim bIsTrailerLine As Boolean
            bIsTrailerLine = IsTrailerLine(sLine)
            
            If bIsTrailerLine Then
            
                PasteResults dicInterimResults, lSavedResultIndex
                lSavedResultIndex = lResultIndex
            
            End If
            
            Dim bIsEntryLine As Boolean
            bIsEntryLine = IsEntryLine(bIsFileHeader, bIsDirectoryHeader, bIsTrailerLine, bIsBlankLine)
            
            Dim bIsFileLine As Boolean
            bIsFileLine = IsFileLine(bIsEntryLine, sLine)
            
            If bIsFileLine Then
                Dim sFileName As String
                sFileName = Trim$(Mid$(sLine, 37))
                
                Dim lLastDotInstr As Long
                lLastDotInstr = VBA.InStrRev(sFileName, ".")
                
                If lLastDotInstr > 0 Then
                    Dim sLastFiveChars As String
                    sLastFiveChars = Left$(Mid$(sFileName, lLastDotInstr) & "      ", 5)
                    Debug.Assert Len(sLastFiveChars) = 5
                    Debug.Assert Left$(sLastFiveChars, 1) = "."
                    
                    Dim lFileTypeFound As Long
                    lFileTypeFound = VBA.InStr(1, "|.jpeg|.jpg |.tiff|.gif |.bmp |.png |.img |", "|" & sLastFiveChars & "|", vbTextCompare)
                    If lFileTypeFound > 0 Then
                    
                        Dim sFullPath As String
                        sFullPath = m_fso.BuildPath(sDirectory, sFileName)
                        
                        If m_fso.FileExists(sFullPath) Then
                        
                            Dim filImage As Scripting.File
                            Set filImage = m_fso.GetFile(sFullPath)
                        
                            Dim sShortCut As String
                            sShortCut = m_fso.BuildPath(sImageShortcutsFolder, CreateLinkFileExtensionEquiv(filImage.Name))
                        
                            CreateShortcut sShortCut, sFullPath
                            
                            Set filImage = Nothing
                        
                        End If
 
                        pdicLongListResults.Add sFullPath, 0
                        dicInterimResults.Add sFullPath, 0
                        lResultIndex = lResultIndex + 1
                    End If
                End If
            
            End If
            
            sLine = txtIn.ReadLine
        Wend
        
        txtIn.Close
        Set txtIn = Nothing
    End If
End Function

Private Function IsTrailerLine(ByVal sLine As String) As Boolean
    If (VBA.InStr(1, sLine, "File(s)", vbTextCompare) > 0) Then
        IsTrailerLine = True
    End If
End Function


Private Function IsBlankLine(ByVal sLine As String) As Boolean
    IsBlankLine = (Len(Trim(sLine)) = 0)
End Function

Private Function IsFileLine(ByVal bIsEntryLine As Boolean, ByVal sLine As String) As Boolean
    If bIsEntryLine Then
        If (VBA.InStr(1, sLine, msDIR, vbTextCompare) = 0) Then
            IsFileLine = True
        End If
    End If
End Function

Private Function IsSubdirectoryLine(ByVal bIsEntryLine As Boolean, ByVal sLine As String) As Boolean
    If bIsEntryLine Then
        If (VBA.InStr(1, sLine, msDIR, vbTextCompare) > 0) Then
            IsSubdirectoryLine = True
        End If
    End If
End Function

Private Function IsEntryLine(ByVal bIsFileHeader As Boolean, ByVal bIsDirectoryHeader As Boolean, ByVal bIsTrailerLine As Boolean, ByVal bIsBlankLine As Boolean) As Boolean
    IsEntryLine = (Not bIsFileHeader) And (Not bIsDirectoryHeader) And (Not bIsTrailerLine) And (Not bIsBlankLine)
End Function

Private Function IsDirectoryHeader(ByVal sLine As String, ByRef psDirectory As String) As Boolean
    If VBA.InStr(1, sLine, " Directory of ", vbTextCompare) > 0 Then
    
        psDirectory = Trim(Mid$(sLine, 15))
    
        IsDirectoryHeader = True
    End If
End Function

Private Function IsFileHeader(ByVal sLine As String, ByVal lLineNumber As Long) As Boolean
    If lLineNumber <= 2 Then
        IsFileHeader = (VBA.InStr(1, sLine, " Volume ", vbTextCompare) > 0)
    End If
End Function

Private Function CreateShortcut(ByVal sShortCut As String, ByVal sTargetPath As String)

    If Not m_fso.FileExists(sShortCut) Then
    
        Dim oShortcut As WshShortcut
        Set oShortcut = m_oWsh.CreateShortcut(sShortCut)
        oShortcut.TargetPath = sTargetPath
        oShortcut.Save

    End If

End Function

Private Function CreateLinkFileExtensionEquiv(ByVal sFile_Name As String) As String

    Dim vSplit As Variant
    vSplit = VBA.Split(sFile_Name, ".")
    
    If UBound(vSplit) > LBound(vSplit) Then
        vSplit(UBound(vSplit)) = "lnk"
    End If
    CreateLinkFileExtensionEquiv = Join(vSplit, ".")
    
End Function


Some code to help reduce the list might help...


Public Function IsIgnorableDirectory(ByVal sDir As String) As Boolean
    If InStr(1, sDir, "C:\Program Files", vbTextCompare) > 0 Then IsIgnorableDirectory = True
    If InStr(1, sDir, "C:\Android", vbTextCompare) > 0 Then IsIgnorableDirectory = True
    If InStr(1, sDir, "C:\CocosCreator", vbTextCompare) > 0 Then IsIgnorableDirectory = True
    If InStr(1, sDir, "C:\mozilla", vbTextCompare) > 0 Then IsIgnorableDirectory = True
    If InStr(1, sDir, "pdfclown", vbTextCompare) > 0 Then IsIgnorableDirectory = True
    If InStr(1, sDir, "rubberduck", vbTextCompare) > 0 Then IsIgnorableDirectory = True
    If InStr(1, sDir, "eclipse", vbTextCompare) > 0 Then IsIgnorableDirectory = True
    If InStr(1, sDir, "C:\hp", vbTextCompare) > 0 Then IsIgnorableDirectory = True
    If InStr(1, sDir, "cryptoppref", vbTextCompare) > 0 Then IsIgnorableDirectory = True
    If InStr(1, sDir, "Inkscape", vbTextCompare) > 0 Then IsIgnorableDirectory = True
    If InStr(1, sDir, "node_modules", vbTextCompare) > 0 Then IsIgnorableDirectory = True
    If InStr(1, sDir, "SNIP Translator", vbTextCompare) > 0 Then IsIgnorableDirectory = True
    If InStr(1, sDir, "resteasy-jaxrs", vbTextCompare) > 0 Then IsIgnorableDirectory = True
    If InStr(1, sDir, "Apps For Office", vbTextCompare) > 0 Then IsIgnorableDirectory = True
    If InStr(1, sDir, "HelloAPITemplateDemo", vbTextCompare) > 0 Then IsIgnorableDirectory = True
    If InStr(1, sDir, "jwplayer", vbTextCompare) > 0 Then IsIgnorableDirectory = True
    If InStr(1, sDir, "\WSO2\", vbTextCompare) > 0 Then IsIgnorableDirectory = True
    If InStr(1, sDir, "MVCAPPLICATION", vbTextCompare) > 0 Then IsIgnorableDirectory = True
End Function

Installing 2007 Office System Driver: Data Connectivity Components

Installing 2007 Office System Driver: Data Connectivity Components which is the replacement for JET for querying Excel worksheet data, some screenshots ...




Static Values Script Generator

So it is really useful to initialise a Range with some static values from code, especially for Stack Overflow where if an Excel VBA question does not have data then it is not directly debuggable. When I post to Stack Overflow I want to give the responders some test data to play with. We can generate some scripts with some code (meta-code?).

Here is the standard module modStaticValuesScriptGenerator.bas It relies on tables of data being resident on sheets Players and Clubs. To solve chicken and egg problem, a script below follows which you can use first...

Attribute VB_Name = "modStaticValuesScriptGenerator"
Option Explicit

Sub TestGenerateScript()
    Dim dicScript As Scripting.Dictionary
    GenerateScript dicScript, "Players"
    GenerateScript dicScript, "Clubs"
    Debug.Print Join(dicScript.items, vbNewLine)
End Sub

Function GenerateScript(ByRef dicLines As Scripting.Dictionary, ByVal sSheetName As String) As Variant
    
    If dicLines Is Nothing Then Set dicLines = New Scripting.Dictionary
    
    'Debug.Assert sSheetName > 1

    Dim wsData As Excel.Worksheet
    Set wsData = ThisWorkbook.Worksheets.Item(sSheetName)
    
    Dim rngData As Excel.Range
    Set rngData = wsData.Cells(1, 1).CurrentRegion
    
    Dim lRowCount As Long
    lRowCount = rngData.Rows.Count
    
    Dim lColumnCount As Long
    lColumnCount = rngData.Columns.Count
    
    ReDim sRow(1 To lRowCount) As String
    
    Dim lRowLoop As Long
    For lRowLoop = 1 To lRowCount
        
        sRow(lRowLoop) = ""
        
        Dim lColumnLoop As Long
        For lColumnLoop = 1 To lColumnCount
        
            Dim rng As Excel.Range
            Set rng = rngData.Cells(lRowLoop, lColumnLoop)
            
            Dim v As Variant
            v = rng.Value2
            
            Dim v2 As Variant: v2 = Empty
            If IsNumeric(v) Then
                v2 = v
            Else
                v2 = """" & v & """"
            End If
            sRow(lRowLoop) = sRow(lRowLoop) & VBA.IIf(Len(sRow(lRowLoop)) = 0, v2, "," & v2)
            
        
        Next lColumnLoop
        
    
    Next lRowLoop
'    Stop
    
    
    Dim lRowsPerChunk As Long
    lRowsPerChunk = 5
    
    If lRowCount Mod lRowsPerChunk = 1 Then
        '* no singleton rows because we need tweo dimensional chunks
        '* so add a blank line
        
        ReDim Preserve sRow(LBound(sRow) To UBound(sRow) + 1)
        
        Dim sPad As String: sPad = ""
        'Dim lPadLoop As Long
        For lColumnLoop = 1 To lColumnCount
            sPad = sPad & VBA.IIf(Len(sPad) > 0, ",""""", """""")
        Next
        
        sRow(UBound(sRow)) = sPad
        
        lRowCount = lRowCount + 1
        
    
    End If
    
    Dim lChunks As Long
    lChunks = Int(lRowCount / lRowsPerChunk) + 1
    
    ReDim sChunks(1 To lChunks) As String
    ReDim sRow2(1 To lRowsPerChunk) As String
    'sData = ""
    For lRowLoop = 1 To lRowCount
        
        
        Dim lChunk As Long
        lChunk = ((lRowLoop - 1) \ lRowsPerChunk) + 1
        Debug.Assert lChunk <> 0
        
        Dim lChunkRow As Long
        lChunkRow = (lRowLoop Mod lRowsPerChunk)
        
        Dim lChunkRowIndex As Long
        lChunkRowIndex = VBA.IIf(lChunkRow = 0, lRowsPerChunk, lChunkRow)
        
        sRow2(lChunkRowIndex) = sRow(lRowLoop)
        
        If lRowLoop Mod lRowsPerChunk = 0 Then
            Debug.Assert sChunks(lChunk) = ""
            sChunks(lChunk) = "[{" & VBA.Join(sRow2, ";") & "}]"
            ReDim sRow2(1 To lRowsPerChunk) As String
        End If
    
    Next
    ReDim Preserve sRow2(1 To lChunkRowIndex)
    sChunks(lChunks) = "[{" & VBA.Join(sRow2, ";") & "}]"
    
    dicLines.Add dicLines.Count, "Sub Paste" & sSheetName
    dicLines.Add dicLines.Count, vbTab & "Dim sh as Excel.Worksheet: Set sh=Nothing" & vbNewLine
    dicLines.Add dicLines.Count, vbTab & "Dim v(1 to " & lChunks & ") as Variant"
    
    Dim lChunkLoop As Long
    For lChunkLoop = 1 To lChunks
        dicLines.Add dicLines.Count, vbTab & "v(" & lChunkLoop & ")=" & sChunks(lChunkLoop)
    
    Next
    
    dicLines.Add dicLines.Count, vbTab & "Dim lRowIndex As Long: lRowIndex = 0"
    dicLines.Add dicLines.Count, vbTab & "Dim lChunkLoop As Long"
    dicLines.Add dicLines.Count, vbTab & "For lChunkLoop = 1 To " & lChunks
    dicLines.Add dicLines.Count, vbTab & "    Dim vWrite As Variant"
    dicLines.Add dicLines.Count, vbTab & "    vWrite = v(lChunkLoop)"
        
    dicLines.Add dicLines.Count, vbTab & "    Dim lChunkRowsCount As Long"
    dicLines.Add dicLines.Count, vbTab & "    lChunkRowsCount = UBound(vWrite, 1) - LBound(vWrite, 1) + 1"
    dicLines.Add dicLines.Count, vbTab & "    sh.Cells(1, 1).Offset(lRowIndex).Resize(lChunkRowsCount, UBound(vWrite, 2) - LBound(vWrite, 2) + 1).Value2 = vWrite"

    dicLines.Add dicLines.Count, vbTab & "    lRowIndex = lRowIndex + lChunkRowsCount"

    dicLines.Add dicLines.Count, vbTab & "Next"

    dicLines.Add dicLines.Count, "End Sub "

End Function


Here is the standard module modScripts.bas It was generated by module above

Attribute VB_Name = "modScripts"
Sub PastePlayers()
    Dim sh As Excel.Worksheet: Set sh = Sheet10

    Dim v(1 To 5) As Variant
    v(1) = [{"Player","Club","Nationality","Goals";"Diego Costa","Chelsea","Spain",15;"Alexis Sánchez","Arsenal","Chile",15;"Jermain Defoe","Sunderland","England",14;"Zlatan Ibrahimovic","Manchester United","Sweden",14}]
    v(2) = [{"Romelu Lukaku","Everton","Belgium",14;"Harry Kane","Tottenham Hotspur","England",13;"Sergio Agüero","Manchester City","Argentina",11;"Dele Alli","Tottenham Hotspur","England",11;"Eden Hazard","Chelsea","Belgium",10}]
    v(3) = [{"Christian Benteke","Crystal Palace","Belgium",9;"Sadio Mané","Liverpool","Senegal",9;"Michail Antonio","West Ham United","England",8;"Roberto Firmino","Liverpool","Brazil",8;"Olivier Giroud","Arsenal","France",8}]
    v(4) = [{"Fernando Llorente","Swansea City","Spain",8;"Theo Walcott","Arsenal","England",8;"Troy Deeney","Watford","England",7;"Adam Lallana","Liverpool","England",7;"Salomón Rondón","West Bromwich Albion","Venezuela",7}]
    v(5) = [{"Gylfi Sigurdsson","Swansea City","Iceland",7;"","","",""}]
    Dim lRowIndex As Long: lRowIndex = 0
    Dim lChunkLoop As Long
    For lChunkLoop = 1 To 5
        Dim vWrite As Variant
        vWrite = v(lChunkLoop)
        Dim lChunkRowsCount As Long
        lChunkRowsCount = UBound(vWrite, 1) - LBound(vWrite, 1) + 1
        sh.Cells(1, 1).Offset(lRowIndex).Resize(lChunkRowsCount, UBound(vWrite, 2) - LBound(vWrite, 2) + 1).Value2 = vWrite
        lRowIndex = lRowIndex + lChunkRowsCount
    Next
End Sub
Sub PasteClubs()
    Dim sh As Excel.Worksheet: Set sh = Sheet9

    Dim v(1 To 5) As Variant
    v(1) = [{"Club","Wins";"Chelsea",19;"Arsenal",14;"Manchester City",14;"Liverpool",13}]
    v(2) = [{"Tottenham Hotspur",13;"Manchester United",11;"Everton",10;"Burnley",9;"West Bromwich Albion",9}]
    v(3) = [{"West Ham United",8;"AFC Bournemouth",7;"Southampton",7;"Stoke City",7;"Watford",7}]
    v(4) = [{"Swansea City",6;"Crystal Palace",5;"Leicester City",5;"Hull City",4;"Middlesbrough",4}]
    v(5) = [{"Sunderland",4;"",""}]
    Dim lRowIndex As Long: lRowIndex = 0
    Dim lChunkLoop As Long
    For lChunkLoop = 1 To 5
        Dim vWrite As Variant
        vWrite = v(lChunkLoop)
        Dim lChunkRowsCount As Long
        lChunkRowsCount = UBound(vWrite, 1) - LBound(vWrite, 1) + 1
        sh.Cells(1, 1).Offset(lRowIndex).Resize(lChunkRowsCount, UBound(vWrite, 2) - LBound(vWrite, 2) + 1).Value2 = vWrite
        lRowIndex = lRowIndex + lChunkRowsCount
    Next
End Sub

Wednesday 1 February 2017

SVG Text Element Width Calculator

So whilst SVG is wonderful at graphics, for text it has no word wrap features etc. this is a pain and I quickly wanted a solution to break up a paragraph of text into lines.

 This is work in progress as requirement suspended.

So the trick is to instantiate Internet Explorer and navigate to a test file with some words in it and inspect the length.  If the length is too long then you remove the last word you added.  This runs slow but it must be stressed this is dev-time process not a run-time process so no matter.

Here is the SVGTextMessageLengthCalculator class

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "SVGTextMessageLengthCalculator"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'* References Microsoft Scripting Runtime
'* References Microsoft Internet Controls
'* References Microsoft HTML Object Library

Private fso As Scripting.FileSystemObject

Private moIE As InternetExplorerMedium
Private msMessage As String
Private mdCutOffLength As Double

Private msFileName As String
Private msTextStyle As String
Private msTextElementID As String
Private mx As Double
Private my As Double

Public Sub Initialise(ByVal sMessage As String, ByVal sFileName As String, _
                    ByVal sTextStyle As String, ByVal sTextElementID As String, ByVal x As Double, ByVal y As Double, _
                    ByVal dCutOffLength As Double)
    'these are parameters unchanging whilst the text message remains constant so stash in class members
    msFileName = sFileName
    msTextStyle = sTextStyle
    msTextElementID = sTextElementID
    mx = x
    my = y
    
    msMessage = sMessage
    mdCutOffLength = dCutOffLength
                    
    Set moIE = New InternetExplorerMedium
    moIE.Visible = True
                    
End Sub


Public Function CalculateChunks() As Scripting.Dictionary
    Dim dicChunks As New Scripting.Dictionary '* used as expanding array/vector
    Dim sRemainder As String, sChunk As String
    
    sRemainder = CycleThroughTextMessage(msMessage, mdCutOffLength, sChunk)
    dicChunks.Add dicChunks.Count, sChunk
    While Len(sRemainder) > 0
    
        sRemainder = CycleThroughTextMessage(sRemainder, mdCutOffLength, sChunk)
        dicChunks.Add dicChunks.Count, sChunk
    Wend
    
    Set CalculateChunks = dicChunks

End Function

Private Function CycleThroughTextMessage( _
            ByVal sTextMessage As String, ByVal dCutOffLength As Double, _
            ByRef psChunk As String) As String


    Dim vSplitTextMessage As Variant
    vSplitTextMessage = VBA.Split(sTextMessage)

    Dim sTextAccumulator As String
    Dim sSavedTextAccumulator As String
    
    Dim vSplitLoop As Variant
    For Each vSplitLoop In vSplitTextMessage
        sTextAccumulator = sTextAccumulator & vSplitLoop & " "
        
        WriteSVGTextFile sTextAccumulator
        
        Dim dLength As Double
        dLength = NavigateToTextMessageAndMeasureWidth
        If dLength > dCutOffLength Then
            Dim sRemainder As String
            sRemainder = Mid(sTextMessage, Len(sSavedTextAccumulator) + 1)
            Debug.Assert Len(sRemainder) + Len(sSavedTextAccumulator) - Len(sTextMessage) = 0
            Exit For
        End If
        sSavedTextAccumulator = sTextAccumulator
    Next vSplitLoop
    psChunk = sSavedTextAccumulator
    CycleThroughTextMessage = sRemainder


End Function

Public Sub Terminate()
    Set fso = Nothing
    moIE.Quit
    Set moIE = Nothing
End Sub

Private Function NavigateToTextMessageAndMeasureWidth() As Double
    Debug.Assert Not moIE Is Nothing
    moIE.navigate msFileName '"N:\drawing.svg"
    While moIE.Busy = True
        DoEvents
    Wend

    Dim doc As HTMLDocument
    Set doc = moIE.document

    Dim objTextElement As MSHTML.SVGTSpanElement
    Set objTextElement = doc.getElementById(msTextElementID)

    NavigateToTextMessageAndMeasureWidth = objTextElement.getComputedTextLength

End Function


Private Sub WriteSVGTextFile(ByVal sTextMessage As String)
    Debug.Assert Not fso Is Nothing
    
    Dim txt As Scripting.TextStream
    Set txt = fso.CreateTextFile(msFileName)
    
    txt.WriteLine Chr$(60) & "?xml version=""1.0"" encoding=""UTF-8"" standalone=""no""?" & Chr$(62)
    txt.WriteLine Chr$(60) & "svg xmlns=""http://www.w3.org/2000/svg"" width=""210mm"" height=""297mm"" viewBox=""0 0 744.09448819 1052.3622047"" id=""svg2"" version=""1.1"" " & Chr$(62)
    txt.WriteLine Chr$(60) & "text "
    txt.WriteLine "xml:space=""preserve"" "
    txt.WriteLine "style=""" & msTextStyle & """ "
    txt.WriteLine "id=""" & msTextElementID & """ "
    txt.WriteLine "x=""" & CStr(mx) & """ "
    txt.WriteLine "y=""" & CStr(my) & """" & Chr$(62)
    txt.WriteLine sTextMessage
    txt.WriteLine Chr$(60) & "/text>"
    txt.WriteLine Chr$(60) & "/svg" & Chr$(62)
    txt.Close
    
    
    
End Sub

Private Sub Class_Initialize()
    Set fso = New Scripting.FileSystemObject
End Sub

And here is some test calling code

Attribute VB_Name = "tstSVGTextMessageLengthCal"
Option Explicit

Sub Test()
    Dim sMessage As String
    sMessage = "The financial markets have begun to wake up to the fact that the Republican reforms " & _
                "to US corporate taxation will probably include important new 'border adjustments' to " & _
                "the definitions of company revenues and costs. The basic idea is that US should shift " & _
                "to a 'territorial' system, with corporations being taxed only on revenues and costs " & _
                "incurred within the US itself, and not on their worldwide aggregates, which is the " & _
                "principle behind the present system. [1]"


    Dim oTextMessageLengthCalculator As SVGTextMessageLengthCalculator
    Set oTextMessageLengthCalculator = New SVGTextMessageLengthCalculator
    Const sFileName As String = "N:\drawing2.svg"
    Const sSTYLE As String = "font-style:normal;font-weight:normal;font-size:40px;line-height:125%;font-family:sans-serif;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:none;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1"
    Const sTEXTELEMENT_ID As String = "id001"
    oTextMessageLengthCalculator.Initialise sMessage, sFileName, sSTYLE, sTEXTELEMENT_ID, 20, 50, 700


    
    Dim dicChunks As New Scripting.Dictionary '* used as expanding array/vector
    Set dicChunks = oTextMessageLengthCalculator.CalculateChunks
    oTextMessageLengthCalculator.Terminate
    
    Debug.Print VBA.Join(dicChunks.Items, vbNewLine)

End Sub

Creating an SVG file with VBA

So SVG stands for Scalable Vector Graphics as is part of HTML5 and so is best open standard for graphics.  However, when drawing curved lines the co-ordinate data is packed in an attribute called 'd' on a SVG path element and is very fiddly to manipulate.

We will set ourselves the task of creating the Union Flag of the United Kingdom, at time of writing there is still a problem with viewbox, TODO: fix viewbox. Here is the finished output


I want a number of classes to help me out.  I opened a new workbook and named the VBA project SVGHelper and add library references to Microsoft Scripting Runtime and Microsoft Xml, v6.0

First I wanted a SVGHelper.Point class.

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Point"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Const msMODULE As String = gsPROJECT & ".Point"

Private m_x As Double
Private m_y As Double

Public Sub SetPoint(ByVal dX As Double, ByVal dY As Double)
    m_x = dX
    m_y = dY
    
End Sub
Public Property Get x() As Double
    Const sSRC As String = msMODULE & ".x[PropertyGet]"
    x = m_x
End Property
Public Property Get y() As Double
    Const sSRC As String = msMODULE & ".y[PropertyGet]"
    y = m_y
End Property

Then I wanted a SVGHelper.Points class which is a collection of SVGHelper.Points, this will help us build a path step by step.



VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Points"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Const msMODULE As String = gsPROJECT & ".Points"


Private mdicPoints As Scripting.Dictionary

Private Sub Class_Initialize()
    Set mdicPoints = New Scripting.Dictionary
End Sub

Public Function Count() As Long
    Count = mdicPoints.Count
End Function

Public Function Item(ByVal idx As Long) As SVGHelper.Point
    Const sSRC As String = msMODULE & ".Item"

    If idx >= mdicPoints.Count Then Err.Raise vbObjectError, sSRC, "#Bad index!"
    Set Item = mdicPoints.Item(idx)
End Function

Public Function LastPoint() As SVGHelper.Point
    Const sSRC As String = msMODULE & ".LastPoint"
    If mdicPoints.Count = 0 Then Err.Raise vbObjectError, sSRC, "#Cannot have last point if point count is zero!"
    Set LastPoint = mdicPoints.Item(mdicPoints.Count - 1)

End Function

Public Function AddPoint(ByVal dX As Double, ByVal dY As Double) As SVGHelper.Point
    Const sSRC As String = msMODULE & ".AddPoint"
    Dim oPoint As SVGHelper.Point
    Set oPoint = CreatePoint(dX, dY)
    mdicPoints.Add mdicPoints.Count, oPoint

    Set AddPoint = oPoint

End Function

Public Function CreatePoint(ByVal dX As Double, ByVal dY As Double) As SVGHelper.Point
    Const sSRC As String = msMODULE & ".CreatePoint"
    Dim oPoint As SVGHelper.Point
    Set oPoint = New SVGHelper.Point
    oPoint.SetPoint dX, dY
    
    Set CreatePoint = oPoint
    
End Function
Next I wanted a SVGHelper.SVGPath which effectively inherits from the Points class and allows the calculation of the D attribute. Also, we ship some method to generate one path from another via a transform, the union flag is quite symmetrical and if you can find the path of a small blue triangle then you have all four by reflection.

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "SVGPath"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Const msMODULE As String = gsPROJECT & ".SvgPath"

Private moPoints As SVGHelper.Points

Private Sub Class_Initialize()
    Set moPoints = New SVGHelper.Points
End Sub

Public Function D_Attribute(Optional dLateScale As Double = 1, Optional dLateTransformX As Double = 0, Optional dLateTransformY As Double = 0) As String
    Const sSRC As String = msMODULE & ".D_Attribute"

    If moPoints.Count >= 1 Then
        Dim oMovePoint As SVGHelper.Point
        Set oMovePoint = moPoints.Item(0)
        D_Attribute = "M " & (oMovePoint.x * dLateScale) + dLateTransformX & "," & (oMovePoint.y * dLateScale) + dLateTransformY & " "
    End If
    
    Dim lPointLoop As Long
    For lPointLoop = 1 To moPoints.Count - 1
        Dim oPointLoop As SVGHelper.Point
        Set oPointLoop = moPoints.Item(lPointLoop)
        D_Attribute = D_Attribute & "L " & (oPointLoop.x * dLateScale) + dLateTransformX & "," & (oPointLoop.y * dLateScale) + dLateTransformY & " "
    Next lPointLoop
    
    

End Function

Public Function ReflectInBothXAndY() As SVGHelper.SVGPath

    Dim oNewPath As SVGHelper.SVGPath
    Set oNewPath = Me.ReflectInX
    Set oNewPath = oNewPath.ReflectInY
    Set ReflectInBothXAndY = oNewPath

End Function



Public Function ReflectInY() As SVGHelper.SVGPath

    Dim oNewPath As SVGHelper.SVGPath
    Set oNewPath = New SVGHelper.SVGPath
    
    Dim oMovePoint As SVGHelper.Point
    Set oMovePoint = moPoints.Item(0)
    oNewPath.SetMove -oMovePoint.x, oMovePoint.y

    Dim lPointLoop As Long
    For lPointLoop = 1 To moPoints.Count - 1
        Dim oPointLoop As SVGHelper.Point
        Set oPointLoop = moPoints.Item(lPointLoop)
        oNewPath.AddPoint -oPointLoop.x, oPointLoop.y, False
        
    Next lPointLoop
    
    Set ReflectInY = oNewPath
    

End Function

Public Function ReflectInX() As SVGHelper.SVGPath

    Dim oNewPath As SVGHelper.SVGPath
    Set oNewPath = New SVGHelper.SVGPath
    
    Dim oMovePoint As SVGHelper.Point
    Set oMovePoint = moPoints.Item(0)
    oNewPath.SetMove oMovePoint.x, -oMovePoint.y

    Dim lPointLoop As Long
    For lPointLoop = 1 To moPoints.Count - 1
        Dim oPointLoop As SVGHelper.Point
        Set oPointLoop = moPoints.Item(lPointLoop)
        oNewPath.AddPoint oPointLoop.x, -oPointLoop.y, False
        
    Next lPointLoop
    
    Set ReflectInX = oNewPath
    

End Function

Public Sub SetMove(ByVal dX As Double, ByVal dY As Double)
    Const sSRC As String = msMODULE & ".SetMove"
    If moPoints.Count <> 0 Then Err.Raise vbObjectError, sSRC, "#Move must be first point only!"
    
    moPoints.AddPoint dX, dY
    
End Sub

Public Sub AddPoint(ByVal dX As Double, ByVal dY As Double, ByVal bRelative As Boolean)
    Const sSRC As String = msMODULE & ".AddPoint"
    If bRelative Then Err.Raise vbObjectError, sSRC, "#Not yet implemented!"
    If moPoints.Count = 0 Then Err.Raise vbObjectError, sSRC, "#Must set move point first!"
    
    moPoints.AddPoint dX, dY
End Sub

Public Sub ClosePath()
    Const sSRC As String = msMODULE & ".ClosePath"
    If moPoints.Count = 0 Then Err.Raise vbObjectError, sSRC, "#Must set move point first!"

    Dim oFirstPoint As SVGHelper.Point
    Set oFirstPoint = moPoints.Item(0)

    moPoints.AddPoint oFirstPoint.x, oFirstPoint.y

End Sub


So I'm done with the re-useable helper classes, now I want a UnionJack class that calls into above helper classes

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "UnionJack" 
VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Const msMODULE As String = gsPROJECT & ".UnionJack"

Private dSqr5 As Double
Private d2Sqr5 As Double

Private Sub Class_Initialize()
    dSqr5 = Sqr(5)
    d2Sqr5 = 2 * Sqr(5)
End Sub


'Public Function TransformElement(ByVal dScale As Double) As String
'    TransformElement = "translate(" & 30 * dScale & "," & 15 * dScale & ")"
'End Function

Public Function StPatricksCrossBlade(ByVal idx As Long) As SVGHelper.SVGPath

    Dim oBlade As SVGHelper.SVGPath
    Set oBlade = New SVGHelper.SVGPath
    
    If idx Mod 2 = 0 Then
        
        oBlade.SetMove 30, 15
        oBlade.AddPoint 30, 15 - dSqr5, False
        oBlade.AddPoint 10 + d2Sqr5, 5, False
        oBlade.AddPoint 10, 5, False
        
        oBlade.ClosePath
        
        If idx = 2 Then Set oBlade = oBlade.ReflectInBothXAndY
    
    Else
        oBlade.SetMove 30, -15
        oBlade.AddPoint 30 - d2Sqr5, -15, False
        oBlade.AddPoint 10 - d2Sqr5, -5, False
        oBlade.AddPoint 10, -5, False
    
    
        oBlade.ClosePath
        If idx = 3 Then Set oBlade = oBlade.ReflectInBothXAndY
    
    End If

    Set StPatricksCrossBlade = oBlade
End Function


Public Function BlueTriangle(ByVal bSmall As Boolean, ByVal idx As Long) As SVGHelper.SVGPath
    Const sSRC As String = msMODULE & ".BlueTriangle"
    If idx < 0 Then Err.Raise vbObjectError, sSRC, "#idx must be in set {0,1,2,3}!"
    If idx > 3 Then Err.Raise vbObjectError, sSRC, "#idx must be in set {0,1,2,3}!"

    Dim oSvgPath As SVGHelper.SVGPath
    If bSmall Then

        Set oSvgPath = MySmallerBlueTriangle
    Else
        Set oSvgPath = MyLargerBlueTriangle
    End If
    
    If idx >= 1 Then Set oSvgPath = oSvgPath.ReflectInX
    If idx >= 2 Then Set oSvgPath = oSvgPath.ReflectInY
    If idx >= 3 Then Set oSvgPath = oSvgPath.ReflectInX

    Set BlueTriangle = oSvgPath

End Function


Private Function MyLargerBlueTriangle() As SVGHelper.SVGPath

    Dim oSvgPath As SVGHelper.SVGPath
    Set oSvgPath = New SVGHelper.SVGPath

    Dim dHalfLength As Double
    dHalfLength = (25 - (3 * Sqr(5))) / 2

    oSvgPath.SetMove 5, 15
    oSvgPath.AddPoint 5, 15 - dHalfLength, False
    oSvgPath.AddPoint 5 + dHalfLength + dHalfLength, 15, False
    oSvgPath.ClosePath

    Set MyLargerBlueTriangle = oSvgPath
End Function

Private Function MySmallerBlueTriangle() As SVGHelper.SVGPath

    Dim oSvgPath As SVGHelper.SVGPath
    Set oSvgPath = New SVGHelper.SVGPath

    Dim dHalfLength As Double
    dHalfLength = 10 - (3 * (Sqr(5) / 2))

    

    oSvgPath.SetMove 30, 5
    oSvgPath.AddPoint 30, 5 + dHalfLength, False
    oSvgPath.AddPoint 30 - dHalfLength - dHalfLength, 5, False
    oSvgPath.ClosePath

    Set MySmallerBlueTriangle = oSvgPath
End Function


Public Function EnglishCross() As SVGHelper.SVGPath

    Dim oSvgPath As SVGHelper.SVGPath
    Set oSvgPath = New SVGHelper.SVGPath

    Dim x As Double, y As Double
    x = 3: y = 3
    oSvgPath.SetMove x, y
    oSvgPath.AddPoint x + 27, y, False 'out to the east point
    oSvgPath.AddPoint x + 27, y - 6, False
    oSvgPath.AddPoint x, y - 6, False
    oSvgPath.AddPoint x, y - 6 - 12, False 'now over the top north point
    oSvgPath.AddPoint x - 6, y - 6 - 12, False
    oSvgPath.AddPoint x - 6, y - 6, False
    oSvgPath.AddPoint x - 6 - 27, y - 6, False 'out to the west point
    oSvgPath.AddPoint x - 6 - 27, y, False
    oSvgPath.AddPoint x - 6, y, False
    oSvgPath.AddPoint x - 6, y + 12, False 'now under the south point
    oSvgPath.AddPoint x, y + 12, False
    oSvgPath.AddPoint x, y, False 'finish


    Set EnglishCross = oSvgPath

End Function



Finally, I want some code to manipulate an Xml document because SVG is a type of Xml (or SGML strictly)

Attribute VB_Name = "modUnionJack"
Option Explicit
Option Private Module

'* References Microsoft Scripting Runtime
'* References Microsoft XML, v6.0

Public Const gsPROJECT As String = "SVGHelper"
Private Const msMODULE As String = gsPROJECT & ".modUnionJack"


Private Sub CreateFromScratch()

    Dim fso As Scripting.FileSystemObject
    Set fso = New Scripting.FileSystemObject
    
    Dim sSVGPath As String
    'sSVGPath = fso.BuildPath(ThisWorkbook.Path, "United Jack Red White And Blue VBA 2.svg")
    sSVGPath = "N:\UnionJack.svg"
    
    Dim txtOut As Scripting.TextStream
    Set txtOut = fso.CreateTextFile(sSVGPath)
    txtOut.WriteLine Chr$(60) & "?xml version=""1.0"" encoding=""UTF-8"" standalone=""no""?" & Chr$(62)
    txtOut.WriteLine Chr$(60) & "svg:svg xmlns:svg=""http://www.w3.org/2000/svg"" /" & Chr$(62)

    txtOut.Close
    Set txtOut = Nothing
    
    
    If fso.FileExists(sSVGPath) Then
    
        Dim dom As MSXML2.DOMDocument60
        Set dom = New MSXML2.DOMDocument60
        
        dom.Load sSVGPath
    
        Debug.Assert dom.parseError = 0
        
        Const csRED_STYLE As String = "fill:#cf142b;fill-opacity:1"
        Const csBLUE_STYLE As String = "fill:#00247d;fill-opacity:1"
        
        Dim xmlPaths As MSXML2.IXMLDOMNodeList
        'Set xmlPaths = dom.DocumentElement.SelectNodes("paths")
        'Debug.Assert Not xmlPaths Is Nothing
        
        'dom.setProperty "SelectionLanguage", "XPath"
        dom.setProperty "SelectionNamespaces", "xmlns:svg=""http://www.w3.org/2000/svg"""
        
        Dim xmlSVG As MSXML2.IXMLDOMElement
        Set xmlSVG = dom.SelectSingleNode("svg:svg")
        Call xmlSVG.setAttribute("viewbox", "0 0 600 300")
        'Call xmlSVG.setAttribute("width", "1200")
        'Call xmlSVG.setAttribute("height", "600")
        'Call xmlSVG.setAttribute("width", "210mm")
        'Call xmlSVG.setAttribute("height", "297mm")
        Call xmlSVG.setAttribute("version", "1.1")
        
        
        Dim xmlGTranslate As MSXML2.IXMLDOMElement
        Set xmlGTranslate = dom.createElement("svg:g")
        Call xmlGTranslate.setAttribute("id", "TranslateToCentre")
        
        Dim oUnionJack As UnionJack
        Set oUnionJack = New UnionJack
        
        '* last minute scale and transform to hard code
        Dim dScale As Double, dTransformX As Double, dTransformY As Double
        dScale = 10
        dTransformX = 300
        dTransformY = 150
        
        
        'Call xmlGTranslate.setAttribute("transform", oUnionJack.TransformElement)
        xmlSVG.appendChild xmlGTranslate
        dom.Save sSVGPath
        

        Dim xmlEnglishCross As MSXML2.IXMLDOMElement

        Dim xmlLineBreak As MSXML2.IXMLDOMText
        Set xmlLineBreak = dom.createTextNode(vbNewLine)
        
        Set xmlEnglishCross = dom.createElement("svg:path")
        Call xmlEnglishCross.setAttribute("id", "EnglishCross")
        Call xmlEnglishCross.setAttribute("style", csRED_STYLE)
        Call xmlEnglishCross.setAttribute("d", oUnionJack.EnglishCross.D_Attribute(dScale, dTransformX, dTransformY))

        xmlGTranslate.appendChild xmlEnglishCross
        xmlGTranslate.appendChild xmlLineBreak
        dom.Save sSVGPath
        
        Dim bSizeLoop As Long
        For bSizeLoop = True To False
            
            Dim lLoop As Long
            For lLoop = 0 To 3
                Dim oSvgLoop As SVGPath
                Set oSvgLoop = oUnionJack.BlueTriangle(bSizeLoop, lLoop)
                
                Dim sId As String
                sId = VBA.IIf(bSizeLoop, "Small", "Large") & "BlueTriangle" & lLoop
                

                               
                Dim xmlBlueTriangle As MSXML2.IXMLDOMElement
                Set xmlBlueTriangle = dom.createElement("svg:path")
                Call xmlBlueTriangle.setAttribute("id", sId)
                Call xmlBlueTriangle.setAttribute("style", csBLUE_STYLE)
                Call xmlBlueTriangle.setAttribute("d", oUnionJack.BlueTriangle(bSizeLoop, lLoop).D_Attribute(dScale, dTransformX, dTransformY))
                
                xmlGTranslate.appendChild xmlBlueTriangle
                xmlGTranslate.appendChild xmlLineBreak

            
            Next lLoop
            dom.Save sSVGPath
            
        
        Next bSizeLoop
        
        Dim lBlade As Long
        For lBlade = 0 To 3
            Dim oBlade As SVGPath
            Set oBlade = oUnionJack.StPatricksCrossBlade(lBlade)
            
            Dim xmlBlade As MSXML2.IXMLDOMElement
            Set xmlBlade = dom.createElement("svg:path")
            Call xmlBlade.setAttribute("id", "Blade" & lBlade)
            Call xmlBlade.setAttribute("style", csRED_STYLE)
            Call xmlBlade.setAttribute("d", oBlade.D_Attribute(dScale, dTransformX, dTransformY))
            
            xmlGTranslate.appendChild xmlBlade
        Next lBlade
        
        'dom.Save sSVGPath
        
        'dom.LoadXML StringFormatter.FormatXML(dom.xml)
        dom.Save sSVGPath
        
        
        

        'Stop
    End If


End Sub

Static classes in Excel VBA

From StackOverflow I have learnt a trick that allows static classes in Excel VBA, i.e. not having to use the New keyword. Now standard modules (.bas files) can serve the same purpose as a Static module but the VBA compiler will not insist on full qualification of a sub or function in a standard module. So if you want to enforce qualification to meet a coding standard then a Static class is useful.

A static class is also useful for those instances where you want static state, admitted the data will be global but so would a standard module! It would be useful to have a convention where a class called 'Foo' has a companion static class called say 'Foo_shared' or 'Foo_Static' or 'Foo_Common' to house those members which would be declared as static in languages such as C# or Java.

However, this technique requires a trick of exporting the module, editing an attribute, and re-importing. The attribute is VB_PredeclaredId which is by default False, edit this to True and reimport and you will get a Static class, it is the same mechanism by which Forms are static.

Here is example code in its raw form, ready to import

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "XmlFormatter"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Public Function FormatString(ByVal sCore As String, ParamArray Args())
    
    Dim lArgMax As Long
    lArgMax = UBound(Args())
    
    Dim lCharLen As Long
    lCharLen = VBA.Len(CStr(lArgMax))
    
    Dim lArgLoop As Long
    For lArgLoop = LBound(Args()) To lArgMax
        Dim sArgLoop As String
        sArgLoop = Right$(String$(lCharLen, "0") & CStr(lArgLoop), lCharLen)
    
        sCore = VBA.Replace(sCore, "%" & sArgLoop, Args(lArgLoop))
        'Debug.Print sCore
    Next lArgLoop
    
    FormatString = sCore

End Function

Reading a Directory Listing for Excel VBA code module files using VBA

If like me you are an Excel VBA developer and you code long enough with a codebase you get to the point when you'll need to clean the code.  Cleaning a VBA codebase requires exporting modules, deleting them and re-importing them.  You can get addins that do this for you or you can write your own quite simply.

When exporting the modules I tend to create a temp directory which means I have very many VBA module on my machine.  Sometimes I like to go browse code I have already written for re-use.   It would be nice to get a list of every VBA module on a drive.  This is today's post.

I've seen people write code to iterate through folders and files many times but this is tedious and actually not asynchronous or multi-threadable.  I like to use the command DIR *.* /s > c:\temp\cdrive_star_dot_star.txt to scan the whole hard drive into a text file, this is great for one part of the long running task as can be run in its own separate window but we'll still need code to loop through the piped output file.

The code will parse the directory output file and write to a sheet, but we add some value in that we look for .bas and .cls files, i.e. VBA files, but we ensure they are genuine VBA files by reading the first line and checking.  The results are written to Sheet1 periodically, the code uses DoEvents to stay responsive so you can begin browsing the results whilst the code is running.  Enjoy!

Option Explicit

Private m_fso As New Scripting.FileSystemObject
Private msDIR As String

Sub Test()

    '* my blog does not like angle brackets - grrrr!
    msDIR = " " & Chr$(60) & "DIR" & Chr$(62) & " "

    '* ASSUMES YOU HAVE DONE c:\dir *.* /s > c:\temp\cdrive_star_dot_star.txt

    Sheet1.Cells.Clear
    Dim sPipedOutputPath As String
    sPipedOutputPath = "c:\temp\cdrive_star_dot_star.txt"
    'sPipedOutputPath = "c:\temp\cdrive_test.txt"
    sPipedOutputPath = "c:\temp\cdrive_test2.txt"
    
    Dim dicLongListResults As Scripting.Dictionary
    
    
    Debug.Assert m_fso.FileExists(sPipedOutputPath)
    
    ReadDirForwardSlashS sPipedOutputPath, dicLongListResults
    
    Debug.Assert dicLongListResults.Count = _
      Sheet1.Cells(1, 1).CurrentRegion.Rows.Count
    
    
End Sub

Sub PasteResults(ByVal dicLongListResults As Scripting.Dictionary, _
          ByVal lResultIndex As Long)
    
    If dicLongListResults.Count > 0 Then
    
        Dim vResults As Variant
        vResults = Application.Transpose(dicLongListResults.Keys)
        
        Dim rngOrigin As Excel.Range
        Set rngOrigin = Sheet1.Cells(lResultIndex, 1)
        Debug.Assert IsEmpty(rngOrigin.Value)
        
        rngOrigin.Resize(dicLongListResults.Count) = vResults
        dicLongListResults.RemoveAll
    End If

End Sub

Function ReadDirForwardSlashS(ByVal sPipedOutputPath As String, _
                ByRef pdicLongListResults As Scripting.Dictionary)

    Dim lResultIndex As Long: lResultIndex = 1
    Dim lSavedResultIndex As Long: lSavedResultIndex = 1
    
    Dim dicInterimResults As Scripting.Dictionary
    Set dicInterimResults = New Scripting.Dictionary
    
    If m_fso.FileExists(sPipedOutputPath) Then
    
        Dim txtIn As Scripting.TextStream
        Set txtIn = m_fso.OpenTextFile(sPipedOutputPath)
        
        Set pdicLongListResults = New Scripting.Dictionary
        
        Dim lLineNumber As Long
        lLineNumber = 0
        
        Dim sLine As String
        sLine = txtIn.ReadLine
        While Not txtIn.AtEndOfStream
            DoEvents
            lLineNumber = lLineNumber + 1
            
            Dim bIsFileHeader As Boolean
            bIsFileHeader = IsFileHeader(sLine, lLineNumber)
            
            Dim bIsBlankLine As Boolean
            bIsBlankLine = IsBlankLine(sLine)
            
            Dim sDirectory As String
            Dim bIsDirectoryHeader As Boolean
            bIsDirectoryHeader = IsDirectoryHeader(sLine, sDirectory)
            
            Dim bIsTrailerLine As Boolean
            bIsTrailerLine = IsTrailerLine(sLine)
            
            If bIsTrailerLine Then
            
                PasteResults dicInterimResults, lSavedResultIndex
                lSavedResultIndex = lResultIndex
            
            End If
            
            
            Dim bIsEntryLine As Boolean
            bIsEntryLine = (Not bIsFileHeader) And (Not bIsDirectoryHeader) And _
                    (Not bIsTrailerLine) And (Not bIsBlankLine)
            
            Dim bIsFileLine As Boolean
            bIsFileLine = IsFileLine(bIsEntryLine, sLine)
            
            If bIsFileLine Then
                Dim sFileName As String
                sFileName = Trim$(Mid$(sLine, 37))
                
                Dim sLastFourChars As String
                sLastFourChars = Right$(sFileName, 4)
                
                Dim lFileTypeFound As Long
                lFileTypeFound = InStr(1, "|.bas|.cls|", "|" & sLastFourChars & _
                            "|", vbTextCompare)
                If lFileTypeFound > 0 Then
                
                    Dim lFileType As Long
                    lFileType = (lFileTypeFound - 1) / 5
                
                    Dim sFullPath As String
                    sFullPath = m_fso.BuildPath(sDirectory, sFileName)
                    
                    Debug.Assert m_fso.FileExists(sFullPath)
                    
                    Dim txtFileContents As Scripting.TextStream
                    Set txtFileContents = m_fso.OpenTextFile(sFullPath)
                
                    If Not txtFileContents.AtEndOfStream Then
                        Dim sTopLine As String
                        sTopLine = txtFileContents.ReadLine
                                            
                        Dim bIsVBAFile As Boolean
                        If lFileType = 0 Then
                            bIsVBAFile = (Left$(sTopLine, 19) = "Attribute VB_Name =")
                        Else
                            bIsVBAFile = (Left$(sTopLine, 17) = "VERSION 1.0 CLASS")
                        End If
                        
                        txtFileContents.Close
                        Set txtFileContents = Nothing
                        
                        If bIsVBAFile Then
                            pdicLongListResults.Add sFullPath, lFileType
                            dicInterimResults.Add sFullPath, lFileType
                            lResultIndex = lResultIndex + 1
                        End If
                    End If
                    'Stop
                End If
            End If
            
            sLine = txtIn.ReadLine
        Wend
        
        txtIn.Close
        Set txtIn = Nothing
    End If

End Function

Function IsTrailerLine(ByVal sLine As String) As Boolean
    If (VBA.InStr(1, sLine, "File(s)", vbTextCompare) > 0) Then
        IsTrailerLine = True
    End If
End Function


Function IsBlankLine(ByVal sLine As String) As Boolean
    IsBlankLine = (Len(Trim(sLine)) = 0)
End Function

Function IsFileLine(ByVal bIsEntryLine As Boolean, ByVal sLine As String) As Boolean
    If bIsEntryLine Then
        If (VBA.InStr(1, sLine, msDIR, vbTextCompare) = 0) Then
            IsFileLine = True
        End If
    End If
End Function

Function IsSubdirectoryLine(ByVal bIsEntryLine As Boolean, ByVal sLine As String) As Boolean
    If bIsEntryLine Then
        If (VBA.InStr(1, sLine, msDIR, vbTextCompare) > 0) Then
            IsSubdirectoryLine = True
        End If
    End If
End Function

Function IsDirectoryHeader(ByVal sLine As String, ByRef psDirectory As String) As Boolean
    If VBA.InStr(1, sLine, " Directory of ", vbTextCompare) > 0 Then
        psDirectory = Trim(Mid$(sLine, 15))
        IsDirectoryHeader = True
    End If
End Function

Function IsFileHeader(ByVal sLine As String, ByVal lLineNumber As Long) As Boolean
    If lLineNumber <= 2 Then
        IsFileHeader = (VBA.InStr(1, sLine, " Volume ", vbTextCompare) > 0)
    End If
End Function