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
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

        '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

        '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

                '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)
                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)

        '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)
        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

Review of A-PDF Page Cut – software to split a pdf page in half

I came into the requirement of needing to split the  pages of a pdf in half, normally this is required when you scan a book and have two pages per scan, but my specific example was a Lonely Planet digital publication which for some reason was  released similarly, as I wanted to view it on a Kindle I required single pages only.

My first trial was free software Briss, Java coded cross-platform, I did not find it intuitive at all and couldn’t get it to work, there was no way to select exactly half of the sheet, and no batch functionality.

I then moved to Page Cut by A-PDF, A-PDF have an interesting offer called “Blog it and get it” where you blog about the software and they give you a free license, hence this post, hopefully it pulls through.

Page Cut is extremely easy to use, the steps to split a page in half are;

  1. Open pdf with Page Cut
  2. Click Add a Vertical Line from the toolbar
  3. Click Apply with default settings
  4. Click Cut and Save As

That’s it you have a single page per page pdf.

Cutting a single pdf pages in half

Batch Cut Mode is even easier;

  1. Import pdf  with Page Cut
  2. Select Cut Vertical In Half
  3. Click Cut and Save As

Batch cutting multiple pdf pages in half

So what is Page Cut missing?

I would like to see some smarts; mainly for batch cuts, warnings if cuts go through words (or there isn’t enough blank white space).

The other thing needed is a column showing if the pdf is Landscape or Portait, with the option to select/deselect either. In general a landscape page will have two pages per page, a portrait page can be ignored.

As I needed this functionality, I wrote a little VB function that finds the page orientation, it does require Acrobat though. I could then filter and move to a separate folder landscape orientated pdfs to be imported into Page Cut, here’s the code;

Public Function getOrientation(ByRef gPDFPath As String) As String
    If LenB(gPDFPath) > 0 Then
        Dim acroApp, avDoc, pdDoc, pdPage
        Dim acroPoint
        Dim x As Long, y As Long

        Set acroApp = CreateObject("AcroExch.App")
        If acroApp.GetNumAVDocs = 0 Then 'no existing files
        End If
        Set avDoc = CreateObject("AcroExch.AVDoc")
        If avDoc.Open(gPDFPath, "Accessing PDF's") Then
            If Not avDoc.IsValid Then
                getOrientation = "Error"
                Exit Function
            End If

            Set pdDoc = avDoc.GetPDDoc()
            Set pdPage = avDoc.GetPDDoc.AcquirePage(0) 'first page

            Set acroPoint = pdPage.GetSize()
            x = acroPoint.x
            y = acroPoint.y
            Set acroPoint = Nothing

            If x >= y Then
                getOrientation = "Landscape"
                getOrientation = "Portrait"
            End If
        End If
        avDoc.Close True
'        If acroApp.GetNumAVDocs > 0 Then
'            acroApp.CloseAllDocs
'        End If
        Set acroApp = Nothing
        Set avDoc = Nothing
        Set pdDoc = Nothing
        Set pdPage = Nothing
    End If
End Function

Finally, on my search for the above functionality I tried A-PDF Explorer, what I noticed was a second folder in my Program Files and Start menu, given A-PDF make a large amount of tools, why not have a root folder A-PDF, with subfolders for each product, makes more sense.

VBA/VB6 functions to return folder or file type and date modified.

Here are two quick functions;

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"
            getType = "file"
        End If
        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

VB6/VBA functions to convert binary string to Base64 string

Here are some functions to convert a binary string, to a byte array, to a Base64 string and then back to a byte array and binary string. Run tester to see it in action, enjoy.

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)
    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"
                '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.

Photoshop VBScript to automatically resize images

Decided to learn Photoshop VBScripting, don’t know why I didn’t do this sooner, I now have scripts to automatically generate my blog thumbnails (as below), and add little Google Maps markers on them (see here).

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

  • RESIZEWIDTH – thumbnail width
  • RESIZEHEIGHT – thumbnail height
  • IGNOREVERTICAL – should vertical (portrait) 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.

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

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

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

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

    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