Export Android contacts contacts2.db to vCard vcf on Windows

The other day I need to restore some contacts on an Android phone, I had Titanium Backup files, though restoring the contacts through there didn’t seem to work.

I searched for a solution but there wasn’t really anything for Windows to restore the contacts so I developed my own VBA script.

I will assume you already have a backup contacts2.db file, it is found the zip file com.android.providers.contacts.

Firstly, download SQLite Manager add-on for Firefox, run it, Connect Database contacts2.db. Under Tables, right-click data table and chose Export Table click OK and save as data.csv.

Download convert-contacts2.db data-to-vcard-vcf.xlsm, open, and enable macros if necessary. Run the macro convertDatatoContacts and select the data.csv file.

You should now have a list of contacts, delete any contacts that you don’t want to import by deleting the whole row. When done run the macro and a vCard.vcf file will be created in the same folder as the Excel WorkBook.

Copy vCard.vcf to the root  directory of your Android phone. On the phone enter Contacts, Settings, Import/Export and Import from storage. The contacts will be imported.

 

VBA/VBS check if printer is installed

Here is a quick code snippet to determine if a printer is installed on a Microsoft Windows system;

MsgBox printerExists("Microsoft XPS Document Writer")

Function printerExists(str)
    printerExists = False
    Dim objWMIService
    Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")

    Dim colPrinters
    Set colPrinters = objWMIService.ExecQuery("Select * From Win32_Printer")

    Dim objPrinter
    For Each objPrinter In colPrinters
        If objPrinter.Name = str Then
            printerExists = True
            Exit For
        End If
    Next
End Function

VB functions for determining red/black numbers on roulette wheel

Here are two simple functions for calculating if a number falls on red or black on a roulette wheel, for the perfectionists that don’t want to use odd/even.

'isRed calculates if a number falls red on a roulette wheel
Public Function isRed(ByRef n As Long) As Boolean
    Select Case n
        Case 1, 3, 5, 7, 9, 12, 14, 16, 18, 19, 21, 23, 25, 27, 30, 32, 34, 36
            isRed = True
        Case Else
            isRed = False
    End Select
End Function

'isBlack calculates if a number falls black on a roulette wheel
Public Function isBlack(ByRef n As Long) As Boolean
    Select Case n
        Case 2, 4, 6, 8, 10, 11, 13, 15, 17, 20, 22, 24, 26, 28, 29, 31, 33, 35
            isBlack = True
        Case Else
            isBlack = False
    End Select
End Function

SplitExtended – improved VB split function with group characters

Based on SplitEx by Chip Pearson, SplitExtended is optimised to be over double the speed, with fixes and additional features;

Features over the standard VB Split are;

  • grouping characters, no longer split strings in quotes,
  • ignore consecutive delimiters, while preserving those in  grouping characters,
  • option to remove grouping characters, start and end quotes can be removed, and
  • double grouping characters inside a grouping character is converted to single grouping characters, double quotes inside quotes are converted to single quotes.

Download modSplitExtended.bas

Code here;

Option Explicit

'====================================================================================
' SplitExtended
' By Travis Hydzik
'
' Based on SplitEx by Chip Pearson http://www.cpearson.com/Excel/Split.aspx
'
' Improvements include;
' - over double the speed of SplitEx
' - doesn't remove double Delimiters in groups
' - double GroupChar in groups treated as escaped and converted to single
'====================================================================================
Public Function SplitExtended(ByRef InString As String, _
    ByVal Delimiter As String, _
    Optional ByVal GroupChar As String = vbNullString, _
    Optional ByVal IgnoreConsecutiveDelimiters As Boolean = False, _
    Optional ByVal DeleteGroupCharacters As Boolean = False) As String()

    Dim arr() As String

    Dim InGroupReplace As String
    Dim consectGroupReplace As String

    Dim S As String

    S = InString
    Dim i As Long, j As Long

    If LenB(S) = 0 Then
        'string is empty so return an unbound array (similar to original Split)
    ElseIf LenB(Delimiter) = 0 Then
        'Delimiter is empty so return an array with the first element the string
        ReDim arr(0)
        arr(0) = S
    ElseIf InStrB(1, S, Delimiter, vbBinaryCompare) = 0 Then
        'Delimiter is not found in the string, return an array with the first element of the string
        ReDim arr(0)
        arr(0) = S
    Else

        'find a unique character in string s, that isn't the Delimiter
        'it can be unique AND the group character as this means there won't be any grouping
        i = -1
        Do While LenB(InGroupReplace) = 0
            i = i + 1
            'the character is unique
            If InStrB(1, S, ChrW$(i), vbBinaryCompare) = 0 Then
                'the character is not the delimiter
                If StrComp(ChrW$(i), Delimiter, vbBinaryCompare) <> 0 Then
                    InGroupReplace = ChrW$(i)
                End If
            End If
        Loop

        'if DeleteGroupCharacters is enabled, it is common to double the GroupChar if that character is needed
        'replace all consecutive group characters with consectGroupReplace
        If DeleteGroupCharacters Then
            'only if there are consecutive GroupChar
            If InStrB(1, S, GroupChar & GroupChar, vbBinaryCompare) > 0 Then
                'find a unique character in string s, that isn't the Delimiter and isn't inGroupReplace
                Do While LenB(consectGroupReplace) = 0
                    i = i + 1
                    'the character is unique
                    If InStrB(1, S, ChrW$(i), vbBinaryCompare) = 0 Then
                        'the character is not the delimiter
                        If StrComp(ChrW$(i), Delimiter, vbBinaryCompare) <> 0 Then
                            'the character is not the GroupChar
                            If StrComp(ChrW$(i), GroupChar, vbBinaryCompare) <> 0 Then
                                consectGroupReplace = ChrW$(i)
                            End If
                        End If
                    End If
                Loop

                'once the character is found, replace all double GroupChar
                S = Replace(S, GroupChar & GroupChar, consectGroupReplace, 1, -1)
            End If
        End If

        'replace any Delimiter occuring in a group with inGroupReplace
        i = InStr(1, S, GroupChar, vbBinaryCompare)
        j = InStr(i + Len(GroupChar), S, GroupChar, vbBinaryCompare)
        Do While i > 0 And j > 0
            If j > i Then
                'mid$(s, 1, i) = Replace(mid$(s, 1, i), Delimiter, inGroupReplace, 1, -1, vbBinaryCompare)
                'mid$(s, j) = Replace(mid$(s, j), Delimiter, inGroupReplace, 1, -1, vbBinaryCompare)
                Mid$(S, i, j - i) = Replace(Mid$(S, i, j - i), Delimiter, InGroupReplace, 1, -1, vbBinaryCompare)
            Else
                S = Replace(S, Delimiter, InGroupReplace, 1, -1, vbBinaryCompare)
            End If

            i = InStr(j + Len(GroupChar), S, GroupChar, vbBinaryCompare)
            j = InStr(i + Len(GroupChar), S, GroupChar, vbBinaryCompare)
        Loop

        'remove any consecutive delimiters, iteratively
        If IgnoreConsecutiveDelimiters Then
            Do While InStrB(1, S, Delimiter & Delimiter, vbBinaryCompare) > 0
                S = Replace(S, Delimiter & Delimiter, Delimiter, 1, -1, vbBinaryCompare)
            Loop
        End If

        'perform the split
        arr = Split(S, Delimiter, -1, vbBinaryCompare)

        'loop through the array and restore the special characters
        For i = 0 To UBound(arr)
            If InStrB(1, arr(i), InGroupReplace, vbBinaryCompare) > 0 Then
                arr(i) = Replace(arr(i), InGroupReplace, Delimiter, 1, -1, vbBinaryCompare)
            End If
            If DeleteGroupCharacters Then
                If InStrB(1, arr(i), GroupChar, vbBinaryCompare) > 0 Then
                    arr(i) = Replace(arr(i), GroupChar, vbNullString, 1, -1, vbBinaryCompare)
                End If
                If InStrB(1, arr(i), consectGroupReplace, vbBinaryCompare) > 0 Then
                    arr(i) = Replace(arr(i), consectGroupReplace, GroupChar, 1, -1, vbBinaryCompare)
                End If
            End If
        Next i
    End If

    SplitExtended = arr

End Function

Longest Common Subsequence implemented in VBA (Visual Basic for Applications)

From Wikipedia, The longest common subsequence (LCS) problem is to find the longest subsequence common to all sequences in a set of sequences (often just two).

The following is a VBA implementation of this problem. The following functions are included;

String functions;

  • longestCommonSubsequence – calculate an LCS array.
  • backTraceUp and backTraceLeft – trace back either defaulting up or left respectively, and find the LCS.
  • getDiff – returns the difference of the two strings. The succeeding character of =, – or + indicated if the character was equal, removed or added, respectively.
  • passGetDiffOutput – passes the output of getDiff so that =, – or + are now values in a 2 x n array, with indix 0 being equal, indix 1 being removed and indix 2 being added.

Array functions;

  • longestCommonSubsequenceArr – calculate an LCS array.
  • backTraceUpArr – trace back defaulting up and find the LCS.
  • getDiffArr – returns the difference of the two arrays as a 2 x n array, with indix 0 being equal, indix 1 being removed and indix 2 being added.

Common functions;

  • max – standard maximum function.
  • stringToArray – convert a string to an array for array functions.

Examples;

  • exampleString
  • exampleArr

Download the Basic (bas) File

Unfortunately, the limitations of VBA makes a dog’s dinner out of what would be some very concise code or, perhaps that’s just my implementation…

Option Explicit

Public Function longestCommonSubsequence(ByRef string1 As String, ByRef string2 As String) As Long()
    If string1 = vbNullString Or string2 = vbNullString Then
        Exit Function
    End If
 
    Dim num() As Long
    
    'define the array, note rows of zeros get added to front automatically
    ReDim num(Len(string1), Len(string2))
    
    Dim i As Long, j As Long
    
    For i = 1 To Len(string1)
        For j = 1 To Len(string2)
            If Mid$(string1, i, 1) = Mid$(string2, j, 1) Then
                num(i, j) = num(i - 1, j - 1) + 1
            Else
                num(i, j) = max(num(i - 1, j), num(i, j - 1))
            End If
        Next j
    Next i

    longestCommonSubsequence = num
End Function

Sub exampleString()

    Dim arr() As Long
    
    Dim string1 As String
    Dim string2 As String
    
    string1 = "this is a find the haystack string"
    string2 = "this is a replace the needle string"
    
    arr = longestCommonSubsequence(string1, string2)
    
    Dim s As String, t As String
    s = backTraceUp(arr, string1, string2, Len(string1), Len(string2))
    t = backTraceLeft(arr, string1, string2, Len(string1), Len(string2))
    Dim a As String, b As String
    a = getDiff(arr, string1, string2, Len(string1), Len(string2))
    
    Dim brr() As Long
    
    brr = passGetDiffOutput(a)
End Sub

Public Function max(ByRef a As Long, ByRef b As Long) As Long
    If a >= b Then
        max = a
    Else
        max = b
    End If
End Function


'back traces c, defaulting in the up direction
Public Function backTraceUp(ByRef c() As Long, ByRef string1 As String, ByRef string2 As String, ByRef i As Long, ByRef j As Long) As String
    If i < 1 Or j < 1 Then
        backTraceUp = vbNullString
    ElseIf Mid$(string1, i, 1) = Mid$(string2, j, 1) Then
        'equal characters, save it and then go up and left
        backTraceUp = backTraceUp(c, string1, string2, i - 1, j - 1) & Mid$(string1, i, 1)
    Else
        'go in the direction of the highest number, defaulting to up
        If (c(i, j - 1) > c(i - 1, j)) Then
            backTraceUp = backTraceUp(c, string1, string2, i, j - 1)
        Else
            backTraceUp = backTraceUp(c, string1, string2, i - 1, j)
        End If
    End If
End Function

'back traces c, defaulting in the left direction
Public Function backTraceLeft(ByRef c() As Long, ByRef string1 As String, ByRef string2 As String, ByRef i As Long, ByRef j As Long) As String
    If i < 1 Or j < 1 Then
        backTraceLeft = vbNullString
    ElseIf Mid$(string1, i, 1) = Mid$(string2, j, 1) Then
        'equal characters, save it and then go up and left
        backTraceLeft = backTraceLeft(c, string1, string2, i - 1, j - 1) & Mid$(string1, i, 1)
    Else
        'go in the direction of the highest number, defaulting to left
        If (c(i, j - 1) >= c(i - 1, j)) Then
            backTraceLeft = backTraceLeft(c, string1, string2, i, j - 1)
        Else
            backTraceLeft = backTraceLeft(c, string1, string2, i - 1, j)
        End If
    End If
End Function

'the following function returns a string with indication to what was deleted or added
'proceding character can be;
' = no change
' - deletion
' + addition
Public Function getDiff(ByRef c() As Long, ByRef stringOld As String, ByRef stringNew As String, ByRef i As Long, ByRef j As Long) As String
    If i > 0 Then
        If j > 0 Then 'both are greater than zero
            'can only do the following comparison when i and j are greater than zero
            If Mid$(stringOld, i, 1) = Mid$(stringNew, j, 1) Then
                getDiff = getDiff(c, stringOld, stringNew, i - 1, j - 1) & Mid$(stringOld, i, 1) & "="
            Else
                If i = 0 Then
                    getDiff = getDiff(c, stringOld, stringNew, i, j - 1) & Mid$(stringNew, j, 1) & "+"
                ElseIf c(i, j - 1) >= c(i - 1, j) Then
                    getDiff = getDiff(c, stringOld, stringNew, i, j - 1) & Mid$(stringNew, j, 1) & "+"
                ElseIf j = 0 Then
                    getDiff = getDiff(c, stringOld, stringNew, i - 1, j) & Mid$(stringOld, i, 1) & "-"
                ElseIf c(i, j - 1) < c(i - 1, j) Then
                    getDiff = getDiff(c, stringOld, stringNew, i - 1, j) & Mid$(stringOld, i, 1) & "-"
                Else
                    getDiff = vbNullString
                End If
            End If
        Else 'i is is greater than zero
                If j = 0 Then
                    getDiff = getDiff(c, stringOld, stringNew, i - 1, j) & Mid$(stringOld, i, 1) & "-"
                ElseIf c(i, j - 1) < c(i - 1, j) Then
                    getDiff = getDiff(c, stringOld, stringNew, i - 1, j) & Mid$(stringOld, i, 1) & "-"
                Else
                    getDiff = vbNullString
                End If
        End If
    Else
        If j > 0 Then 'j is  greater than zero
                If i = 0 Then
                    getDiff = getDiff(c, stringOld, stringNew, i, j - 1) & Mid$(stringNew, j, 1) & "+"
                ElseIf c(i, j - 1) >= c(i - 1, j) Then
                    getDiff = getDiff(c, stringOld, stringNew, i, j - 1) & Mid$(stringNew, j, 1) & "+"
                Else
                    getDiff = vbNullString
                End If
        Else 'none are greater than zero
                getDiff = vbNullString
        End If
    End If
End Function

'this function returns the location of the string difference
Public Function passGetDiffOutput(ByRef outputStr As String) As Long()
    Dim i As Long
    i = 1
    
    Dim typeChr As String
    
    
    Dim oldi As Long
    Dim newi As Long
    oldi = 0
    newi = 0
    
    Dim toFrom() As Long
    Dim toFromCount As Long
    toFromCount = -1
    
    
    Dim typeChrPrev As String
    typeChrPrev = vbNullString
    
    Do While i < Len(outputStr)
        typeChr = Mid$(outputStr, i + 1, 1)
        Select Case typeChr
            Case "="
                If typeChr <> typeChrPrev Then
                
                    'check if it is comming from a deletion
                    If typeChrPrev = "-" Then
                        toFrom(2, toFromCount) = oldi
                    End If
                    
                    'check if it is comming from a addition
                    If typeChrPrev = "+" Then
                        toFrom(2, toFromCount) = newi
                    End If
                End If
                
                oldi = oldi + 1 'update old index
                newi = newi + 1 'update new index
            Case "-"
                'check if it is comming from a addition
                If typeChrPrev = "+" Then
                    toFrom(2, toFromCount) = newi
                End If
            
                oldi = oldi + 1 'update old index
                If typeChr <> typeChrPrev Then
                    toFromCount = toFromCount + 1
                    ReDim Preserve toFrom(2, toFromCount)
                    'let old be -1
                    toFrom(0, toFromCount) = -1
                    toFrom(1, toFromCount) = oldi
                End If
            Case "+"
                'check if it is comming from a deletion
                If typeChrPrev = "-" Then
                    toFrom(2, toFromCount) = oldi
                End If
            
                newi = newi + 1 'update new index
                If typeChr <> typeChrPrev Then
                    toFromCount = toFromCount + 1
                    ReDim Preserve toFrom(2, toFromCount)
                    'let new be 1
                    toFrom(0, toFromCount) = 1
                    toFrom(1, toFromCount) = newi
                End If
        End Select
    
        i = i + 2
        typeChrPrev = typeChr
    Loop
    
    'check if it ended on a deletion or adition
    If typeChrPrev = "-" Then
        toFrom(2, toFromCount) = oldi
    End If
    
    If typeChrPrev = "+" Then
        toFrom(2, toFromCount) = newi
    End If
    
    passGetDiffOutput = toFrom
End Function

'note, arrays must be single dimension
Public Function longestCommonSubsequenceArr(ByRef array1() As String, ByRef array2() As String) As Long()
    On Error Resume Next
    If UBound(array1, 2) > 0 Or UBound(array2, 2) > 0 Then 'multidimensional arrays
        If Error = vbNullString Then
            Exit Function
        End If
    End If
    
    If UBound(array1) < 0 Or UBound(array2) < 0 Then 'check if arrays are bounded
        If Error <> vbNullString Then
            Exit Function
        End If
    End If

    Dim num() As Long
    
    'define the array, note rows of zeros get added to front automatically
    ReDim num(UBound(array1) + 1, UBound(array2) + 1)
    
    Dim i As Long, j As Long
    
    'note, arrays must always start at indice zero.
    For i = 0 To UBound(array1)
        For j = 0 To UBound(array2)
            If array1(i) = array2(j) Then
                num(i + 1, j + 1) = num(i, j) + 1
            Else
                num(i + 1, j + 1) = max(num(i, j + 1), num(i + 1, j))
            End If
        Next j
    Next i

    longestCommonSubsequenceArr = num
End Function

Public Function stringToArray(ByRef str As String) As String()
    Dim i As Long
    Dim arr() As String
    ReDim arr(Len(str) - 1)
    For i = 1 To Len(str)
        arr(i - 1) = Mid$(str, i, 1)
    Next i
    stringToArray = arr
End Function

Sub exampleArr()

    Dim string1 As String
    Dim string2 As String
    
    string1 = "this is a find the haystack string"
    string2 = "this is a replace the needle string"


    Dim a1() As String
    Dim a2() As String
    
    a1 = stringToArray(string1)
    a2 = stringToArray(string2)
    
    Dim c() As Long
    
    c = longestCommonSubsequenceArr(a1, a2)
    
    Dim str() As String
    
    str = backTraceUpArr(c, a1, a2, UBound(a1), UBound(a2))
    
    Dim dif() As String
    dif = getDiffArr(c, a1, a2, UBound(a1), UBound(a2))

End Sub

'back traces c, defaulting in the up direction
Public Function backTraceUpArr(ByRef c() As Long, ByRef array1() As String, ByRef array2() As String, ByRef i As Long, ByRef j As Long) As String()
    Dim arr() As String
    If i < 0 Or j < 0 Then
        backTraceUpArr = arr
    ElseIf array1(i) = array2(j) Then
        'equal characters, save it and then go up and left
        arr = backTraceUpArr(c, array1, array2, i - 1, j - 1)
        'check the bounding of arr
        Dim bound As Long
        On Error Resume Next
        bound = UBound(arr)
        If Error <> vbNullString Then
            ReDim arr(0)
            arr(0) = array1(i)
        Else 'no error
            ReDim Preserve arr(bound + 1)
            arr(bound + 1) = array1(i)
        End If
        backTraceUpArr = arr
    Else
        'go in the direction of the highest number, defaulting to up
        If (c(i + 1, j) > c(i, j + 1)) Then
            backTraceUpArr = backTraceUpArr(c, array1, array2, i, j - 1)
        Else
            backTraceUpArr = backTraceUpArr(c, array1, array2, i - 1, j)
        End If
    End If
End Function


'returns a 2xn array, where
'indice 0 are equal
'indice 1 are deletions
'indice 2 are additions
Public Function getDiffArr(ByRef c() As Long, ByRef arrayOld() As String, ByRef arrayNew() As String, ByRef i As Long, ByRef j As Long) As String()
    Dim arr() As String
    Dim bound As Long
    On Error Resume Next
    If i >= 0 Then
        If j >= 0 Then 'both are greater or equal to zero
            'can only do the following comparison when i and j are greater or equal than zero
            If arrayOld(i) = arrayNew(j) Then
                    arr = getDiffArr(c, arrayOld, arrayNew, i - 1, j - 1)
                    bound = UBound(arr, 2) 'check the bounding of arr
                    If Error <> vbNullString Then
                        Err.Clear
                        ReDim arr(2, 0)
                        arr(0, 0) = arrayOld(i)
                    Else 'no error
                        ReDim Preserve arr(2, bound + 1)
                        arr(0, bound + 1) = arrayOld(i)
                    End If
                    getDiffArr = arr
            Else
                If i = 0 Then
                    arr = getDiffArr(c, arrayOld, arrayNew, i, j - 1)
                    bound = UBound(arr, 2) 'check the bounding of arr
                    If Error <> vbNullString Then
                        Err.Clear
                        ReDim arr(2, 0)
                        arr(2, 0) = arrayNew(j)
                    Else 'no error
                        ReDim Preserve arr(2, bound + 1)
                        arr(2, bound + 1) = arrayNew(j)
                    End If
                    getDiffArr = arr
                ElseIf c(i + 1, j - 1 + 1) >= c(i - 1 + 1, j + 1) Then
                    arr = getDiffArr(c, arrayOld, arrayNew, i, j - 1)
                    bound = UBound(arr, 2) 'check the bounding of arr
                    If Error <> vbNullString Then
                        Err.Clear
                        ReDim arr(2, 0)
                        arr(2, 0) = arrayNew(j)
                    Else 'no error
                        ReDim Preserve arr(2, bound + 1)
                        arr(2, bound + 1) = arrayNew(j)
                    End If
                    getDiffArr = arr
                ElseIf j = 0 Then
                    arr = getDiffArr(c, arrayOld, arrayNew, i - 1, j)
                    bound = UBound(arr, 2) 'check the bounding of arr
                    If Error <> vbNullString Then
                        Err.Clear
                        ReDim arr(2, 0)
                        arr(1, 0) = arrayOld(i)
                    Else 'no error
                        ReDim Preserve arr(2, bound + 1)
                        arr(1, bound + 1) = arrayOld(i)
                    End If
                    getDiffArr = arr
                ElseIf c(i + 1, j - 1 + 1) < c(i - 1 + 1, j + 1) Then
                    arr = getDiffArr(c, arrayOld, arrayNew, i - 1, j)
                    bound = UBound(arr, 2) 'check the bounding of arr
                    If Error <> vbNullString Then
                        Err.Clear
                        ReDim arr(2, 0)
                        arr(1, 0) = arrayOld(i)
                    Else 'no error
                        ReDim Preserve arr(2, bound + 1)
                        arr(1, bound + 1) = arrayOld(i)
                    End If
                    getDiffArr = arr
                Else
                    getDiffArr = arr
                End If
            End If
        Else 'i is is greater or equal to zero
                If j = 0 Then
                    arr = getDiffArr(c, arrayOld, arrayNew, i - 1, j)
                    bound = UBound(arr, 2) 'check the bounding of arr
                    If Error <> vbNullString Then
                        Err.Clear
                        ReDim arr(2, 0)
                        arr(1, 0) = arrayOld(i)
                    Else 'no error
                        ReDim Preserve arr(2, bound + 1)
                        arr(1, bound + 1) = arrayOld(i)
                    End If
                    getDiffArr = arr
                ElseIf c(i + 1, j - 1 + 1) < c(i - 1 + 1, j + 1) Then
                    arr = getDiffArr(c, arrayOld, arrayNew, i - 1, j)
                    bound = UBound(arr, 2) 'check the bounding of arr
                    If Error <> vbNullString Then
                        Err.Clear
                        ReDim arr(2, 0)
                        arr(1, 0) = arrayOld(i)
                    Else 'no error
                        ReDim Preserve arr(2, bound + 1)
                        arr(1, bound + 1) = arrayOld(i)
                    End If
                    getDiffArr = arr
                Else
                    getDiffArr = arr
                End If
        End If
    Else
        If j >= 0 Then 'j is  greater than zero
                If i = 0 Then
                    arr = getDiffArr(c, arrayOld, arrayNew, i - 1, j)
                    bound = UBound(arr, 2) 'check the bounding of arr
                    If Error <> vbNullString Then
                        Err.Clear
                        ReDim arr(2, 0)
                        arr(2, 0) = arrayNew(j)
                    Else 'no error
                        ReDim Preserve arr(2, bound + 1)
                        arr(2, bound + 1) = arrayNew(j)
                    End If
                    getDiffArr = arr
                ElseIf c(i + 1, j - 1 + 1) >= c(i - 1 + 1, j + 1) Then
                    arr = getDiffArr(c, arrayOld, arrayNew, i, j - 1)
                    bound = UBound(arr, 2) 'check the bounding of arr
                    If Error <> vbNullString Then
                        Err.Clear
                        ReDim arr(2, 0)
                        arr(2, 0) = arrayNew(j)
                    Else 'no error
                        ReDim Preserve arr(2, bound + 1)
                        arr(2, bound + 1) = arrayNew(j)
                    End If
                    getDiffArr = arr
                Else
                    getDiffArr = arr
                End If
        Else 'none are greater than zero
                getDiffArr = arr
        End If
    End If
End Function

Optimizing/faster String Concatenation in VBA

There are numerous links about Visual Basic string concatenation, one particular is Microsoft’s How To Improve String Concatenation Performance. But the article is overwritten for the point it is trying to make, so I will share a simplified example.

Lets say we want to perform the following concatenation:

Dim i As Long
Dim s As String
For i = 1 To 100000000
	s = "A" & i & "B"
Next i

This takes approximately 6000 ticks. The faster approach, yet more complex functionality would be as follows:

Dim sourceLength As Long
sourceLength = 1
Dim source As String
s = "A B"

Dim i As Long
Dim s As String
For i = 1 To 100000000
	source = CStr(i)
	If Len(source) > sourceLength Then
		sourceLength = Len(source)
		s = "A" & Space$(sourceLength) & "B"
	End If
	Mid$(s, 2, sourceLength) = source
Next i

Which takes approximately 3700 ticks, a saving of nearly 40%.

Word Minimize/Maximize event capture VBA

Here is a quick little post outlining how to create a minimize/maximize event routine.

Add the following code to a class named EventClassModule

Public WithEvents App As Word.Application

Private Sub App_WindowDeactivate(ByVal Doc As Document, ByVal Wn As Window)
    If Doc.ActiveWindow.WindowState = wdWindowStateMinimize Then
        'you code in here
    End If
End Sub

and then add the following code under ThisDocument

Dim X As New EventClassModule

Private Sub Document_Open()
    'Call Register_Event_Handler
    Set X.App = Word.Application
End Sub

VBA automatically saves Excel 2003 Workbook in compatibility mode as Excel 2007 Workbook

Lets say you have a neat little Excel 2003 macro, when you run your macro in Excel 2007, Excel runs it in Compatibility Mode, and any benefits (such as the 16384 columns) you were hoping to use are still unavailable. So how can we enable these benefits depending on the Excel version? Simply by including the following code in the Auto_Open subroutine.

Public Sub auto_open()
    'add some smarts if opened in Excel 2007 or later
    Dim oldFileName As String
    oldFileName = ThisWorkbook.Name
    Dim tempi As Integer 'used to store position of '.' before file extension in workbook file name
    tempi = InStrRev(oldFileName, ".xls", -1, vbTextCompare)
    
    If Application.Version > 11 And Len(oldFileName) - tempi = 3 Then 'assume running in compatability mode
        Application.DisplayAlerts = False
        Dim newFileName As String
        newFileName = Mid$(oldFileName, 1, tempi) & "xlsm"
        
        If fileExist(newFileName) Then 'if the new workbook version already exists, then open it and close this one
            'open the new workbook by emulating double clicking the file, as this is the only way to run the auto_open
            Shell "Excel """ & ThisWorkbook.Path & "\" & newFileName & """", 3 '3 = vbMaximizedFocus
            'close this Excel application
            Application.Quit
        Else 'if the new workbook version doesn't exist, then save it as new workbook version
            'save as macro enables office 2007 workbook
            ActiveWorkbook.SaveAs Filename:=newFileName, FileFormat:=52, CreateBackup:=False '52 = xlOpenXMLWorkbookMacroEnabled
            'create a timer to call the same new workbook as it will be now opened in non compatibility mode
            Application.OnTime Now + TimeValue("00:00:01"), "auto_open"
            Workbooks(newFileName).Close
        End If
        
        Application.DisplayAlerts = True
    End If
    
    UserForm1.Show
End Sub

Some brief info on how this works, so far the only way I have found to run in Non-Compatibility Mode is to save the Workbook as an Excel Macro Enabled Workbook and reopen the file, or if the file already exists then open that file and close the Excel 2003 Workbook. The main problem is the showing of a UserForm on the reopen or existing open. The bove code is the only way I have found so far, and it involves some trickery. It can be simplified if portions are separated into the Workbook_Activate subroutine, but I wanted to provide a copy and paste solution with minimal fiddling around. The only change in the above code is the UserForm1 name.

One of the problems was the Workbook_Activate or Auto_open not running when called via the normal Open method. I actually had to ask ExpertsExchange, the expert was very helpful.

Any comments or suggestions welcome as always.