Babylon - Contacts

I'm a big fan of Babylon to easily translate or explain something. I also use it a lot with my own created "dictionaries". For example: I made some script to easily export all my Microsoft Outlook contacts and create a Babylon dictionary out of it. Whenever I need a name, email, phone number, ... of some contact, I just have to provide a name, company, phone number,... to immediately popup my contacts details with just a click.

Follow these steps if you want to be able to export your own Outlook contacts to Babylon.

1. Export MS Outlook contacts to Excel file: Menu 'File' -> 'Import and export' -> 'Export to file' -> 'Microsoft Excel 97-2003' -> 'Contacts' -> chose some location to save the file
2. Open the generated Excel file
3. Add a new macro in the Excel file: Menu 'Developer' -> 'Visual Basic' -> Sheet1 -> Copy-paste my macro from here :

Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
  "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Type OPENFILENAME
  lStructSize As Long
  hwndOwner As Long
  hInstance As Long
  lpstrFilter As String
  lpstrCustomFilter As String
  nMaxCustFilter As Long
  nFilterIndex As Long
  lpstrFile As String
  nMaxFile As Long
  lpstrFileTitle As String
  nMaxFileTitle As Long
  lpstrInitialDir As String
  lpstrTitle As String
  flags As Long
  nFileOffset As Integer
  nFileExtension As Integer
  lpstrDefExt As String
  lCustData As Long
  lpfnHook As Long
  lpTemplateName As String
End Type
Sub ConvertOutlookContactsToBabylon()
    sFile = "C:\Contacts.gls"
    
    Application.ScreenUpdating = False
    ' turns off screen updating
    Application.DisplayStatusBar = True
    ' makes sure that the statusbar is visible
    Application.StatusBar = "Preparing babylon file in " + sFile
    
    '--------------------------------------------------------------------------
    'Create export file
    '--------------------------------------------------------------------------
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.CreateTextFile(sFile, True)
    f.writeline ("### Glossary title:Contacts")
    f.writeline ("### Author:")
    f.writeline ("### Description:Contacts")
    f.writeline ("### Source language:Dutch")
    f.writeline ("### Source alphabet:Latin")
    f.writeline ("### Target language:Dutch")
    f.writeline ("### Target alphabet:Latin")
    f.writeline ("### Icon:")
    f.writeline ("### Icon2:")
    f.writeline ("### Browsing enabled?Yes")
    
    f.writeline ("### Type of glossary:00000000")
    f.writeline ("### Case sensitive words?0")
    f.writeline ("; DO NOT EDIT THE NEXT **SIX** LINES  - Babylon-Builder generated text !!!!!!")
    f.writeline ("### Glossary id:029f645f6877899f836e9c869d8a89447c6e8e9e8271769a9d659559957889978372869c8477772a9693897f5d89526e7c458944648127444854575a428a9244977c946e5b524147584c559fcc23264eac62515a414f4b8b279a224f5a42474f5f555638993bd86e5b524147584c559f908e2d60475e5a4b597e66833a32294d48429a4d5955")
    f.writeline ("### Confirmation string:7C221QRF")
    f.writeline ("### File build number:01292D7C")
    f.writeline ("### Build:")
    f.writeline ("### Glossary settings:00000000")
    f.writeline ("### Gls type:00000001")
    f.writeline ("; DO NOT EDIT THE PREVIOUS **SIX** LINES  - Babylon-Builder generated text !!!!!!")
    f.writeline ("### Part of speech table:")
    f.writeline ("### Private label id:")
    f.writeline ("### Min version:0")
    f.writeline ("### Regular expression:")
    f.writeline ("### Glossary section:")
    'Find a free column to fill with copy
    ' and find the column to copy from
    For iColumn = 1 To 65000
        'Empty column, stop loop
        colName = CStr(Worksheets(1).Cells(1, iColumn).Value)
        If colName = Empty Then
          lastColumn = iColumn
            Exit For
        End If
        
        'Columns to remove
        If colName = "E-mail Type" Or colName = "E-mail Display Name" Or colName = "E-mail 2 Type" Or colName = "E-mail 2 Type" Or colName = "E-mail 2 Display Name" Or colName = "E-mail 3 Type" Or colName = "E-mail 3 Display Name" Or colName = "Gender" Or colName = "Priority" Or colName = "Private" Or colName = "Sensitivity" Then
          Worksheets(1).Columns(iColumn).Delete (xlShiftToLeft)
          iColumn = iColumn - 1
        End If
        
    Next iColumn
    
    
    'go thru all rows
    For iRow = 2 To 65000
    
        'check if last row to do
        If Worksheets(1).Cells(iRow, 2).Value = Empty And Worksheets(1).Cells(iRow, 4).Value = Empty And Worksheets(1).Cells(iRow + 1, 2).Value = Empty And Worksheets(1).Cells(iRow + 1, 4).Value = Empty Then
            Exit For
        End If
        
        'start new line for babylon display data
        Worksheets(1).Rows(iRow + 1).Insert (xlShiftDown)
        'insert empty row between each contact
        Worksheets(1).Rows(iRow + 2).Insert (xlShiftDown)
        
        'output line, will be written to file
        sLine = ""
        
        'babylon subject
        sSubject = ""
        FullName = CStr(Worksheets(1).Cells(iRow, 2).Value) + " " + CStr(Worksheets(1).Cells(iRow, 4).Value) + "|" + CStr(Worksheets(1).Cells(iRow, 4).Value) + " " + CStr(Worksheets(1).Cells(iRow, 2).Value) + "|"
        
        'keep track of column working in, since cells will be deleted but not in header row
        iColumn = 1
        For headerColumn = 1 To (lastColumn - 1)
            If Worksheets(1).Cells(iRow, iColumn).Value <> Empty Then
                
                'convert value to string
                elementValue = CStr(Worksheets(1).Cells(iRow, iColumn).Value)
                
                
                'eleminiate empty birthday dates
                If elementValue = "0/0/00" Then
                    Worksheets(1).Cells(iRow, iColumn).Value = ""
                Else
                    'insert babylon display data
                    displayData = elementValue
                    
                    'convert email addresses to links
                    If InStr(displayData, "@") And (Not InStr(displayData, " ")) Then
                        displayData = "<a href='mailto:" + elementValue + "'>" + elementValue + "</a>"
                    End If
                    
                    'convert web links
                    If Worksheets(1).Cells(1, headerColumn).Value = "WebPage" Then
                        If Not InStr(elementValue, "http://") Then
                            displayData = "<a href='http://" + elementValue + "'>" + elementValue + "</a>"
                        Else
                            displayData = "<a href='" + elementValue + "'>" + elementValue + "</a>"
                        End If
                    End If
                    
                    'convert phone numbers
                    If InStr(Worksheets(1).Cells(1, headerColumn).Value, "Phone") Or InStr(Worksheets(1).Cells(1, headerColumn).Value, "Fax") Then
                        displayData = Replace(Replace(Replace(elementValue, "+31", "+31."), "+33", "+33."), "+32", "+32.")
                    End If
                    
                    
                    'convert categories
                    If Worksheets(1).Cells(1, headerColumn).Value = "Categories" Then
                        displayArray = Split(displayData, ";")
                        displayData = ""
                        For Each sArrayElement In displayArray
                            displayData = displayData + "<a href='bword://" + sArrayElement + "'>" + sArrayElement + "</a> "
                        Next
                    End If
                        
                        
                    'Put display data in sheet
                    Worksheets(1).Cells(iRow + 1, 1).Value = Worksheets(1).Cells(iRow + 1, 1).Value + "<b>" + Worksheets(1).Cells(1, headerColumn).Value + "</b>: " + Replace(Replace(Replace(displayData, vbCrLf, "<br>"), vbCr, "<br>"), ";", ",") + "<br>"
                    
                    
                    'replace vbCrLf vbCr ; with |
                    elementValue = Replace(Replace(Replace(Replace(elementValue, vbCrLf, "|"), vbCr, "|"), ";", "|"), "||", "|")
                    'replace all special character for babylon search data
                    replacedChars = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(elementValue, " ", "|"), ".", "|"), "@", "|"), ":", "|"), ";", "|"), "-", "|"), "/", "|"), "||", "|"), "||", "|"), "|&|", "|"), "|-|", "|"), "|.|", "|"), "|~|", "|"), "|=|", "|")
                    replacedChars = Replace(Replace(Replace(replacedChars, "+31", "0"), "+33", "0"), "+32", "0")
                    
                    If replacedChars <> elementValue Then
                        Worksheets(1).Cells(iRow, iColumn).Value = elementValue + "|" + replacedChars + "|"
                    Else
                        Worksheets(1).Cells(iRow, iColumn).Value = elementValue + "|"
                    End If
                    
                    If headerColumn = 1 Or headerColumn = 2 Or headerColumn = 3 Or headerColumn = 4 Then
                        If sSubject = "" Then
                            sSubject = elementValue
                        Else
                            sSubject = sSubject + " " + elementValue
                        End If
                    End If
                    
                End If
                
                If Worksheets(1).Cells(1, headerColumn).Value <> "Notes" Then
                    sLine = sLine + Worksheets(1).Cells(iRow, iColumn).Value
                End If
                'handle next cell in next loop of For
                iColumn = iColumn + 1
            Else
                'empty column: remove cell and shift other cells left
                'keep track of original cell location to get the heading name of the cell
                'deleting cells is very slow!
                'Worksheets(1).Cells(iRow, iColumn).Delete (xlShiftToLeft)
                
                'handle next cell in next loop of For, not needed if cells are deleted
                iColumn = iColumn + 1
            End If
        Next headerColumn
        
        sSubject = Replace(sSubject, "|", " ")
        
        'writing to file
        
        f.writeline (Replace(sSubject + "|" + FullName + sLine, "||", "|"))
        f.writeline (Replace(CStr(Worksheets(1).Cells(iRow + 1, 1).Value), vbTab, " "))
        f.writeline ("")
        iRow = iRow + 2
    Next iRow
    
    'Close export file
    f.Close
    
    Application.ScreenUpdating = True
    ' turns off screen updating
    Application.DisplayStatusBar = True
    ' makes sure that the statusbar is visible
    MsgBox "Babylon file prepared in " + sFile
End Sub




4. Close Visual Basic editor


5. Run the created Macro: Menu 'Developer' -> 'Macro' –> 'ConvertOutlookContactsToBabylon'


6. A file called 'c:\Contacts.gls' will be created on your C: drive


7. Open BabylonBuilder.exe and open the gls file 'c:\Contacts.gls': Menu 'File' -> 'Open' (The new version of BabylonBuilder can also be used to compile .gls to .bgl)


8. Press 'Edit screen'


9. Press 'Build screen'


10. Press 'Build'


11. A file called 'Contacts.bgl' file will be created, this is the compile Babylon dictionary.


12. Double click the 'Contacts.bgl' file to load it into Babylon


13. Use Babylon to search on any contact and immediately see all contact details.