The first getType takes in a path of a folder or file and returns the type.

Function getType(ByRef path As String) As String
    On Error Resume Next
    Dim res As Long
    res = GetAttr(path)
    If Err.Number = 0 Then
        If res And vbDirectory Then
            getType = "folder"
        Else
            getType = "file"
        End If
    Else
        getType = "error"
    End If
End Function

The second function getDate takes in a folder or path and returns the date modified. getDate references getType.

Function getDate(ByRef path As String) As Double
    Select Case getType(path)
        Case "file"
            getDate = CreateObject("scripting.filesystemobject").getfile(path).datelastmodified
        Case "folder"
            getDate = CreateObject("scripting.filesystemobject").getfolder(path).datelastmodified
    End Select
End Function

Private Function encodeBase64(ByRef arrData() As Byte) As String
    Dim objXML As MSXML2.DOMDocument
    Dim objNode As MSXML2.IXMLDOMElement

    Set objXML = New MSXML2.DOMDocument

    Set objNode = objXML.createElement("b64")
    objNode.DataType = "bin.base64"
    objNode.nodeTypedValue = arrData
    encodeBase64 = objNode.Text

    Set objNode = Nothing
    Set objXML = Nothing
End Function

Private Function decodeBase64(ByVal strData As String) As Byte()
    Dim objXML As MSXML2.DOMDocument
    Dim objNode As MSXML2.IXMLDOMElement

    Set objXML = New MSXML2.DOMDocument
    Set objNode = objXML.createElement("b64")
    objNode.DataType = "bin.base64"
    objNode.Text = strData
    decodeBase64 = objNode.nodeTypedValue

    Set objNode = Nothing
    Set objXML = Nothing
End Function

Function bin2Byte(ByVal s As String) As Byte()
    Dim bitsIn As Long
    bitsIn = 8

    Dim i As Long
    'pad with zeros
    If Len(s) Mod bitsIn <> 0 Then
        For i = 1 To bitsIn - Len(s) Mod bitsIn
            s = "0" & s
        Next i
    End If

    i = Len(s)
    Dim bytes() As Byte
    Dim byteCount As Long
    byteCount = -1
    Dim sByte As String
    Do While LenB(s) > 0
        byteCount = byteCount + 1
        ReDim Preserve bytes(byteCount)

        sByte = Mid$(s, Len(s) - bitsIn + 1)
        'sByte = Mid$(s, 1, bitsIn)
        For i = 0 To 7 Step 1
            bytes(byteCount) = bytes(byteCount) + CLng(Mid$(sByte, 8 - i, 1)) * 2 ^ i
        Next i
        s = Mid$(s, 1, Len(s) - bitsIn)
        's = Mid$(s, bitsIn + 1)
    Loop
    bin2Byte = bytes
End Function

Function byte2Bin(ByRef bytes() As Byte) As String
    Dim i As Long, j As Long
    Dim bin As String
    For i = 0 To UBound(bytes)
        bin = Space$(8)

        For j = 0 To 7
            If bytes(i) And 2 ^ j Then
                Mid(bin, 8 - j, 1) = "1"
            Else
                'Mid(bin, 8 - j, 1) = "0"
            End If
        Next j

        byte2Bin = bin & byte2Bin
    Next i
    byte2Bin = LTrim$(byte2Bin)
    byte2Bin = Replace(byte2Bin, " ", "0", 1, -1, vbBinaryCompare)
End Function

Sub tester()
    'note we can't add any 0 padding to the test binary string
    Dim bin As String
    bin = "111101000001100010101"
    Dim binOut As String
    binOut = byte2Bin(decodeBase64(encodeBase64(bin2Byte(bin))))

    MsgBox binOut = bin
End Sub

Thanks to Tim Hastings for the Base64 functions.

A few constants to change in the script (edit with Notepad);

• RESIZEWIDTH – thumbnail width
• RESIZEHEIGHT – thumbnail height
• IGNOREVERTICAL – should vertical (portrait0 images be ignored (I like to do these manually as I crop them to landscape)
• SUFFIX – thumbnail suffix

To run it, simply place the script in your image folder (make sure to take a backup) and execute the file.
auto-resize-images-v0.1.vbs

Public Const RESIZEWIDTH = 150
Public Const RESIZEHEIGHT = 113

Public Const IGNOREVERTICAL = True
Public Const SUFFIX = "-th"

Dim spath
spath = Mid(WScript.ScriptFullName, 1, InStrRev(WScript.ScriptFullName, "\", -1, vbBinaryCompare))

Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")

Dim foldero
Set foldero = fso.GetFolder(spath)

Dim fileo
Dim sfile

For Each fileo In foldero.Files
    'only modify jpg files
    sfile = fileo.Name
    If InStrRev(sfile, ".jpg", -1, vbTextCompare) = Len(sfile) - 3 Then
        resize spath & sfile
    End If
Next

MsgBox "Complete."

Sub resize(sfilename)

    Set WshShell = WScript.CreateObject("WScript.Shell")
    Set colProcessList = GetObject("Winmgmts:").ExecQuery("Select * from Win32_Process")

    Dim found
    found = False

    For Each objProcess In colProcessList
        If StrComp(objProcess.Name, "photoshop.exe", vbTextCompare) = 0 Then
            found = True
            Exit For
        End If
    Next

    Dim appRef
    If found Then
        Set appRef = GetObject(, "Photoshop.Application")
    Else
        Set appRef = CreateObject("Photoshop.Application")
    End If

    Do While appRef.documents.Count
       appRef.activeDocument.Close 2 'dont' save
    Loop

    Dim originalRulerUnits
    originalRulerUnits = appRef.Preferences.RulerUnits
    appRef.Preferences.RulerUnits = 1 'pixels

    Dim docRef
    Set docRef = appRef.Open(sfilename)

    Dim modified
    modified = False

    If docRef.Width >= docRef.Height Then 'horizontal photo
            If docRef.Width <> RESIZEWIDTH Then 'proceed if not already resized
                docRef.ResizeImage RESIZEWIDTH 'preserves aspect ratio
                modified = True
            End If
    Else 'verticle photo
        If Not IGNOREVERTICAL Then 'proceed
            If docRef.Height <> RESIZEHEIGHT Then 'proceed if not already resized
                docRef.ResizeImage , RESIZEHEIGHT 'preserves aspect ratio
                modified = True
            End If
        End If
    End If

    If modified Then 'only save if the image was modified
        Dim jpgSaveOptions
        Set jpgSaveOptions = CreateObject("Photoshop.JPEGSaveOptions")
        jpgSaveOptions.Quality = 8

        'calculate the new file name
        Dim newfilename
        newfilename = Mid(sfilename, 1, Len(sfilename) - 4) & SUFFIX & ".jpg"

        docRef.SaveAs newfilename, jpgSaveOptions, True, 2 'for psLowercase
    End If

    docRef.Close 2 'dont' save

    appRef.Preferences.RulerUnits = originalRulerUnits

End Sub

• Didn’t use GetObject.
• Didn’t display any command (cmd) prompt.
• Didn’t use a temporary files.

Here is what I found;

<br />
Function ping(node)<br />
    Set WshShell = CreateObject(&quot;WScript.Shell&quot;)<br />
    ping = Not CBool(WshShell.Run(&quot;ping -n 1 &quot; &amp; node, 0, True))<br />
End Function<br />

I was looking at a way to timeout the ping function after 1 second using Threading but this didn’t quite make it so simple. Whilst ping offers a timeout value if you ping an incorrect hostname it will hang for a little while.

• CBin – converts a decimal integer to binary string.
• CDeci – converts a binary string to decimal integer.
• CBinS16 – converts a decimal signed integer to 16 bit binary string.
• CdecS16 – converts a 16 bit binary string to decimal signed integer.

'converts an integer to binary string
Function CBin(ByVal n As Double) As String
    On Error Resume Next 'caters for 0 values
    Dim i As Double
    i = 2 ^ Int(Log(n) / Log(2))
    Do While i >= 1
        CBin = CBin & Fix(n / i)
        n = n - i * Fix(n / i)
        i = i / 2
    Loop
End Function

'converts a binary string to integer
Function CDeci(ByRef s As String) As Double
    Dim i As Long
    CDeci = 0
    For i = 0 To Len(s) - 1
        CDeci = CDeci + (Mid$(s, Len(s) - i, 1) * 2 ^ i)
    Next i
End Function

'converts an integer to 16 bit signed binary string
Function CBinS16(ByVal n As Double) As String
    Dim i As Double

    CBinS16 = vbNullString
    If n < -2 ^ 15 Then
        CBinS16 = "0"
        n = n + 2 ^ 16
        i = 2 ^ 14
    ElseIf n < 0 Then
        CBinS16 = "1"
        n = n + 2 ^ 15
        i = 2 ^ 14
    Else 'not negative
        i = 2 ^ 15
    End If

    Do While i >= 1
        CBinS16 = CBinS16 & Fix(n / i)
        n = n - i * Fix(n / i)
        i = i / 2
    Loop
End Function

'converts 16 bit signed binary string to integer
Function CDecS16(ByRef s As String) As Double
    Dim i As Long
    CDecS16 = 0
    For i = 0 To Len(s) - 1
        CDecS16 = CDecS16 + (Mid$(s, Len(s) - i, 1) * 2 ^ i)
    Next i
    If CDecS16 >= 2 ^ 15 Then 'negative number
        CDecS16 = CDecS16 - 2 ^ 16
    End If
End Function

First, using the standard INSERT INTO without specifying column names. TickCount of 70547.

For i = 1 To 10000
	Connection.Execute "INSERT INTO TABLETESTER VALUES (1, 'abcdefghijklmnopqrstuvwxyz')"
Next i

Specifying the column names is actually marginally faster. TickCount of 66782.

For i = 1 To 100000
    Connection.Execute "INSERT INTO TABLETESTER (NUMBERVAL, STRINGVAL) VALUES (1, 'abcdefghijklmnopqrstuvwxyz')"
Next i

Removing the optional INTO is a little faster still. TickCount 64843.

For i = 1 To 100000
	Connection.Execute "INSERT TABLETESTER (NUMBERVAL, STRINGVAL) VALUES (1, 'abcdefghijklmnopqrstuvwxyz')"
Next i

Now lets try some of the methods to combine multiple inserts.

Bunching multiple statements in a single Execute increases the speed by 2. TickCount 35391.

For i = 1 To 100000 / 100
	s = vbNullString
	For j = 1 To 100
		s = s & "INSERT TABLETESTER (NUMBERVAL, STRINGVAL) VALUES (1, 'abcdefghijklmnopqrstuvwxyz');"
	Next j
	Connection.Execute = s
Next i

Using UNION ALL increases it by a whopping 10 fold. TickCount 2781.

For i = 1 To 100000 / 100
	s = "INSERT INTO TABLETESTER (NUMBERVAL, STRINGVAL) SELECT  1, 'abcdefghijklmnopqrstuvwxyz'"
	For j = 2 To 100
		s = s & " UNION ALL SELECT  1, 'abcdefghijklmnopqrstuvwxyz'"
	Next j
	Connection.Execute = s
Next i

Increasing the inner loop count. TickCount 3125.

For i = 1 To 100000 / 1000
	s = "INSERT INTO TABLETESTER (NUMBERVAL, STRINGVAL) SELECT  1, 'abcdefghijklmnopqrstuvwxyz'"
	For j = 2 To 1000
		s = s & " UNION ALL SELECT  1, 'abcdefghijklmnopqrstuvwxyz'"
	Next j
	Connection.Execute = s
Next i

Decreasing the inner loop count. TickCount 8235.

For i = 1 To 100000 / 10
	s = "INSERT INTO TABLETESTER (NUMBERVAL, STRINGVAL) SELECT  1, 'abcdefghijklmnopqrstuvwxyz'"
	For j = 2 To 10
		s = s & " UNION ALL SELECT  1, 'abcdefghijklmnopqrstuvwxyz'"
	Next j
	Connection.Execute = s
Next i

SQL Server 2008 has a new method of combining multiple inserts. TickCount 3282.

For i = 1 To 100000 / 100
	s = "INSERT TABLETESTER (NUMBERVAL, STRINGVAL) VALUES (1, 'abcdefghijklmnopqrstuvwxyz')"
	For j = 2 To 100
		s = s & ", (1, 'abcdefghijklmnopqrstuvwxyz')"
	Next j
	Connection.Execute = s
Next i

Increasing the inner loop count, note 1000 is the maximum allowed. TickCount 2859.

For i = 1 To 100000 / 1000
	s = "INSERT TABLETESTER (NUMBERVAL, STRINGVAL) VALUES (1, 'abcdefghijklmnopqrstuvwxyz')"
	For j = 2 To 1000
		s = s & ", (1, 'abcdefghijklmnopqrstuvwxyz')"
	Next j
	Connection.Execute = s
Next i

Finally, not a SQL syntax change, but compacting the strings. TickCount 2453.

For i = 1 To 100000 / 1000
	s = "INSERT TABLETESTER (NUMBERVAL,STRINGVAL) VALUES (1,'abcdefghijklmnopqrstuvwxyz')"
	For j = 2 To 1000
		s = s & ",(1,'abcdefghijklmnopqrstuvwxyz')"
	Next j
	Connection.Execute = s
Next i

So from our original method at 66782 to our optimised method at 2453, we get a 97% speed saving!

The test situation was to find if the last character in the string ‘abcdefghijklmnopqrstuvwxyz’ is ‘z’ and iterated 100000000 times.

First, the most intuitive which most would use. TickCount of 49546.

Right("abcdefghijklmnopqrstuvwxyz", 1) = "z"

Function Right takes in a Variant by default, by succeeding it with a dollar sign it accepts Strings by default. TickCount of 22828, a significant saving.

Right$("abcdefghijklmnopqrstuvwxyz", 1) = "z"

Using the equals sign would be seem the norm, but what if the String Compare function was used. TickCount of 18047.

StrComp(Right$("abcdefghijklmnopqrstuvwxyz", 1), "z", vbBinaryCompare) = 0

What if Mid was used to extract the last character instead of Right. TickCount of 28391.

StrComp(Mid$("abcdefghijklmnopqrstuvwxyz", Len("abcdefghijklmnopqrstuvwxyz"), 1), "z") = 0

Now what if we use the In String function. String length binary is faster than standard String length. TickCount of 14516.

InStrRev("abcdefghijklmnopqrstuvwxyz", "z", -1, vbBinaryCompare) = LenB("abcdefghijklmnopqrstuvwxyz") / 2

Finally, with out String length binary. TickCount of 11312.

InStrRev("abcdefghijklmnopqrstuvwxyz", "z", -1, vbBinaryCompare) = Len("abcdefghijklmnopqrstuvwxyz")

So using In String Reverse is 77% faster.

UPDATE next day: Three that I totally forgot about

In String starting at last character, TickCount 11266.

InStr(Len("abcdefghijklmnopqrstuvwxyz"), "abcdefghijklmnopqrstuvwxyz", "z", vbBinaryCompare) = Len("abcdefghijklmnopqrstuvwxyz")

And In String Binary which is naturally fast. TickCount 6672.

InStrB(LenB("abcdefghijklmnopqrstuvwxyz") - 1, "abcdefghijklmnopqrstuvwxyz", "z", vbBinaryCompare) = LenB("abcdefghijklmnopqrstuvwxyz") - 1

So using In String Binary is 70% faster.

'Convert positive integer to a base36 string.
Function base36encode(ByRef number As Long) As String

    Dim alphabet As String
    alphabet = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
    If number = 0 Then
        base36encode = "0"
        Exit Function
    End If
    base36encode = vbNullString
    Do While number <> 0
        base36encode = Mid(alphabet, number Mod 36 + 1, 1) & base36encode
        number = number \ 36
    Loop

End Function

'Convert base36 string to positive integer.
Function base36decode(ByRef base36 As String) As Long

    Dim alphabet As String
    alphabet = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"

    base36decode = InStr(1, alphabet, Right(base36, 1), vbTextCompare) - 1 'get the last character
    For i = Len(base36) - 1 To 1 Step -1
        base36decode = base36decode + 36 ^ (Len(base36) - i) * (InStr(1, alphabet, Mid(base36, i, 1), vbTextCompare) - 1)
    Next i

End Function

In eventquery.vbs, scroll down to line 1700 and 1703 and change both CInt to CLng.
Before;

        If CInt(objLogs.Item(arrKeyName(intLoopCount))) > 0 Then
            strFilterLog = arrKeyName(intLoopCount)
            intRecordRangeFrom = 0
            intRecordRangeTo = CInt(objLogs.Item(arrKeyName(intLoopCount)))

After;

        If CLng(objLogs.Item(arrKeyName(intLoopCount))) > 0 Then
            strFilterLog = arrKeyName(intLoopCount)
            intRecordRangeFrom = 0
            intRecordRangeTo = CLng(objLogs.Item(arrKeyName(intLoopCount)))

Or download the already updated eventquery.vbs.

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