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
Posts
