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
Friday, 17 February 2017
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.
Ok so the MSDN article on Programming with CComBSTR (ATL) also gives a similar warning
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.
to which is given an extremely interesting replyP.S. Very ruefully that neither _bstr_t nor CComBSTR doesn't support real string interface with [R|L]Trim, SubString, UpperCase and others.
wow, "BSTRs should be treated as data exchange format", very interesting.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.
Ok so the MSDN article on Programming with CComBSTR (ATL) also gives a similar warning
So it seems Microsoft are tipping CStringT as a good class for Unicode and lo and behold this class has a Trim function CStringT::TrimAs 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.
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.
If you want some code to analyze what is going on then try this
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.
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
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
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
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...
Here is the standard module modScripts.bas It was generated by module above
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
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
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.
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
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
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
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
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
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!
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
Subscribe to:
Posts (Atom)