Archive for the ‘VBA’ Category.

Converting Numbers to Words Part V

See Converting Numbers to Words Part IV

No need to bite this one off in small chunks. Just need to make sure the triplets processing works at the next level.

Sub TEST_Millions()
   
    Debug.Assert NumbersToWords(1000000) = "one million"
    Debug.Assert NumbersToWords(1000001) = "one million one"
    Debug.Assert NumbersToWords(20000000) = "twenty million"
    Debug.Assert NumbersToWords(55555000) = "fifty-five million five hundred fifty-five thousand"
    Debug.Assert NumbersToWords(999999999) = "nine hundred ninety-nine million nine hundred ninety-nine thousand nine hundred ninety-nine"
   
End Sub

I’m just going to add a new If block for millions that looks a lot like the thousands If block. Of course I’ll be using exponents so I don’t have to type all those zeros.

Function NumbersToWords(ByVal dNumbers As Double) As String
   
    Dim sReturn As String
    Dim dRemainder As Double
   
    If dNumbers = 0 Then
        sReturn = "zero"
    Else
       
        dRemainder = dNumbers
       
        If dRemainder >= 10 ^ 6 Then
            sReturn = ProcessTriplet(dRemainder \ 10 ^ 6, "million")
            dRemainder = dRemainder - ((dRemainder \ 10 ^ 6) * 10 ^ 6)
        End If
       
        If dRemainder >= 1000 Then
            sReturn = sReturn & Space(1) & ProcessTriplet(dRemainder \ 1000, "thousand")
            dRemainder = dRemainder - ((dRemainder \ 1000) * 1000)
        End If
       
        If dRemainder > 0 Then
            sReturn = sReturn & Space(1) & ProcessTriplet(dRemainder)
        End If
       
    End If
   
    NumbersToWords = Trim$(sReturn)
   
End Function

All tests passed. The rest should be easy. I’m going to go a little sparse on the next tests.

Sub TEST_More()
   
    Debug.Assert NumbersToWords(1 * 10 ^ 9) = "one billion"
    Debug.Assert NumbersToWords(1000000001) = "one billion one"
    Debug.Assert NumbersToWords(999999999999999#) = "nine hundred ninety-nine trillion nine hundred ninety-nine billion nine hundred ninety-nine million nine hundred ninety-nine thousand nine hundred ninety-nine"
   
End Sub

I could create a new If block for each triplet, but I already know I’ll be refactoring, so what’s the point. I need to loop through however many triplets are there and process them.

Function NumbersToWords(ByVal dNumbers As Double) As String
   
    Dim sReturn As String
    Dim dRemainder As Double
    Dim vaTriplets As Variant
    Dim i As Long
   
    vaTriplets = Split(",,,thousand,,,million,,,billion,,,trillion", ",")
   
    If dNumbers = 0 Then
        sReturn = "zero"
    Else
       
        dRemainder = dNumbers
       
        For i = 12 To 0 Step -3
            If dRemainder >= 10 ^ i Then
                sReturn = sReturn & Space(1) & ProcessTriplet(dRemainder \ 10 ^ i, vaTriplets(i))
                dRemainder = dRemainder - ((dRemainder \ 10 ^ i) * 10 ^ i)
            End If
        Next i
       
    End If
   
    NumbersToWords = Trim$(sReturn)
   
End Function

Error: Overflow. I originally passed in a Double so I could do decimals, but never did the decimals. Anyway, it’s the integer division operator (\) that’s causing the problem. When you use a floating point number, like a Double, in an integer division expression, VBA casts it as a Long first. So anything more than 2.4 billion won’t work. Fortunately, MS has a fix.

Function NumbersToWords(ByVal dNumbers As Double) As String
   
    Dim sReturn As String
    Dim dRemainder As Double
    Dim vaTriplets As Variant
    Dim i As Long
    Dim lFixed As Long
   
    vaTriplets = Split(",,,thousand,,,million,,,billion,,,trillion", ",")
   
    If dNumbers = 0 Then
        sReturn = "zero"
    Else
       
        dRemainder = dNumbers
       
        For i = 12 To 0 Step -3
            If dRemainder >= 10 ^ i Then
                lFixed = Fix(Int(dRemainder + 0.5) / 10 ^ i)
                sReturn = sReturn & Space(1) & ProcessTriplet(lFixed, vaTriplets(i))
                dRemainder = dRemainder - (lFixed * 10 ^ i)
            End If
        Next i
       
    End If
   
    NumbersToWords = Trim$(sReturn)
   
End Function

All tests passed. And that’s it. I could add decimals, I suppose. Or even larger numbers.

The test-first methodology was pretty enjoyable, I have to say. This isn’t especially complicated code, but biting it off in small chunks made things flow nicely.

Converting Numbers to Words Part III

See Converting Numbers to Words Part II

My tests work from 0-99. The next test will test numbers between 100-199.

Sub TEST_OneHundred()

    Debug.Assert NumbersToWords(100) = "one hundred"
    Debug.Assert NumbersToWords(110) = "one hundred ten"
    Debug.Assert NumbersToWords(119) = "one hundred nineteen"
    Debug.Assert NumbersToWords(120) = "one hundred twenty"
    Debug.Assert NumbersToWords(121) = "one hundred twenty-one"
    Debug.Assert NumbersToWords(150) = "one hundred fifty"
    Debug.Assert NumbersToWords(188) = "one hundred eighty-eight"
    Debug.Assert NumbersToWords(199) = "one hundred ninety-nine"

End Sub

A haphazard selection of numbers including the edge cases.

Function NumbersToWords(ByVal dNumbers As Double) As String
   
    Dim vaSingles As Variant
    Dim vaTens As Variant
    Dim sReturn As String
   
    vaSingles = Split("zero,one,two,three,four,five,six,seven,eight,nine,ten,eleven,twelve,thirteen,fourteen,fifteen,sixteen,seventeen,eighteen,nineteen", ",")
    vaTens = Split("NA,NA,twenty,thirty,forty,fifty,sixty,seventy,eighty,ninety", ",")
       
    If dNumbers >= 100 Then
        sReturn = "one hundred"
        If dNumbers Mod 100 <> 0 Then
            If dNumbers - 100 > 19 Then
                sReturn = sReturn & Space(1) & vaTens((dNumbers - 100) \ 10)
                If (dNumbers - 100) Mod 10 <> 0 Then
                    sReturn = sReturn & "-" & vaSingles((dNumbers - 100) - (((dNumbers - 100) \ 10) * 10))
                End If
            Else
                sReturn = sReturn & Space(1) & vaSingles(dNumbers - 100)
            End If
        End If
       
    ElseIf dNumbers > 19 Then
        sReturn = vaTens(dNumbers \ 10)
        If dNumbers Mod 10 <> 0 Then
            sReturn = sReturn & "-" & vaSingles(dNumbers - ((dNumbers \ 10) * 10))
        End If
    Else
        sReturn = vaSingles(dNumbers)
    End If
   
   
    NumbersToWords = Trim$(sReturn)
   
End Function

And all tests pass. Back in the first post of this series I said that I hoped it would be obvious when I need to refactor. Well if this isn’t a frying pan to the face, I don’t know what is. Way too much repetition, for one. I need to introduce a “remainder” variable, so that once I process the hundred part, I can send the remainder to process the tens, and the remainder from that to the less than 19 part.

Function NumbersToWords(ByVal dNumbers As Double) As String

    Dim vaSingles As Variant
    Dim vaTens As Variant
    Dim sReturn As String
    Dim dRemainder As Double

    vaSingles = Split("zero,one,two,three,four,five,six,seven,eight,nine,ten,eleven,twelve,thirteen,fourteen,fifteen,sixteen,seventeen,eighteen,nineteen", ",")
    vaTens = Split("zero,zero,twenty,thirty,forty,fifty,sixty,seventy,eighty,ninety", ",")

    dRemainder = dNumbers

    If dRemainder >= 100 Then
        sReturn = "one hundred" & Space(1)
        dRemainder = dRemainder - (dRemainder \ 100) * 100
    End If

    If dRemainder > 19 Then
        sReturn = sReturn & vaTens(dRemainder \ 10)
        dRemainder = dRemainder - (dRemainder \ 10) * 10
    End If

    If dRemainder > 0 Then
        If Right(sReturn, 1) = "y" Then
            sReturn = sReturn & "-"
        End If

        sReturn = sReturn & vaSingles(dRemainder)
    End If

    NumbersToWords = Trim$(sReturn)

End Function

That looks much better, but it doesn’t pass the zero test. I don’t like special cases, but zero might just be one, so I’m going to force it. My conditional on whether to include a hyphen checks to see if the answer so far ends in “y”. That seems a little hokey, but it works. I could test for mod10 and set a Boolean variable in the If block above, but I’m not sure what I gain, so there it stays.

Refactoring in this way also makes the next bit of testing code painfully obvious. I’m hardcoding “one hundred”, but with vaSingles sitting right there, I don’t know why I can’t go above 199 pretty easily. So I’ll write that next test.

Sub TEST_Hundreds()

    Debug.Assert NumbersToWords(200) = "two hundred"
    Debug.Assert NumbersToWords(310) = "three hundred ten"
    Debug.Assert NumbersToWords(419) = "four hundred nineteen"
    Debug.Assert NumbersToWords(520) = "five hundred twenty"
    Debug.Assert NumbersToWords(621) = "six hundred twenty-one"
    Debug.Assert NumbersToWords(750) = "seven hundred fifty"
    Debug.Assert NumbersToWords(888) = "eight hundred eighty-eight"
    Debug.Assert NumbersToWords(999) = "nine hundred ninety-nine"

End Sub

Instead of hardcoding “one hundred”, I’ll pull the property number from vaSingles. This also shows my brute force zero fix.

Function NumbersToWords(ByVal dNumbers As Double) As String

    Dim vaSingles As Variant
    Dim vaTens As Variant
    Dim sReturn As String
    Dim dRemainder As Double

    vaSingles = Split("zero,one,two,three,four,five,six,seven,eight,nine,ten,eleven,twelve,thirteen,fourteen,fifteen,sixteen,seventeen,eighteen,nineteen", ",")
    vaTens = Split("zero,zero,twenty,thirty,forty,fifty,sixty,seventy,eighty,ninety", ",")

    If dNumbers = 0 Then
        sReturn = "zero"
    Else

        dRemainder = dNumbers
   
        If dRemainder >= 100 Then
            sReturn = sReturn & vaSingles(dRemainder \ 100) & " hundred "
            dRemainder = dRemainder - (dRemainder \ 100) * 100
        End If
   
        If dRemainder > 19 Then
            sReturn = sReturn & vaTens(dRemainder \ 10)
            dRemainder = dRemainder - (dRemainder \ 10) * 10
        End If
   
        If dRemainder > 0 Then
            If Right(sReturn, 1) = "y" Then
                sReturn = sReturn & "-"
            End If
   
            sReturn = sReturn & vaSingles(dRemainder)
        End If
    End If

    NumbersToWords = Trim$(sReturn)

End Function

All tests pass. And the code doesn’t look too bad. Only infinity numbers left to test. Here’s what my main testing procedure looks like now, as if you couldn’t guess.

Sub TEST_All()

    TEST_Singles
    TEST_Tens
    TEST_OneHundred
    TEST_Hundreds

    Debug.Print "tests passed"

End Sub

Converting Numbers To Words Part II

See Converting Numbers To Words Part I.

The next test will test 20-99. I think in real TDD, you’re supposed to write tests that test just one thing. But I’m not doing real TDD, so I’m testing in groups.

Sub TEST_Tens()

    Debug.Assert NumbersToWords(20) = "twenty"
    Debug.Assert NumbersToWords(21) = "twenty-one"
    Debug.Assert NumbersToWords(30) = "thirty"
    Debug.Assert NumbersToWords(77) = "seventy-seven"
    Debug.Assert NumbersToWords(99) = "ninety-nine"

End Sub

Again, I’m testing the edges and few in between. Now that I have two test procedures, I’ll need to create a procedure to run them both.

Sub TEST_All()

    TEST_Singles
    TEST_Tens

    Debug.Print "tests passed"

End Sub

Now I can run TEST_All and make sure I don’t break any previous tests with the changes I make. Of course, TEST_Tens fails so it’s time to write some code to make it pass. I tried to write the simplest code possible, but it didn’t work out for me.

Function NumbersToWords(ByVal dNumbers As Double) As String
   
    Dim vaSingles As Variant
    Dim vaTens As Variant
    Dim sReturn As String
   
    vaSingles = Split("zero,one,two,three,four,five,six,seven,eight,nine,ten,eleven,twelve,thirteen,fourteen,fifteen,sixteen,seventeen,eighteen,nineteen", ",")
    vaTens = Split("NA,NA,twenty,thirty,forty,fifty,sixty,seventy,eighty,ninety", ",")
   
    If dNumbers > 19 Then
        sReturn = vaTens(dNumbers \ 10) & "-" & vaSingles(dNumbers - ((dNumbers \ 10) * 10))
    Else
        sReturn = vaSingles(dNumbers)
    End If
   
    NumbersToWords = Trim$(sReturn)
   
End Function

That fails because NumbersToWords(20) returns twenty-zero. So there’s a special case that needs to be handled.

Function NumbersToWords(ByVal dNumbers As Double) As String
   
    Dim vaSingles As Variant
    Dim vaTens As Variant
    Dim sReturn As String
   
    vaSingles = Split("zero,one,two,three,four,five,six,seven,eight,nine,ten,eleven,twelve,thirteen,fourteen,fifteen,sixteen,seventeen,eighteen,nineteen", ",")
    vaTens = Split("NA,NA,twenty,thirty,forty,fifty,sixty,seventy,eighty,ninety", ",")
   
    If dNumbers > 19 Then
        sReturn = vaTens(dNumbers \ 10)
        If dNumbers Mod 10 <> 0 Then
            sReturn = sReturn & "-" & vaSingles(dNumbers - ((dNumbers \ 10) * 10))
        End If
    Else
        sReturn = vaSingles(dNumbers)
    End If
   
   
    NumbersToWords = Trim$(sReturn)
   
End Function

That works. But I can see this special case handling becoming a problem. Maybe. We’ll see what happens when we test in the hundreds.

Converting Numbers To Words Part I

I overheard two people talking, one of whom was showing his intellectual prowess using that puzzle whose answer is always ‘four’. I don’t remember the specifics of the game, but you count the letters of an integer, do some basic math, and you always end up with ‘four’ because the word ‘four’ has that many letters in it. I get how it works, but I thought there’s surely another number with that property. Off to VBA to find out.

There’s not. But let me back up a bit. I searched the vast DDoE archives to find my Numbers-to-Words code. I’ve already written this code right? Apparently not. A broader search showed plenty of hits and, I’m sure, code, but I didn’t click any of the links. I’ve been hankering to write some test-first code and this seemed like a good candidate. I didn’t want to read anybody else’s code so it wouldn’t influence my test-first experience.

I’m going to document my test-first methodology in a series of posts. This is not test driven development (TDD), but borrows some of the principles from that. Basically, I write a test, watch it fail, then write enough code to make it pass. I refactor the code as necessary. If you are interested in TDD in Excel and VBA, search for xlUnit on Mike Woodhouse’s blog.

On to test 1! The idea is to write a function that returns a string that represents the English words of the argument. The procedure header should look like this:

Function NumbersToWords(ByVal dNumbers As Double) As String

First, write a test.

Sub TEST_Singles()
   
    Debug.Assert NumbersToWords(0) = "zero"
    Debug.Assert NumbersToWords(1) = "one"
    Debug.Assert NumbersToWords(7) = "seven"
    Debug.Assert NumbersToWords(19) = "nineteen"
   
End Sub

I know that once I hit 20 a pattern will start emerging, so I’m going to start by testing up to 19. Now I have to write enough code to make this pass. That’s seems pretty easy.

Function NumbersToWords(ByVal dNumbers As Double) As String
   
    Dim vaSingles As Variant
   
    vaSingles = Split("zero,one,two,three,four,five,six,seven,eight,nine,ten,eleven,twelve,thirteen,fourteen,fifteen,sixteen,seventeen,eighteen,nineteen", ",")
   
    NumbersToWords = vaSingles(dNumbers)
   
End Function

When I run that test, it passes. I put all the words for zero to 19 in an array, then read the array. What could be easier? For my tests, I choose the two edge cases (0 and 19) and a couple in the middle. It’s not very rigorous, but what the heck. One of the benefits of a test-first approach is that you’re biting off a bigger problem in smaller chunks. No single code revision is particularly difficult, but when put together can be complex. The refactoring part will be the interesting part. I assume it will be apparent when it’s time to refactor (as it is in examples I’ve seen) but I’ve never done it before, so we’ll see.

Next time, I’ll test some ‘tens’.

Avoiding Date Conversion When Pasting an HTML Table

From Get Data From a Website…, MD comments:

However, the info in the table I copy is formatted ## / ## whereby # represents a number.
So when it tries to paste 10 / 10 in the worksheet for example, it auto-changes to 10/okt in my sheet.

This is a common problem that’s hard to solve. There’s no setting I can find in Excel that tells it to stop converting things that look like dates into dates. Since I’m reading in the data and putting it in the clipboard, I can just message the data before I do it. That’s not so easy when you just want to copy and paste, but if you’re using code, you may find the technique useful.

In the above linked post, I automated Internet Explorer to login to a website. I don’t automate Internet Explorer any more, preferring XML instead. But it doesn’t matter which you use. It all ends up in an HTMLDocument, so it’s the same from there. Also, this example doesn’t log into a webpage. It uses Contextures’ Sample Data.

Sub GetTableNoDateConversion()
   
    Dim xHttp As MSXML2.XMLHTTP
    Dim hDoc As MSHTML.HTMLDocument
    Dim hTable As MSHTML.HTMLTable
    Dim hCell As MSHTML.HTMLTableCell
    Dim doClip As MSForms.DataObject
   
    'Get the webpage
    Set xHttp = New MSXML2.XMLHTTP
    xHttp.Open "GET", "http://www.contextures.com/xlSampleData01.html"
    xHttp.send
   
    'Wait for it to load
    Do: DoEvents: Loop Until xHttp.readyState = 4
   
    'Put it in a document
    Set hDoc = New MSHTML.HTMLDocument
    hDoc.body.innerHTML = xHttp.responseText
   
    'Find the third table
    Set hTable = hDoc.getElementsByTagName("table").Item(2)
   
    'Fix anything that looks like a date
    For Each hCell In hTable.Cells
        If IsDate(hCell.innerText) Then
            hCell.innerText = "'" & hCell.innerText
        End If
    Next hCell
   
    'put it in the clipboard
    Set doClip = New MSForms.DataObject
    doClip.SetText "<html>" & hTable.outerHTML & "</html>"
    doClip.PutInClipboard
   
    'paste it to the sheet
    Sheet1.Select
    Sheet1.Range("A1").Select
    Sheet1.PasteSpecial "Unicode Text"
   
    'Make the leading apostrophes go away
    Sheet1.Range("A1").CurrentRegion.Value = Sheet1.Range("A1").CurrentRegion.Value
   
End Sub

Once I get the table into an HTMLTable object, I loop through all the HTMLTableCells to see if any of them looks like a date. If so, I put an apostrophe in front of it. The apostrophe is the Excel way to say “No matter what I type next, assume it’s text”. Except when you’re pasting special as Unicode Text. In that case, it doesn’t hide the apostrophe like it should. So the last line of the code is the equivalent of pressing F2 and Enter all the say down the column and forcing Excel to reevaluate its decision to ignore that apostrophe.

Find Your Dropbox Folder in VBA

Here’s a function to get the location of the Dropbox folder:

Public Function DropBox() As String
   
    Dim DropboxHostFile As String
    Dim DropboxHostFileNumber As Long
    Dim Base64EncodedPath As String
    Dim TempXMLDocument As MSXML2.DOMDocument60
    Dim Base64XMLNode As MSXML2.IXMLDOMElement
   
    DropboxHostFile = Environ("appdata") & "\Dropbox\host.db"
    DropboxHostFileNumber = FreeFile
   
    Open DropboxHostFile For Input As DropboxHostFileNumber
    Base64EncodedPath = Input$(LOF(DropboxHostFileNumber), DropboxHostFileNumber)
    Close DropboxHostFileNumber
   
    Set TempXMLDocument = New MSXML2.DOMDocument60
    Set Base64XMLNode = TempXMLDocument.createElement("b64")
    Base64XMLNode.DataType = "bin.base64"
    Base64XMLNode.Text = Split(Base64EncodedPath, vbLf)(1)
   
    DropBox = StrConv(Base64XMLNode.nodeTypedValue, vbUnicode)
   
End Function

According to Reinaldo there is a host.db file in the Roaming directory that stores this information. The Environ("appdata") function returns the Roaming directory in Win7. I open host.db and read in the text. Then I create a new XML document, thanks to Tim Hastings, to write in the Base64 text and read out the byte data that is converted to Unicode. There’s two lines in my host.db file, so I split on vbLf and only use the second line.

Here’s what it would look like if I wrote this function and didn’t want to poke my eyes out afterward.

Public Function DropBox() As String
   
    Dim sFile As String
    Dim lFile As Long
    Dim sPath As String
    Dim xDoc As MSXML2.DOMDocument60
    Dim xNode As MSXML2.IXMLDOMElement
   
    sFile = Environ("appdata") & "\Dropbox\host.db"
    lFile = FreeFile
   
    Open sFile For Input As lFile
    sPath = Input$(LOF(lFile), lFile)
    Close lFile
   
    Set xDoc = New MSXML2.DOMDocument60
    Set xNode = xDoc.createElement("b64")
    xNode.DataType = "bin.base64"
    xNode.Text = Split(sPath, vbLf)(1)
   
    DropBox = StrConv(xNode.nodeTypedValue, vbUnicode)
   
End Function

Printing Labels on a Dymo LabelWriter 450 from VBA

How’s that title for Google-ability. Pretty saucy, I’d say. Here’s an affiliate link if you’re in the market for one of these label printers.


LabelWriter 450

Back in 2010, I was printing labels on a Dymo from VBA. At my current job, I had occasion to do it again, so I bought a LabelWriter 450 from Amazon. Seventy-five bucks! What a deal.

Previously I didn’t need anything fancy formatting-wise. I could just push some text at a DymoLabels object and print it. I’m not so lucky this time around. I really needed some underlines for visual separation of data. I don’t see any way to underline stuff through the Dymo object model. But what I did discover was that the .label files created by their software are just XML files. Woot!

Rather than trying to navigate a klunky object model, I can just write to a text file. Here’s what the new labels look like.

And here’s a piece of the XML file.

                <Element>
                    <String>Int BOL  Ext BOL     Gallons   Price        Total
</String>
                    <Attributes>
                        <Font Family="Courier New" Size="10" Bold="True" Italic="False" Underline="True" Strikeout="False" />
                        <ForeColor Alpha="255" Red="0" Green="0" Blue="0" />
                    </Attributes>
                </Element>
                <Element>
                    <String>         22753         6,418   2.9775   19,109.60
18318    24094018        830   3.3361    2,768.93
18318    0           </String>
                    <Attributes>
                        <Font Family="Courier New" Size="10" Bold="True" Italic="False" Underline="False" Strikeout="False" />
                        <ForeColor Alpha="255" Red="0" Green="0" Blue="0" />
                    </Attributes>
                </Element>

The XML isn’t terribly pretty mostly because there are line feeds in there. Without the line feeds, I think it would be indented properly. Each Element tag has a String tag and an Attributes tag. It looks like every font attribute is listed whether you specifically set it or not. I’m also padding my text with spaces to line up columns. I could use multiple text boxes, but there is no grid control. For now, this works. The only downside to using one big textbox and space padding is that I have to use a fixed-width font – Courier New in this case. If I want to use a nicer font, I’ll have to go the multiple textbox route.

I have this form for data input and a button to print the label. The button kicks off the code below. I don’t need the mdyLabel variable any more because I’m not using that part of the object model. Instead of mdyLabel, I’m manipulating the XML file directly giving me more control.

Sub PrintBlendCalc()

    Dim vaPrinters As Variant
    Dim i As Long
    Dim sFile As String
   
    Const sMSGNODYMO As String = "Dymo label printer not found."
   
     If mdyAddin Is Nothing Then
         CreateDymoObjects
     End If
   
     If Not mdyAddin Is Nothing Then
         vaPrinters = Split(mdyAddin.GetDymoPrinters, "|")
         For i = LBound(vaPrinters) To UBound(vaPrinters)
             If mdyAddin.IsPrinterOnline(vaPrinters(i)) Then
                 mdyAddin.SelectPrinter vaPrinters(i)
                 Exit For
             End If
         Next i
         
         UpdateLabelFile sFile
         mdyAddin.Open sFile
         mdyAddin.Print2 1, True, 1
     Else
         MsgBox sMSGNODYMO, vbOKOnly
     End If

End Sub

Instead of using the SetField method (like in the previous example), I call a new procedure called UpdateLabel file to create a new XML file. Then I open the file and print it.

Public Sub UpdateLabelFile(ByRef sFile As String)
   
    Dim xDoc As MSXML2.DOMDocument
    Dim xStrings As MSXML2.IXMLDOMSelection
    Dim vaData As Variant
   
    'Get the label data in an array
    vaData = wshBlendCalc.Range("B2").Resize(7, 5).Value
   
    'Create a new XML Doc and load the template label
    Set xDoc = New MSXML2.DOMDocument
    xDoc.Load msLABELPATH & "BlendCalc.label"
   
    'Get all the "String" elements (there are 4)
    Set xStrings = xDoc.getElementsByTagName("String")
   
    'Change the text of the four string elements
    xStrings(0).Text = FormatLabelText(vaData, 1)
    xStrings(1).Text = FormatLabelText(vaData, 2) & FormatLabelText(vaData, 3)
    xStrings(2).Text = FormatLabelText(vaData, 4)
    xStrings(3).Text = FormatLabelText(vaData, 5) & FormatLabelText(vaData, 6) & FormatLabelText(vaData, 7)
   
    'Save the XML file
    sFile = msLABELPATH & "NewOrders\" & vaData(2, 2) & "_blend.label"
    xDoc.Save sFile
   
    'Save the data to a text file for those people who don't read XML that well
    Open msLABELPATH & "NewOrders\" & vaData(2, 2) & "_blend.txt" For Output As #1
    Print #1, FormatLabelText(vaData, 1) & _
        FormatLabelText(vaData, 2) & _
        FormatLabelText(vaData, 3) & _
        FormatLabelText(vaData, 4) & _
        FormatLabelText(vaData, 5) & _
        FormatLabelText(vaData, 6) & _
        FormatLabelText(vaData, 7)
    Close #1
   
End Sub

There are four elements in my XML file. The first label line is underlined, so that gets its own element. The second and third lines and a portion of the fourth line have the same attributes, so they’re grouped into one element. The portion of the fourth line that is underlined is in the third element. And all the rest of the text goes into the fourth element. The elements are set and the attributes are just the way I want them, so all that is left is to update the text.

I pass the array into a FormatLabelText function which extracts the data I want and pads the spaces so the columns line up. The FormatLabelText function is shown below.

I pass the sFile variable ByRef into UpdateLabelFile. The sFile variable is set and retains that value back in the calling procedure so the calling procedure knows which file to open and print.

The FormatLabelText function takes the array and whichever row we’re interested in formatting. It starts by defining three arrays: vaBuffer defines how much padding for each of the five columns; vaAlignLeft defines if the columns are aligned right or left; and vaFormat defines the number format for each of the five column (@ is the format for general text).

Public Function FormatLabelText(ByRef vaData As Variant, ByVal lIndex As Long) As String
   
    Dim sReturn As String
    Dim vaBuffer As Variant
    Dim vaAlignLeft As Variant
    Dim vaFormat As Variant
    Dim sData As String
    Dim j As Long
   
    vaBuffer = Array(9, 11, 11, 8, 10)
    vaAlignLeft = Array(True, True, False, False, False)
    vaFormat = Array("@", "@", "#,##0", "0.0000", "###,##0.00")
   
    For j = LBound(vaData, 2) To UBound(vaData, 2)
        sData = Format(vaData(lIndex, j), vaFormat(j - 1))
        If Len(sData) = 0 Then
            sData = Space(vaBuffer(j - 1))
        ElseIf Len(sData) > vaBuffer(j - 1) Then
            sData = Left$(sData, vaBuffer(j - 1) - 1) & Chr$(133)
        ElseIf Len(sData) < vaBuffer(j - 1) Then
            If vaAlignLeft(j - 1) Then
                sData = sData & Space(vaBuffer(j - 1) - Len(sData))
            Else
                sData = Space(vaBuffer(j - 1) - Len(sData)) & sData
            End If
        End If
        sReturn = sReturn & sData
    Next j
   
    FormatLabelText = sReturn & vbNewLine
   
End Function

First the data is formatted using the Format function and the vaFormat array. Next, the big If..ElseIf..EndIf block determines how to pad the data with spaces.

  • If the data is empty (Len = 0) then write spaces for the whole buffer.
  • If the data length is greater than the buffer, truncate it and add an ellipse to the end.
  • If the data length is less than the buffer, add spaces to the end (or the beginning if it’s aligned right) to fill it out.

It would be nice (but hard) to create a more general purpose function that created a label from a range. But this works for now.

KwikOpen Addin

I’ve been using this recent files userform for quite a while now and I like it. I haven’t added Eric’s comment yet (and for no good reason), but I’m going to in the next version. I don’t know if that solves the Sharepoint problem or just the ChDrive problem as neither are problems for me.

Here are my two problems:
Not enough recent files. I’m shocked – SHOCKED – at how often 50 recent files is not enough. It’s usually when I have to open a whole bunch of very similar files that I will never open again, but that clean out my recent files list. I decided to, sort of, maintain my own list. Because I use class modules *ahem* changing things to maintain my own list was pretty easy. I had to change how I fill the CRcntFiles class, but everything that consumes that class downstream just works. Here’s the new Fill method in CRnctFiles.

Public Sub Fill()
   
    Dim rf As RecentFile
    Dim clsRcntFile As CRcntFile
    Dim sFile As String, lFile As Long
    Dim vaFiles As Variant
    Dim i As Long
   
    For Each rf In Application.RecentFiles
        Set clsRcntFile = New CRcntFile
        clsRcntFile.FullName = rf.Path
        Me.Add clsRcntFile
    Next rf
   
    sFile = ThisWorkbook.Path & Application.PathSeparator & msMRUFILE
    lFile = FreeFile
    Open sFile For Input As lFile
   
    vaFiles = Split(Input$(LOF(lFile), lFile), vbNewLine)
   
    Close lFile
   
    For i = LBound(vaFiles) To UBound(vaFiles)
        If Len(vaFiles(i)) > 0 Then
            Set clsRcntFile = Nothing
            Set clsRcntFile = Me.RcntFileByFullName(vaFiles(i))
           
            If clsRcntFile Is Nothing Then
                Set clsRcntFile = New CRcntFile
                clsRcntFile.FullName = vaFiles(i)
                Me.Add clsRcntFile
            End If
        End If
    Next i
       
End Sub

First, I read in the 50 Excel most recently used files. Then I read in the 1,000 most recently used files that I store in a text file, weeding out the duplicates as I go. The advantage of continuing to use the Excel MRU is that I can leverage its pinning feature. I don’t have to write my own pinning bullshit – if you want to pin something, do it via Excel and it will always be in the MRU. Awesome.

Why 1,000 files? I don’t know. We’ll see how the performance holds up. I’ve been using it for three days and my text file is only up to 58 files – the 50 Excel stores plus eight additional. I guess it will take a bit longer to get to 1,000 than I thought, but I think it will be clear when their are too many and I can pare it down.

Next I need a way to write the files back to the text file. When the userform closes, the CRcntFiles.WriteToDisk method is called.

Public Sub WriteToDisk()
   
    Dim sFile As String
    Dim lFile As Long
    Dim clsRcntFile As CRcntFile
    Dim aFiles(1 To 1000) As String
    Dim lCnt As Long
   
    lCnt = 0
    For Each clsRcntFile In Me
        lCnt = lCnt + 1
        If lCnt > UBound(aFiles) Then Exit For
        aFiles(lCnt) = clsRcntFile.FullName
    Next clsRcntFile
   
    sFile = ThisWorkbook.Path & Application.PathSeparator & msMRUFILE
    lFile = FreeFile
   
    Open sFile For Output As lFile
    Print #lFile, Join(aFiles, vbNewLine)
    Close lFile
   
End Sub

I lazily write 1,000 lines to the disk even if I don’t have that many. I mean efficiently, not lazily. The text file is 6KB, so I’m not losing sleep over it. I would be pretty trivial to Redim Preserve that after I’ve filled it up, so I supposed I’ll do that after the alpha test.

And other than a few minor tweaks, that’s the only changes I had to make. If that’s not a case for using class modules, I don’t know what is. My userform consumes a CRcntFiles class. It doesn’t care how that class gets filled up or where the list comes from. I could change to storing those recent files in the registry, in an XML file, or tattooed to my back. As long as I can get them into a CRcntFiles instance, the rest of the code is happy.

Save As is jealous of Open. My next problem is that while I can quickly open a recent file, I can’t quickly save a file to a recent place. This is primarily a problem when I open attachments in Outlook. It stores an opened attachment in the Temp folder and when I choose Save As, that’s the folder it starts me in. Nuts to that. If you download this add-in, you’ll also see that I’ve hooked up a SaveAs userform to Ctrl+Shift+S. It’s got a few problems too (it prompts to replace a file twice), but you can try it if you like.

You can download KwikOpen.zip

The Great Hungarian Debate

I’ve discussed this in 2005. Then again in 2009. I guess it’s time to revisit the issue, mostly because Jordan says it’s time to say goodbye to hungarian notation.

I’ve probably said everything I need to on the subject, so no long diatribes here. However, I decided that I was going to experiment with coding without Hungarian and see what I thought. A little experimentation can’t be bad. I have a choice. I can be stubborn and not learn anything or I can force myself to try something different and maybe I’ll be the better for it. There was a time when I never coded custom class modules. Now you can’t get me to shut about them.

Here is the first procedure I coded in my experiment:

Public Sub ReformatDrivers()
   
    Dim Cell As Range
    Dim Found As Range
   
    For Each Cell In Sheet1.Range("A2:A133").Cells
        Set Found = Sheet2.ListObjects(1).DataBodyRange.Find(Cell.Value, , xlValues, xlWhole)
        If Not Found Is Nothing Then
            Cell.Offset(0, 1).Value = Sheet2.Cells(Found.Row, 2).Value
            Cell.Offset(0, 2).Value = "'" & Sheet2.Cells(Found.Row, 1).Value
            Cell.Offset(0, 3).Value = Found.Offset(0, 1).Value
        End If
    Next Cell
   
End Sub

Not exactly a barn burner, I’m sure you’ll agree. I hated every minute of it. I hate reading it right now. I’ve struggled to pinpoint why it displeases me so, but I have a theory.

It’s hard to tell the difference between keywords and variables. For Each Cell are all one syllable words with the first letter capitalized. The color distinction actually shows up better on this blog than it does in the IDE. I could change my color options in VBA so it stands out a little better.

There’s no requirement to make my variables proper case and thus hard to distinguish. I could code For Each cell and make my variables stand out because they’re lower case. But there is a substantial advantage to using capital letters – the IDE fixes your caps and tells you if you have a typo. So I want to have at least one capital letter to get that benefit. I could use camel case for two syllable words, like fileName. Do I have to always avoid one syllable words?

As I’ve mentioned in the past, I don’t use data type prefixes in other languages. But like this experiment, I don’t really like the variables I use when I code Ruby and I think it’s for the same reason. The difference is that my Ruby IDE doesn’t fix caps and, maybe more importantly, everything about Ruby is new and novel and foreign so on the scale of strangeness, all lower-case variables don’t really rate.

Another advantage of data type prefixing is being able to use reserved words. For my experiments, if I want to use a reserve word I’m going to tack on an underscore. When I want to code Dim lEnd As Long, I will instead use Dim End_ As Long.

I haven’t made a userform yet, but there is a problem that I’m not sure how to solve. Most of my controls have labels and any control with a label is named the same as the label. The textbox tbxSearch has lblSearch. The combobox cbxCustomer has lblCustomer. There’s real value in that and I’m not sure how to get away from it. Another problem with userforms are class properties. When I start typing Me.tbx I know I’m getting a textbox. But if my textbox is called CustomerName and I have a property of the userform class to hold a customer name, how do I distinguish them without the tbx? That’s not a rhetorical question, I really want to know how people do it.

I’ll keep writing new code without data type prefixing until I can’t take it anymore. And, of course, I’ll keep bitching about right here.

The Error Class Revisited

In the comments to Error Handling Via an Error Class, Peter found that the problem with this method is the absence of the Stop and Resume in the error handler than let you debug at the line that caused the error. Yeah, that stinks. Then Jase got me thinking that I just wouldn’t create the class in debug mode. Well, that wasn’t quite right. What needed to happen was that the error handler should not be set in debug mode. Here’s a rewrite of the entry point procedure.

Sub EntryPoint()
   
    Dim clsError As CError
   
    gbDebugMode = False
                   
    If Not gbDebugMode Then On Error GoTo ErrHandler
   
    Set clsError = New CError: clsError.SetLoc "Module1", "EntryPoint"
   
    SubProc1
     
ErrExit:
    Exit Sub
   
ErrHandler:
    Set clsError = Nothing
    MsgBox Err.Description
    Resume ErrExit
   
End Sub

When gbDebugMode is False, the error handler is set and it works as described in the original post. That is, the user gets a message box and the code exits gracefully. When gbDebugMode is True, the error handler is not set. It’s like you don’t have an error handler at all – because you don’t. When in debug mode, you get kicked to the line that caused the error.

Is that that last hurdle?