Saturday 6 December 2014

Writing an Excel range to a csv file: optimisations and unicode compatibility


I posted some VBA code to Split and Join 2D arrays using optimised string-handling a while ago: here's a function using the same logic to write an array to a csv file.

There's some interesting surprises in this kind of simple operation when you meet Unicode characters - and I found out that the horrible hack that I use for reading Excel ranges into complex SQL queries via csv files has some problems when the file contains (say) Arabic company names.

Without going into too much detail, VBA is internally unicode-compliant (strings using 'wide' chars encoding each character in two bytes have been there since well before the turn of the century) but Excel assumes that the outside world runs on ANSI code, or UTF encodings that require a code page. This makes life difficult when you're writing to a file, and reading it again with something else out of Redmond that can manage Unicode text, but hasn't *quite* got it right with the things that other Microsoft products do with this 'We speak Unicode but the outside world is ANSI' thing.

If you do need more detail (and actually, you probably do; there's a lot of misconceptions around and those of us who work in the Microsoft Office 'stack' have some of the most annoying ones), I recommend a quick re-read of Joel Spolsky's blog post: The Absolute Minimum Every Software Developer Absolutely, Positively Must Know About Unicode and Character Sets.

Other stuff: If you call the function repeatedly with the same file name, it'll check that the file's unchanged since the last 'ArrayToCSVfile' write, using an Adler-32 checksum on the file contents. If it's still the same data, it'll bail out. This is *embarrassing* if you're reusing the file name for different data, so be sure to delete the pre-existing files in your calling function if you do that.

And so, without further ado:

Writing an Excel range to a csv file


Public Function ArrayToCSVfile(ByRef InputArray As Variant, _
                               ByVal FilePath As String, _
                               Optional ByVal CoerceText As Boolean = True _
                               ) As Long
                           
' Output an array to a csv file and returns the row count.
' CoerceText=TRUE will encapsulate all items, numeric or not, in quote marks.

' This code handles unicode, and outputs a file that can be read by Microsoft
' ODBC and OLEDB database drivers.

' The first row is assumed to be a list of unique column names. Non-unique or
' blank names are replaced by the F0, F1, F2... sequential names generated by
' widely-used database engines (including MS-Access, JET & OLEDB text drivers)

' Blank rows after the last data row are not written to file.

' The function stores checksums of every file that it writes; we do not over-
' write a pre-existing file if a check on the file name discovers a record in
' the checksum list, and a check on the file contents shows that it still has
' the same checksum. There's an overhead to this preliminary file 'read' of a
' pre-existing file (our VBA implementation of the Adler32 hash can only read
' 25 Mbytes per second) but this is much faster than an uneccessary overwrite

On Error Resume Next

' Coding note: we're not doing any string-handling in VBA.Strings: allocating
' deallocating and (especially!) concatenating are SLOW. We are using the VBA
' Join and Split functions ONLY. Feel free to optimise further by declaring a
' faster set of string functions from the Kernel if you want to.
'
' Other optimisations: type pun. Byte Arrays are interchangeable with strings
' Some of our loops through these arrays have a 'step' of 2. This optimises a
' search-andreplace for ANSI chars in an array of 2-byte unicodes.

' ** THIS CODE IS IN THE PUBLIC DOMAIN **
'   Nigel Heffernan   Excellerando.Blogspot.com

Dim COMMA As String
Dim BLANK As String
Dim EOROW As String
 
 COMMA = ChrW$(44)
 BLANK = ChrW$(13) & ChrW$(10) & ChrW$(13) & ChrW$(10)
 EOROW = ChrW$(13) & ChrW$(10)
 
 
Dim i As Long
Dim j As Long
Dim k As Long

Dim i_LBound As Long
Dim i_UBound As Long
Dim j_LBound As Long
Dim j_UBound As Long
Dim k_lBound As Long
Dim k_uBound As Long

Dim iCheckSum  As Long
Dim iRowCount  As Long
Dim hndFile    As Long
Dim arrBytes() As Byte
Dim arrTemp1() As String
Dim arrTemp2() As String
Dim arrTemp3(0 To 2) As String

Dim strBlankRow As String
Dim boolSkipRow As Boolean
Dim boolNumeric As Boolean

Dim strHeader   As String
Dim arrHeader() As Byte


Static FileCheckSums As Scripting.Dictionary
If FileCheckSums Is Nothing Then
    Set FileCheckSums = New Scripting.Dictionary
End If

If Len(VBA.FileSystem.Dir(FilePath)) <> 0 Then
    iCheckSum = FileCheckSum(FilePath)
    If FileCheckSums(FilePath) = iCheckSum Then
        ArrayToCSVfile = -1
        Exit Function ' The file's unchanged since we last created it.
    Else
        VBA.FileSystem.Kill FilePath
    End If
End If


i_LBound = LBound(InputArray, 1)
i_UBound = UBound(InputArray, 1)

j_LBound = LBound(InputArray, 2)
j_UBound = UBound(InputArray, 2)

ReDim arrTemp1(i_LBound To i_UBound)
ReDim arrTemp2(j_LBound To j_UBound)

' We start with a 2-byte 'Wide' char. This coerces all subsequent operations to unicode

arrTemp3(0) = ChrW$(34)       ' Encapsulating quote
arrTemp3(1) = vbNullString    ' The field value will go here
arrTemp3(2) = ChrW$(34)       ' Encapsulating quote


' Special handling for the header row. Not optimised, but it's only one row
i = i_LBound

    For j = j_LBound To j_UBound
    
        arrTemp3(1) = ChrW(70) & j ' Columns must have a unique header. Default F0, F1...
        
        If IsError(InputArray(i, j)) Then
            ' no action
        ElseIf IsNull(InputArray(i, j)) Then
            ' no action
        ElseIf IsEmpty(InputArray(i, j)) Then
            ' no action
        ElseIf Len(InputArray(i, j)) = 0 Then
            ' no action
        Else
            If IsDate(InputArray(i, j)) Then
                 arrTemp3(1) = Round(CDbl(CVDate(InputArray(i, j))), 8)
            Else
                
                arrBytes = CStr(InputArray(i, j))
                For k = LBound(arrBytes) To UBound(arrBytes) Step 2
                    Select Case arrBytes(k)
                    Case 10, 13, 9, 44, 160 ' replaces CR, LF, Tab, Comma, and non-breaking
                        arrBytes(k) = 32    ' spaces with the standard ANSI space character
                    Case 34
                        arrBytes(k) = 39
                    End Select
                Next k
                arrTemp3(1) = arrBytes
            End If
        End If
       
        arrTemp2(j) = Join(arrTemp3, vbNullString)
        
        ' Remove duplicated field names
        For k = j_LBound To j - 1 Step 1
            If StrComp(arrTemp2(k), arrTemp2(j), vbTextCompare) = 0 Then
                arrTemp2(j) = ChrW(34) & "F" & j & ChrW(34) ' Non-unique: revert to default
                Exit For
            End If
        Next k
        
    Next j
    
    arrTemp1(i) = Join(arrTemp2, COMMA)



' Data body. This is heavily optimised to avoid VBA.String functions with allocations
For i = 1 + i_LBound To i_UBound

    boolSkipRow = True
    For j = j_LBound To j_UBound
    
    If IsEmpty(InputArray(i, j)) Then 'This condition is so common that we separate it out into its
        arrTemp2(j) = vbNullString    'own IF...THEN clause & subordinate the rest into nested IFs
    Else
        If IsError(InputArray(i, j)) Then
            arrTemp2(j) = vbNullString    '' was #ERROR
        ElseIf IsNull(InputArray(i, j)) Then
            arrTemp2(j) = vbNullString
        ElseIf Len(InputArray(i, j)) = 0 Then
            arrTemp2(j) = vbNullString
        Else
            boolSkipRow = False                 ' This is definitely a non-blank row
            If IsDate(InputArray(i, j)) Then
                 arrTemp2(j) = InputArray(i, j) ' Safer to Round(CDbl(CVDate(InputArray(i, j))), 8)
                                                ' but that's costly for performance. You are better
                                                ' off trusting Range.Value2 to create input arrays.
            Else
                arrBytes = CStr(InputArray(i, j))
                For k = LBound(arrBytes) To UBound(arrBytes) Step 2
                    Select Case arrBytes(k)
                    Case 10, 13, 9, 44, 160    ' replace CR, LF, Tab, Comma,   with space
                        If arrBytes(k + 1) = 0 Then arrBytes(k) = 32
                    Case 34
                        If arrBytes(k + 1) = 0 Then arrBytes(k) = 39
                    End Select
                Next k
                arrTemp2(j) = arrBytes
                arrBytes = vbNullString
            End If
        End If
    End If ' isempty
    Next j
    
    If boolSkipRow Then
        arrTemp1(i) = vbNullString
        iRowCount = iRowCount - 1
    Else
    
        If CoerceText Then  ' encapsulate all fields in quotes
        
            For j = j_LBound To j_UBound
                arrTemp3(1) = arrTemp2(j)
                arrTemp2(j) = Join$(arrTemp3, vbNullString)
            Next j
            
        Else
            
            For j = j_LBound To j_UBound
            
                arrBytes = arrTemp2(j)
                boolNumeric = True
                
                For k = LBound(arrBytes) To UBound(arrBytes) Step 2
                    If arrBytes(k) < 45 Or arrBytes(k) > 57 Then
                        boolNumeric = False
                        Exit For
                    End If
                Next k
                
                If boolNumeric Then
                    For k = 1 + LBound(arrBytes) To UBound(arrBytes) Step 2
                        If arrBytes(k) <> 0 Then
                            boolNumeric = False
                            Exit For
                        End If
                    Next k
                End If
                
                arrBytes = vbNullString
                
                If Not boolNumeric Then
                    arrTemp3(1) = arrTemp2(j)
                    arrTemp2(j) = Join(arrTemp3, vbNullString)
                End If
                
            Next j
            
        End If
     
        arrTemp1(i) = Join(arrTemp2, COMMA)
     
     End If
    
Next i

iRowCount = i + iRowCount - 2
If iRowCount < 1 Then
    iRowCount = 0    ' Note: this count excludes the header
End If
    


'   ****   WHY THIS IS COMMENTED OUT   **** **** **** **** **** **** **** ****
'
'   Microsoft ODBC and OLEDB database drivers cannot read the field names from
'   the header when a unicode byte order mark (&HFF & &HFE) is inserted at the
'   start of the text by Scripting.FileSystemObject 'Write' methods. Trying to
'   work around this by writing byte arrays will fail; FSO 'Write' detects the
'   string encoding automatically, and won't let you hack around it by writing
'   the header as UTF-8 (or 'Narrow' string) and appending the rest as unicode
'
'   (Yes, I tried some revolting hacks to get around it: don't *ever* do that)
'
'   **** **** **** **** **** **** **** **** **** **** **** **** **** **** ****
'
'    With FSO.OpenTextFile(FilePath, ForWriting, True, TristateTrue)
'        .Write Join(arrTemp1, EOROW)
'        .Close
'    End With ' textstream object from objFSO.OpenTextFile
'
'   **** **** **** **** **** **** **** **** **** **** **** **** **** **** ****
    



'   **** WHY WE 'PUT' A BYTE ARRAY INSTEAD OF A VBA STRING VARIABLE  **** ****
'
'       Put #hndFile, , StrConv(Join(arrTemp1, EOROW), vbUnicode)
'       Put #hndFile, , Join(arrTemp1, EOROW)
'
'   If you pass unicode, Wide or UTF-16 string variables to PUT, it prepends a
'   Unicode Byte Order Mark to the data which, when written to your file, will
'   render the field names illegible to Microsoft's JET ODBC and ACE-OLEDB SQL
'   drivers (which can actually read unicode field names, if the helpful label
'   isn't in the way). However, the 'PUT' statements write a Byte array as-is.
'
'   **** **** **** **** **** **** **** **** **** **** **** **** **** **** ****
    
    
    
    arrBytes = Join(arrTemp1, EOROW)
    
    ' Remove empty rows after the data: this is so common in arrays from Excel
    ' ranges that the performance penalty is acceptable (one big allocation in
    ' the Redim Preserve statement) but you may prefer to comment out the code
    
    ' We *could* do a Replace on BLANK to get internal blank rows as well, but
    ' I don't trust the unicode handling and the performance penalty is higher
    
    k_lBound = LBound(arrBytes)
    k_uBound = UBound(arrBytes)
    For k = k_uBound - 1 To k_lBound Step -1
        If arrBytes(k) <> 0 Then
            If Not (arrBytes(k) = 10 Or arrBytes(k) = 13) Then
                Exit For
            End If
        End If
    Next k
    ReDim Preserve arrBytes(k_lBound To k + 1)
    
    hndFile = FreeFile
    Open FilePath For Binary As #hndFile
    
    Put #hndFile, , arrBytes
    Close #hndFile
    
    FileCheckSums(FilePath) = StringCheckSum(arrBytes)
    
    Erase arrBytes
    

    ArrayToCSVfile = iRowCount


ExitSub:
On Error Resume Next
    
    Erase arrTemp1
    Erase arrTemp2
    Exit Function
    
ErrSub:
    Resume ExitSub
  
  
  
End Function


You'll need this, too: the file and string checksum functions called in the code.

A VBA implementation of the Adler-32 checksum, running on byte arrays instead of using VBA string-handling.


This includes another Heffernan Horrible Hack: the VBA Long Integer data type doesn't go up tp 2³², it's a signed integer for ±2³¹. So there's a wraparound at 2³¹-1, which feels rather quaint in this modern age of 64-bit LongLong integers.

However, there is old-worlde quaintness, and there's mediƦval barbarism: the final operation of an Adler-32 hashing function is a multiplication that can and does blow past 2³², and I'm using a Floating-point double to do it. If my castle is ever threatened by a mob of peasants with pitchforks and torches, I might encapsulate that in a conditional-compilation block on #VBA7, with a proper LongLong integer in the 64-bit block and the barbarism confined to the #Else block.


Public Function StringCheckSum(ByRef ByteArray() As Byte) As Long
Application.Volatile False

' Returns an Adler32 checksum of a string: typically a large file's contents

' Note that the VBA Long Integer data type is *not* a 32-bit integer, it's a
' signed integer with a range of  ± (2^31) -1. So our return value is signed
' and return values exceeding +2^31 -1 'wraparound' and restart at -2^31 +1.

' Test your results. Some data sets (especially repeating dates) have double
' digit collision rates, and you'll need to find a different hash algorithm.


' Coding Notes:

' What, didn't you know that a Byte Array and a string are type-compatible?

' This is intended for use in VBA, and not for use on the worksheet. Use the
' setting  'Option Private Module' to hide CheckSum from the function wizard


' Author: Nigel Heffernan, May 2006  http://excellerando.blogspot.com
' Acknowledgements and thanks to Paul Crowley, who recommended Adler-32

'  Please note that this code is in the public domain. Mark it clearly, with
'  the author's name, and segregate it from any proprietary code if you need
'  to assert ownership & commercial confidentiality on your proprietary code



Const LONG_LIMIT As Long = (2 ^ 31) - 1
Const MOD_ADLER As Long = 65521

Dim a As Long
Dim b As Long
Dim i As Long


Dim dblOverflow As Double

Dim i_LBound As Long
Dim i_UBound As Long

a = 1
b = 0

i_LBound = LBound(ByteArray)
i_UBound = UBound(ByteArray)

    For i = i_LBound To i_UBound
        
        a = (a + ByteArray(i)) Mod MOD_ADLER
        b = (b + a) Mod MOD_ADLER
 
    Next i
    
' Using a float in an integer calculation? We can get away with it, because
' the float error for a VBA double is < ±0.5 with numbers smaller than 2^32

dblOverflow = (1# * b * MOD_ADLER) + a

If dblOverflow > LONG_LIMIT Then  ' wraparound 2^31 to 1-(2^31)
   
    Do Until dblOverflow < LONG_LIMIT
        dblOverflow = dblOverflow - LONG_LIMIT
    Loop
    StringCheckSum = 1 + dblOverflow - LONG_LIMIT
    
Else
    StringCheckSum = b * MOD_ADLER + a
End If


End Function


Public Function FileCheckSum(strFilePath As String) As Long
Application.Volatile False
On Error Resume Next


'Return an ADLER-32 checksum from a file

' Throttle repeated calls using static variables. WARNING
' this assumes the file hasn't changed in the last 500 ms

    Static LastFile As String
    Static LastCall As Single
    Static LastHash As Long
    
    If LastFile = strFilePath Then
        If VBA.Timer - LastCall < 0.5 Then
            FileCheckSum = LastHash
            Exit Function
        Else
            LastCall = VBA.Timer
        End If
    Else
        LastFile = strFilePath
        LastCall = VBA.Timer
    End If


Dim hndFile As Long
Dim arrBytes() As Byte
Dim lenData As Long


hndFile = FreeFile
Open strFilePath For Binary As #hndFile

ReDim arrBytes(0 To LOF(hndFile) - 1)
Get #hndFile, , arrBytes
Close #hndFile

FileCheckSum = StringCheckSum(arrBytes)

Erase arrBytes

LastHash = FileCheckSum

End Function


Share and enjoy.

I should thank the estimable Paul Crowley for showing me the Adler-32 algorith, years ago, and much else besides; but a gentleman aficionado of algrorithmic elegance might prefer to dissociate himself from such abuses.



No comments:

Post a Comment