Create and/or update Outlook contacts from Excel

When you have a good overview of all your contact details in an Excel file, it can be useful to export these towards Outlook (eg to allow automatic synchronization towards your mobile). When including contact pictures, the look and feel of Outlook and your mobile increases a lot by immediately showing the related pictures when receiving a mail or call.

Since the contact details can change over time, I created the Excel macro below to update existing contacts and create the non existing contact within Outlook, including all available details of the contact.

Using a ‘Reference’ sheet, in which the columns are references using a named cell, it’s easy to retrieve the contact details from the right column, while still being able to easily change the data or order. The data is retrieved using the Cells.Range option, eg: Sheets(sheetName).Cells(i, Sheets("References").Range("columnname").Value)

In order to make sure the same contact is not added multiple times, the contact is first retrieved from the available Outlook contacts using the olFolder.Item.Restrict(…filter…) option based on the email address of the contact.

Since I load the contact details from a DB using a linked Query within Excel, I also refresh the query data before performing the migration from Excel to Outlook.

All details can be found in the macro source below and the example Excel file (including the macro).

'Developed by myT, http://myTselection.blogspot.com
Option Explicit


Public Sub RefreshQueries()

  Dim wks As Worksheet
  Dim qt As QueryTable
  Dim lo As ListObject

  For Each wks In Worksheets
    For Each qt In wks.QueryTables
        qt.Refresh BackgroundQuery:=False
    Next qt

    For Each lo In wks.ListObjects
        lo.QueryTable.Refresh BackgroundQuery:=False
    Next lo

  Next wks

  Set qt = Nothing
  Set wks = Nothing
End Sub
'http://www.globaliconnect.com/excel/index.php?option=com_content&view=article&id=167:import-contacts-from-excel-to-outlook-automate-in-vba&catid=79&Itemid=475



Sub ExcelWorksheetDataAddToOutlookContacts()
    'Automating Outlook from Excel: This example uses the Items.Add Method to export data from an Excel Worksheet to the default Contacts folder.
    'Automate Outlook from Excel, using Late Binding. You need not add a reference to the Outlook library in Excel (your host application), in this case you will not be able to use the Outlook's predefined constants and will need to replace them by their numerical values in your code.
    
    
    
    Dim oApplOutlook As Object
    Dim oNsOutlook As Object
    Dim oCFolder As Object
    Dim oDelFolder As Object
    Dim oCItem As Object
    'Dim olItems As Outlook.Items
    Dim olItems As Object
    'Dim olContactItem As contactItem
    Dim olContactItem As Object
    Dim oDelItems As Object
    Dim lLastRow As Long, i As Long, n As Long, c As Long
    Dim firstRowToProcess As Integer, emailColumn As Integer, pictureColumn As Integer, processedColumn As Integer, itemsFound As Integer
    Dim sheetName As String, fullFilePath As String
    Dim updateExistingContacts As Boolean
    
    
    RefreshQueries
    
    'Config:
    sheetName = "Contacts"
    firstRowToProcess = 2
    updateExistingContacts = False
    
    updateExistingContacts = MsgBox("Update and overwrite fields of existing contacts? Pictures will always be updated. (Existing notes will be appended, not overwritten)", vbYesNo, "Overwrite")
    
    
   Application.ScreenUpdating = False
    ' turns off screen updating
    Application.DisplayStatusBar = True
    ' makes sure that the statusbar is visible
    Application.StatusBar = "Preparing export contacts to Outlook"
    
    'determine last data row in the worksheet:
    lLastRow = Sheets(sheetName).Cells(Rows.Count, "A").End(xlUp).Row
    
    'Create a new instance of the Outlook application, if an existing Outlook object is not available.
    'Set the Application object as follows:
    On Error Resume Next
    Set oApplOutlook = GetObject(, "Outlook.Application")
    'if an instance of an existing Outlook object is not available, an error will occur (Err.Number = 0 means no error):
    If Err.Number <> 0 Then
        Set oApplOutlook = CreateObject("Outlook.Application")
    End If
    'disable error handling:
    On Error GoTo 0
    
    'use the GetNameSpace method to instantiate (ie. create an instance) a NameSpace object variable, to access existing Outlook items. Set the NameSpace object as follows:
    Set oNsOutlook = oApplOutlook.GetNamespace("MAPI")
    
    '----------------------------
    
    'Empty the Deleted Items folder in Outlook so that when you quit the Outlook application you bypass the prompt: Are you sure you want to permanently delete all the items and subfolders in the "Deleted Items" folder?
    
    'set the default Deleted Items folder:
'    'The numerical value of olFolderDeletedItems is 3. The following code has replaced the Outlook's built-in constant olFolderDeletedItems by its numerical value 3.
'    Set oDelFolder = oNsOutlook.GetDefaultFolder(3)
'    'set the items collection:
'    Set oDelItems = oDelFolder.Items
'
'    'determine number of items in the collection:
'    c = oDelItems.Count
'    'start deleting from the last item:
'    For n = c To 1 Step -1
'        oDelItems(n).Delete
'    Next n
'
    '----------------------------
    
    'set reference to the default Contact Items folder:
    'The numerical value of olFolderContacts is 10. The following code has replaced the Outlook's built-in constant olFolderContacts by its numerical value 10.
    Set oCFolder = oNsOutlook.GetDefaultFolder(10)
'    Set olItems = oCFolder.Items.Restrict("[MessageClass]='IPM.Contact'")
    
    'Find contact to update, if not found add a new contact item
    
    
    'post each row's data on a separate contact item form:
    For i = firstRowToProcess To lLastRow
    'restrict info: https://msdn.microsoft.com/en-us/vba/outlook-vba/articles/items-restrict-method-outlook
    'folder items info: https://msdn.microsoft.com/en-us/vba/outlook-vba/articles/folder-items-property-outlook
        Set olItems = oCFolder.Items.Restrict("[MessageClass]='IPM.Contact' And [Email1Address] = '" & Sheets(sheetName).Cells(i, Sheets("References").Range("email").Value) & "'")
        
        itemsFound = 0
        For Each olContactItem In olItems
            
            Application.StatusBar = "Updating Outlook contact " + olContactItem.FullName & ", " & Sheets(sheetName).Cells(i, Sheets("References").Range("pnr").Value)
            'matching contact found in Outlook and Excel
			'web pictures should be stored in a local folder
            fullFilePath = Replace(Sheets(sheetName).Cells(i, Sheets("References").Range("pictureurl").Value), "http://someimageurl", "C:\Users\username\Documents\Pictures\profilephotos\")
            If FileExists(fullFilePath) Then
                olContactItem.AddPicture (fullFilePath)
            Else
                'MsgBox ("Missing picture: " + fullFilePath + ", for member: " + olContactItem.firstName + " " + olContactItem.lastname)
                Debug.Print ("Missing picture: " & fullFilePath & ", for member: " & olContactItem.firstName & " " & olContactItem.lastName)
            End If
            If updateExistingContacts = True Then
                With olContactItem
                    'update existing contact fields https://msdn.microsoft.com/en-us/library/microsoft.office.interop.outlook._contactitem_properties.aspx
                    .firstName = Sheets(sheetName).Cells(i, Sheets("References").Range("first_name").Value)
                    .lastName = Sheets(sheetName).Cells(i, Sheets("References").Range("last_name").Value)
                    If (Sheets(sheetName).Cells(i, Sheets("References").Range("birthdate").Value) <> "") Then
                        .Birthday = DateValue(Sheets(sheetName).Cells(i, Sheets("References").Range("birthdate").Value))
                    End If
                    .BusinessAddressStreet = "BusinessStreet 100"
                    .BusinessAddressCity = "BusinessCity"
                    .BusinessAddressCountry = "BusinessCountry"
                    .BusinessAddressPostalCode = "BusinessPostal"
                    .BusinessHomePage = "http://www.company.com"
                    'do not remove or duplicate existing categories, set some desired category when not yet set
                    If (InStr(.Categories, "Business") = 0) Then
                        .Categories = .Categories & ",Business"
                    End If
                    .CompanyName = "Company"
                    .Email1DisplayName = Sheets(sheetName).Cells(i, Sheets("References").Range("email").Value)
                    .FullName = Sheets(sheetName).Cells(i, Sheets("References").Range("first_name").Value) & " " & Sheets(sheetName).Cells(i, Sheets("References").Range("last_name").Value)
                    .FileAs = Sheets(sheetName).Cells(i, Sheets("References").Range("first_name").Value) & " " & Sheets(sheetName).Cells(i, Sheets("References").Range("last_name").Value)
                    '.gender = Sheets(sheetName).Cells(i, Sheets("References").Range("gender").Value)
'                    If (Sheets(sheetName).Cells(i, Sheets("References").Range("gender").Value) = "M") Then
'                        .gender = Microsoft.Office.Interop.Outlook.OlGender.olMale
'                    ElseIf (Sheets(sheetName).Cells(i, Sheets("References").Range("gender").Value) = "F") Then
'                        .gender = Microsoft.Office.Interop.Outlook.OlGender.olFemale
'                    Else
'                        .gender = Microsoft.Office.Interop.Outlook.OlGender.olUnspecified
'                    End If
                    .HomeAddressCity = Sheets(sheetName).Cells(i, Sheets("References").Range("city").Value)
                    .HomeAddressCountry = "DefaultCountry"
                    .HomeAddressPostalCode = Sheets(sheetName).Cells(i, Sheets("References").Range("postcode").Value)
                    .HomeAddressStreet = Sheets(sheetName).Cells(i, Sheets("References").Range("street").Value) & " " & Sheets(sheetName).Cells(i, Sheets("References").Range("street_number").Value)
                    .JobTitle = Sheets(sheetName).Cells(i, Sheets("References").Range("current_function").Value)
                    '.Language = Sheets(sheetName).Cells(i, Sheets("References").Range("speaking_language_info_list").Value)
                    .MobileTelephoneNumber = Sheets(sheetName).Cells(i, Sheets("References").Range("mobile").Value)
                    .BusinessTelephoneNumber = Sheets(sheetName).Cells(i, Sheets("References").Range("phone").Value)
                    .BusinessFaxNumber = Sheets(sheetName).Cells(i, Sheets("References").Range("fax").Value)
                    .Department = Sheets(sheetName).Cells(i, Sheets("References").Range("division").Value)
                    .ManagerName = Sheets(sheetName).Cells(i, Sheets("References").Range("manager").Value)
                    .WebPage = "http://www.company.com"
                    If (InStr(.body, "Staff number: ") = 0) Then
                        .body = "Staff number: " & Sheets(sheetName).Cells(i, Sheets("References").Range("pnr").Value) & vbCrLf
                        .body = .body & "Recruitment date: " & Sheets(sheetName).Cells(i, Sheets("References").Range("recruitment_date").Value) & vbCrLf
                        .body = .body & "Education: " & Sheets(sheetName).Cells(i, Sheets("References").Range("educations").Value) & vbCrLf
                        .body = .body & "Languages: " & Sheets(sheetName).Cells(i, Sheets("References").Range("speaking_language_info_list").Value) & vbCrLf
                        .body = .body & "Specialty skills: " & Sheets(sheetName).Cells(i, Sheets("References").Range("specialty_skills").Value) & vbCrLf
'                    Else
' keeps original body note, but duplicates all data if run mulitple times
'                        originalBody = .body
'                        .body = "Staff number: " & Sheets(sheetName).Cells(i, Sheets("References").Range("pnr").Value) & vbCrLf
'                        .body = .body & "Recruitment date: " & Sheets(sheetName).Cells(i, Sheets("References").Range("recruitment_date").Value) & vbCrLf
'                        .body = .body & "Education: " & Sheets(sheetName).Cells(i, Sheets("References").Range("educations").Value) & vbCrLf
'                        .body = .body & "Languages: " & Sheets(sheetName).Cells(i, Sheets("References").Range("speaking_language_info_list").Value) & vbCrLf
'                        .body = .body & "Specialty skills: " & Sheets(sheetName).Cells(i, Sheets("References").Range("specialty_skills").Value) & vbCrLf
'                        .body = .body & vbCrLf & originalBody
                    End If
                End With
                                        
            End If
            Sheets(sheetName).Cells(i, Sheets("References").Range("processed").Value).Value = "OK"
            olContactItem.Save
            itemsFound = itemsFound + 1
        Next
        
        If itemsFound = 0 Then
            Application.StatusBar = "Adding Outlook contact " & Sheets(sheetName).Cells(i, Sheets("References").Range("first_name").Value) & " " & Sheets(sheetName).Cells(i, Sheets("References").Range("last_name").Value) & ", " & Sheets(sheetName).Cells(i, Sheets("References").Range("pnr").Value)
            'Using the Items.Add Method to create a new Outlook contact item in the default Contacts folder.
            Set oCItem = oCFolder.Items.Add
            'display the new contact item form:
            'oCItem.Display
            'set properties of the new contact item:
            With oCItem
                    'update existing contact fields https://msdn.microsoft.com/en-us/library/microsoft.office.interop.outlook._contactitem_properties.aspx
                    .firstName = Sheets(sheetName).Cells(i, Sheets("References").Range("first_name").Value)
                    .lastName = Sheets(sheetName).Cells(i, Sheets("References").Range("last_name").Value)
                    If (Sheets(sheetName).Cells(i, Sheets("References").Range("birthdate").Value) <> "") Then
                        .Birthday = DateValue(Sheets(sheetName).Cells(i, Sheets("References").Range("birthdate").Value))
                    End If
                    .BusinessAddressStreet = "BusinessStreet 100"
                    .BusinessAddressCity = "BusinessCity"
                    .BusinessAddressCountry = "BusinessCountry"
                    .BusinessAddressPostalCode = "BusinessPostal"
                    .BusinessHomePage = "http://www.company.com"
                    'do not remove or duplicate existing categories, set some desired category when not yet set
                    If (InStr(.Categories, "Business") = 0) Then
                        .Categories = .Categories & ",Business"
                    End If
                    .CompanyName = "Company"
                    .Email1DisplayName = Sheets(sheetName).Cells(i, Sheets("References").Range("email").Value)
                    .FullName = Sheets(sheetName).Cells(i, Sheets("References").Range("first_name").Value) & " " & Sheets(sheetName).Cells(i, Sheets("References").Range("last_name").Value)
                    .FileAs = Sheets(sheetName).Cells(i, Sheets("References").Range("first_name").Value) & " " & Sheets(sheetName).Cells(i, Sheets("References").Range("last_name").Value)
                    '.gender = Sheets(sheetName).Cells(i, Sheets("References").Range("gender").Value)
'                    If (Sheets(sheetName).Cells(i, Sheets("References").Range("gender").Value) = "M") Then
'                        .gender = Microsoft.Office.Interop.Outlook.OlGender.olMale
'                    ElseIf (Sheets(sheetName).Cells(i, Sheets("References").Range("gender").Value) = "F") Then
'                        .gender = Microsoft.Office.Interop.Outlook.OlGender.olFemale
'                    Else
'                        .gender = Microsoft.Office.Interop.Outlook.OlGender.olUnspecified
'                    End If
                    .HomeAddressCity = Sheets(sheetName).Cells(i, Sheets("References").Range("city").Value)
                    .HomeAddressCountry = "DefaultCountry"
                    .HomeAddressPostalCode = Sheets(sheetName).Cells(i, Sheets("References").Range("postcode").Value)
                    .HomeAddressStreet = Sheets(sheetName).Cells(i, Sheets("References").Range("street").Value) & " " & Sheets(sheetName).Cells(i, Sheets("References").Range("street_number").Value)
                    .JobTitle = Sheets(sheetName).Cells(i, Sheets("References").Range("current_function").Value)
                    '.Language = Sheets(sheetName).Cells(i, Sheets("References").Range("speaking_language_info_list").Value)
                    .MobileTelephoneNumber = Sheets(sheetName).Cells(i, Sheets("References").Range("mobile").Value)
                    .BusinessTelephoneNumber = Sheets(sheetName).Cells(i, Sheets("References").Range("phone").Value)
                    .BusinessFaxNumber = Sheets(sheetName).Cells(i, Sheets("References").Range("fax").Value)
                    .Department = Sheets(sheetName).Cells(i, Sheets("References").Range("division").Value)
                    .ManagerName = Sheets(sheetName).Cells(i, Sheets("References").Range("manager").Value)
                    .WebPage = "http://www.company.com"
                    If (InStr(.body, "Staff number: ") = 0) Then
                        .body = "Staff number: " & Sheets(sheetName).Cells(i, Sheets("References").Range("pnr").Value) & vbCrLf
                        .body = .body & "Recruitment date: " & Sheets(sheetName).Cells(i, Sheets("References").Range("recruitment_date").Value) & vbCrLf
                        .body = .body & "Education: " & Sheets(sheetName).Cells(i, Sheets("References").Range("educations").Value) & vbCrLf
                        .body = .body & "Languages: " & Sheets(sheetName).Cells(i, Sheets("References").Range("speaking_language_info_list").Value) & vbCrLf
                        .body = .body & "Specialty skills: " & Sheets(sheetName).Cells(i, Sheets("References").Range("specialty_skills").Value) & vbCrLf
                    End If
            End With
                
                'mark as done
                Sheets(sheetName).Cells(i, Sheets("References").Range("processed").Value).Value = "OK"
            fullFilePath = Replace(Sheets(sheetName).Cells(i, Sheets("References").Range("pictureurl").Value), "http://someimageurl", "C:\Users\username\Documents\Pictures\profilephotos\")
            If FileExists(fullFilePath) Then
                oCItem.AddPicture (fullFilePath)
            Else
                'MsgBox ("Missing picture: " + fullFilePath + ", for member: " + oCItem.firstName + " " + oCItem.lastname)
                Debug.Print ("Missing picture: " & fullFilePath + ", for member: " & oCItem.firstName & " " & oCItem.lastName)
            End If
            'close the new contact item form after saving:
            'The numerical value of olSave is 0. The following code has replaced the Outlook's built-in constant olSave by its numerical value 0.
            oCItem.Close 0
        End If
    Next i
    
    'quit the Oulook application:
    oApplOutlook.Quit
    
    Application.StatusBar = "Outlook " & lLastRow & " contacts exported"
    Application.ScreenUpdating = True
    
    'clear the variables:
    Set oApplOutlook = Nothing
    Set oNsOutlook = Nothing
    Set oCFolder = Nothing
    Set oDelFolder = Nothing
    Set oCItem = Nothing
    Set oDelItems = Nothing
    Set olContactItem = Nothing
    Set olItems = Nothing
    
    MsgBox "Successfully Exported Worksheet Data to the Default Outlook Contacts Folder."
    
     

End Sub

Function FileExists(fullFileName As String) As Boolean
    FileExists = VBA.Len(VBA.Dir(fullFileName)) > 0
End Function

Outlook default reminder for sent mails

Since most of the time, I need to follow up my mails send out to make sure the expected actions are taken, I do add a reminder on my send email. So I can verify in a couple of days if I did get a reaction or the expected action has been taken in the meantime.

In order to automate this, I added the outlook macro shown below. It’s based on the nice example provided by Diane Poremsky. I just improved it a bit to set the default reminder at 10am in 5 days (moving some days forward whenever the 5 days would end in the weekend). After sending an email, a little popup will show up indicating the reminder would be created for within 5 business days. The number of days can quickly be changed or the reminder can fully be discared using the ‘Cancel’ on the pop-up. After some days of usage, I’m very satisfied with the result. The popup will appear after sending the message, so the email will always be sent and won’t be blocked if the pop-up wouldn’t be noticed.

Of course this is only useful when you often need a follow-up on your sent mails…

'Instructions:    
'myT 04/2016, http://myTselection.blogspot.com
  'Default reminder for sent mails: add a default reminder for every sent mail, default 5 working days with popup to cancel or confirm (and set number of days)
  'Instructions:
  'Open Outlook and press [ALT+F11] to open the VBS developer editor
  'Navigate to 'Project 1 VbaProject.OTM' > Microsoft Outlook Objects > ThisOutlookSession
  'Copy and Paste the macro below and close the VBS editor
  'Make sure the line 'Private WithEvents olSentItems as Items' is saved at the top of the file
  Private WithEvents olSentItems As Items
  Attribute olSentItems.VB_VarHelpID = -1
  Private Declare PtrSafe Function ShellExecute _
  Lib "shell32.dll" Alias "ShellExecuteA" ( _
  ByVal hWnd As Long, _
  ByVal Operation As String, _
  ByVal Filename As String, _
  Optional ByVal Parameters As String, _
  Optional ByVal Directory As String, _
  Optional ByVal WindowStyle As Long = vbMinimizedFocus _
  ) As Long
  'Original source: http://www.slipstick.com/developer/code-samples/set-flag-follow-up-using-vba/
  Private Sub Application_Startup()
  'MsgBox ("test startup")
  Dim objNS As NameSpace
  Set objNS = Application.Session
  ' instantiate objects declared WithEvents
  Set olSentItems = objNS.GetDefaultFolder(olFolderSentMail).Items
  Set objNS = Nothing
  End Sub
  Private Sub olSentItems_ItemAdd(ByVal Item As Object)
  'On Error Resume Next
  Dim prompt As String
  Dim dtmTemp As Date
  Dim businessDays As String
  Dim reminderTime As String
  Dim dueDateDays As Integer
  'MsgBox ("test item sent")
  If TypeName(Item) = "MailItem" Then
          businessDays = 5
      dueDateDays = 14
      reminderTime = "10:00:00 AM"
            'Reminder in 5 days, 10 AM
        dtmTemp = DateValue(Now + businessDays) & " " & TimeValue(reminderTime)
        'skip days if reminder would result in weekend
        Do While IsWeekend(dtmTemp)
            dtmTemp = dtmTemp + 1
        Loop
                    'InputBox(prompt[, title] [, default] )
        businessDays = InputBox("Do you want to add a reminder for the email sent? " & vbCrLf & vbCrLf _
        & " Subject: " & Item.Subject & vbCrLf _
        & " To: " & Item.To & vbCrLf & vbCrLf & vbCrLf _
        & "Set # business days for the reminder" & vbCrLf _
        & " Default " & businessDays & " business days: " & WeekdayName(Weekday(dtmTemp), True, vbSunday) & " " & dtmTemp, _
        "Add a reminder for the email sent?", businessDays)
              'Exit sub if user press Cancel button or does not enter any text in the Input field.
        If businessDays = vbNullString Then Exit Sub
              dtmTemp = DateValue(Now + CInt(businessDays)) & " " & TimeValue(reminderTime)
        'skip days if reminder would result in weekend
        Do While IsWeekend(dtmTemp)
            dtmTemp = dtmTemp + 1
        Loop
                           With Item
            .MarkAsTask olMarkThisWeek
              ' sets a due date in 14 days
            .TaskDueDate = Now + dueDateDays
            .ReminderSet = True
            .reminderTime = dtmTemp
            .Save
        End With
    End If
  End Sub

Update 27/06/2016: added check on item type to make sure no error occur when responding to an meeting request.

vCard contact export from Excel contact list

Recently I needed a way to easily convert a list with contact information into a vCard file, respecting the vCard syntax, in order to import this vCard contact information into a phone.

After some quick Google lookup I ended with this nice Excel created and shared by Savas Geivanidis.

After entering all the contact information into the sheet as instructed, the export macro started executing it’s work and I ended with a vCard file as I wanted. But the process took very long (more than 4 minutes), even if my contact list only contained 100 contacts.

Since Savas was so kind to keep his VBS macro unprotected, I analyzed it and optimized it. The main performance issues I detected was the multiple loops and the cell deletions used in the code. A loop was set up to run over the contact data, and copy all data it into a new sheet. Next a loop was used to run through the data and delete all cell containing the value ‘no data’. Next the new sheet was saved into a text .vcf file.

After rewriting the VBS macro I ended up with one loop, running through the data and saving the information immediately into a text file. The same list of 100 contacts now takes less than 1sec to export instead of more than 4 minutes. Some tests with 1000 contacts were positive as it took only 4sec or less to export. I ended up cleaning up the full sheet and creating a template of it to allow easy reuse. Feel free to use this version 1.0 of vCard Exporter for any purpose.

The optimized source code is shown below for illustration:

Sub Create_vCard() 
  
'

' This Macro creates a vCard from an existing phonebook Excel list

'__________________________________________________________________

' Based on DesktopContacts v0.8 by Savas Geivanidis (savas@mycosmos.gr) egnatia.ee.auth.gr/~aki/dc/DesktopContacts0.8.xls

' Major performance improvements by myT in vCardExporter v1.0

'___________________________________________________________________

    
    Application.ScreenUpdating = False

    ' turns off screen updating

    Application.DisplayStatusBar = True

    ' makes sure that the statusbar is visible

    
    'detect number of data contacts provided

    'mainsheet = ActiveSheet.Name

    mainsheet = "PhoneBook"

    Range("A30000").Select

    Selection.End(xlUp).Select

    nod = ActiveCell.Row

    Range("B30000").Select

    Selection.End(xlUp).Select

    nod1 = ActiveCell.Row

    If nod1 > nod Then

        nod = nod1

    End If

    
    'Check if data is provided

    If nod <= 2 Then

        popup = MsgBox("No contact data could be found. Fill in the contact data in the 'PhoneBook' sheet and provide at least a first or last name for each contact." & vbLf & "See the 'Information' sheet and http://myTselection.blogpsot.com for more information", vbExclamation + vbOKOnly + vbMsgBoxSetForeground, "vCard Exporter: No data found")

        Application.ScreenUpdating = True

        Exit Sub

    End If

    
    'request target filename

    vcardname = Application.GetSaveAsFilename("", "vCard Files (*.vcf), *.vcf", , "Please select the name of the vCard to export")

    If vcardname = False Then

        Application.ScreenUpdating = True

        Exit Sub

    End If

    start_time = Now()

    Application.StatusBar = "Preparing VCARD data"

    
    
    Set vcardFileSystemObject = CreateObject("Scripting.FileSystemObject")

    Set vcardFile = vcardFileSystemObject.CreateTextFile(vcardname, True)

    
    
    'copy formula for VCARD syntax to all rows with contact data

    Range(Cells(1, 61), Cells(1, 101)).Copy

    Range(Cells(3, 61), Cells(nod, 101)).PasteSpecial Paste:=xlPasteFormulas

    Application.CutCopyMode = False

    Range("A3").Select

    
    Application.StatusBar = "Processing contact data..."

    
    vcardFile.writeline ("")

    For iRow = 3 To nod

        For iColumn = 61 To 101

            currentValue = Worksheets(mainsheet).Cells(iRow, iColumn).Value

            Application.StatusBar = "Processing contact data " & Round(((iRow - 2) / (nod - 2)) * 100) & "%" '&" on row " & iRow & ", column " & iColumn & ", value: " & currentValue

            If (currentValue <> "no data") Then

                vcardFile.writeline (currentValue)

            End If

            If currentValue = "END:VCARD" Then

                vcardFile.writeline ("")

            End If

        Next iColumn

    Next iRow

    vcardFile.Close

    Application.StatusBar = "All " & nod - 2 & " contact data processed"

    
    Worksheets(mainsheet).Range(Cells(2, 61), Cells(nod, 101)).ClearContents

    Worksheets(mainsheet).Range("A3").Select

    end_time = Now()

    'DateDiff("s", start_time, end_time)

    Application.StatusBar = "vCard export in " & PrintHrMinSec(DateDiff("s", start_time, end_time)) & "sec done into file: " & vcardname

    Application.ScreenUpdating = True

    
    If (nod - 2 = 1) Then

        popup = MsgBox(nod - 2 & " contact is exported to:" & vbLf & "'" & vcardname & "'" & vbLf & vbLf & "Please send this file to your phone and run it in order to add this contact into it." & vbLf & vbLf & "Original development 'Desktop Contacts v0.8' by Savas Geivanidis (aki@egnatia.ee.auth.gr)" & vbLf & vbLf & "Major layout and performance improvements myT in 'vCard Exporter v1.0' - http://myTselection.blogpsot.com", vbInformation + vbOKOnly + vbMsgBoxSetForeground, "vCard Exporter: data exported")

    Else

        popup = MsgBox(nod - 2 & " contacts were exported to:" & vbLf & "'" & vcardname & "'" & vbLf & vbLf & "Please send this file to your phone and run it in order to add these contacts into it." & vbLf & vbLf & "Original development 'Desktop Contacts v0.8' by Savas Geivanidis (aki@egnatia.ee.auth.gr)" & vbLf & vbLf & "Major layout and performance improvements myT in 'vCard Exporter v1.0' - http://myTselection.blogpsot.com"", vbInformation + vbOKOnly + vbMsgBoxSetForeground, "vCard Exporter: data exported")

    End If

    Application.DisplayStatusBar = True

End Sub

'*********************** 
  
'* This function calculates hours, minutes

'* and seconds based on how many seconds

'* are passed in and returns a nice format

Public Function PrintHrMinSec(elap)

  Dim hr

  Dim min

  Dim sec

  Dim remainder

  
  elap = Int(elap) 'Just use the INTeger portion of the variable

  
  'Using "\" returns just the integer portion of a quotient

  hr = elap \ 3600 '1 hour = 3600 seconds

  remainder = elap - hr * 3600

  min = remainder \ 60

  remainder = remainder - min * 60

  sec = remainder

  
  'Prepend leading zeroes if necessary

  If Len(sec) = 1 Then sec = "0" & sec

  If Len(min) = 1 Then min = "0" & min

  
  'Only show the Hours field if it's non-zero

  If hr = 0 Then

     PrintHrMinSec = min & ":" & sec

  Else

     PrintHrMinSec = hr & ":" & min & ":" & sec

  End If

  
End Function

My Excel macro selection

Some easy to use Excel macro’s. All explained below are available in one Excel Macro Example.

All macro’s are combined in one example Excel sheet template to test the usage of it.

Password Generation

Function RndPassword(vLength)
	'This function will generate a random strong password of variable
	'length.
	'This script is provided under the Creative Commons license located
	'at http://creativecommons.org/licenses/by-nc/2.5/ . It may not
	'be used for commercial purposes with out the expressed written consent
	'of NateRice.com

	For x = 1 To vLength
		Randomize
		vChar = Int(89 * Rnd) + 33
		If vChar = 34 Then 'this is quote character, replace it with a single quote
			vChar = 39
		End If
		RndPassword = RndPassword & Chr(vChar)
	Next
End Function

An example usage of this Password generation function: I have a list with on each row a button to generate a password in the cell next to the button. Each button is linked to the same macro (for easy copy paste of the row). The cell to fill with the new password is automatically detected based on the cell in which the button is drawn. Before setting the new generated password, a warning is shown in a message box.

Sub Process_GenNewPassword()
    Dim LRange As String
    Dim RowOffset As Integer
    Dim ColumnOffset As Integer
    Dim newGenPassword As String
    'Find cell that button resides in
    LName = Application.Caller
    Set bBox = ActiveSheet.Buttons(LName)
    LRange = bBox.TopLeftCell.Address
    RowOffset = 0    ' relative location of the row in which to work, same row used
    FirstNameColumnOffset = -5 ' relative location of firstname column in row to show in warning message box
    LastNameColumnOffset = -4 ' relative location of lastname column in row to show in warning message box
    PasswordColumnOffset = 2 ' relative location of column in row where the generated password should be set
    sResult = MsgBox("The password for user '" & Range(LRange).Offset(RowOffset, FirstNameColumnOffset).Value & " " & Range(LRange).Offset(RowOffset, LastNameColumnOffset).Value & "' will be replaced with a new random password!", vbExclamation + vbOKCancel, "New password generation")
    If (sResult <> 1) Then
        Exit Sub
    End If	
    newGenPassword = RndPassword(10)
    Range(LRange).Offset(RowOffset, PasswordColumnOffset).Value = newGenPassword
End Sub

Checkboxes

Checkbox LinkedCell

Whenever you need many checkboxes in your sheet, you'll probably need each checkbox to be linked to the cell it is residing on.




When copy-pasting rows or columns, the checkboxes will be copied as well, but they will still be linked to the same cell as the checkbox you started to copy-paste. The little macro shown below, will update each Checkbox on the active sheet and set it's linked cell to the cell on which the Checkbox is drawn.

Sub setCheckBoxLinkedCell()
	'Loop through all Checkboxes in the active sheet
	'Set for each Checkbox it's "LinkedCell" value to the cell on which the Checkbox is drawn
	Application.ScreenUpdating = False
	' turns off screen updating
	Application.DisplayStatusBar = True
	' makes sure that the statusbar is visible
	Application.StatusBar = "Updating linked cells of all Checkboxes in this sheet."
	For Each chk In ActiveSheet.Checkboxes
		LRow = ActiveSheet.Checkboxes(chk.Name).TopLeftCell.Row
		LColumn = ActiveSheet.Checkboxes(chk.Name).TopLeftCell.Column
		cA1 = Application.ConvertFormula("R" & LRow & "C" & LColumn, xlR1C1, xlA1)

		ActiveSheet.Shapes.Range(Array(chk.Name)).Select
		With Selection
			.Value = xlOff
			.LinkedCell = cA1
			.Display3DShading = False
		End With
	Next chk
	Application.StatusBar = "Linked cells of all Checkboxes in this sheet are updated."
	Application.ScreenUpdating = True
End Sub

Save date on Checkbox check

The macro below will set the date in the cell next to the Checkbox whenever the checkbox is checked. All checkboxes are linked to the same macro, for easy copy-pasting. The cell in which to save the date will be detected based on the checkbox location.

Sub Process_CheckBox()
    Dim cBox As CheckBox
    Dim LRow As Integer
    Dim LRange As String

    LName = Application.Caller
    Set cBox = ActiveSheet.Checkboxes(LName)

    'Find address that checkbox resides in
    LRange = cBox.TopLeftCell.Address
    DateRowOffset = 0 ' row offset (relative to the checkbox location) in which the date should be set
    DateColumnOffset = 1 ' column offset (relative to the checkbox location) in which the date should be set
    
    'Change date if checkbox is checked
    If cBox.Value > 0 Then
        Range(LRange).Offset(DateRowOffset, DateColumnOffset).Value = Date

    'Clear date if checkbox is unchecked
    Else
        Range(LRange).Offset(DateRowOffset, DateColumnOffset).Value = Null
    End If
End Sub

Create Folder Structure

I copied my previously explained 'Create Folder Structure' in this Excel Macros Example. For all details, see my previous blog post. An import of an existing system folder structure is now added in there as well.

Run macro upon opening a workbook

To run a macro whenever the workbook Excel sheet is opened, the Sub Workbook_Open in 'ThisWorkbook' can be used. This is needed if you want to link some keyboard keys to specific macro's.

Link keys to macro

To link a keyboard key to a specific macro action, the Application.OnKey "..." can be used in the auto startup macro. The keys must be unlinked before closing the workbook. I used this functionality in my Exam Point Counter workbook, described in this previous blog post. In 'ThisWorkbook':

'startup macro
Private Sub Workbook_Open()
    Application.OnKey "t", "tKeyPressed"
    Application.OnKey "e", "eKeyPressed"
    Application.OnKey "s", "sKeyPressed"
    Application.OnKey "t", "tKeyPressed"
End Sub
Private Sub Workbook_BeforeClose()
    Application.OnKey "t"
    Application.OnKey "e"
    Application.OnKey "s"
    Application.OnKey "t"
End Sub

In any module, for example KeyboardAction:

Sub tKeyPressed()
    Application.DisplayStatusBar = True
    Application.StatusBar = "t key linked to special action in KeyboardAction module"
End Sub
Sub eKeyPressed()
    Application.DisplayStatusBar = True
    Application.StatusBar = "e key linked to special action in KeyboardAction module"
End Sub
Sub sKeyPressed()
    Application.DisplayStatusBar = True
    Application.StatusBar = "s key linked to special action in KeyboardAction module"
End Sub

Search Lookup

The search lookup functionality has also been described in details in this previous blog post. The macro is included in this Excel Macro Example as well.

The formula for E9 below looks like:

 

Open Save

A button with linked macro to navigate to a folder is shown in the module 'OpenSave'.








A basic example of the resource exporter I showed in a previous post, is included as well. It will export the example data set into a text file, and while doing so, all special characters will be converted (eg &#233). For rows in the list of AlternativeEncoding, an alternative encoding for special characters will be used (eg \u00E9). To make the sheet readable, the special characters can be converted back into readable special characters. The conversion is based on a hex2ascii converter, unicode encoding, html encoding and decoding.

When you would reuse this code, please note, in order to support FileSystemObject, you’ll need to add reference to Microsoft scripting runtime in your Excel workbook VBA. In order to do so, open the Visual Basic environment in Excel (ALT+F11) > Menu ‘Tools’ > ‘Reference’ > Enable ‘Microsoft Scripting Runtime’. If this isn’t done in the workbook, the error ‘User defined type not defined’ will appear when writing an export file on ‘Dim fso As New FileSystemObject’.

When the special characters are encoded using the macro, they will look like this:

PhoneBook vCard export

A sheet in which all phonebook data can be added (can be exported from any other application) is now available. Once all contact information is set, it can be exported into a vCard format which is supported by many address and contact management applications. More details can be found in this specific blog post.

All code is available in the Excel Macro Example.

Personal expense sheet

With the formula I presented in my previous blogpost on Excel look-ups I created an Excel sheet to monitor my personal expenses.
It is based on the data I extract from my different online banking systems (currently for the Belgian banks Argenta, Landbouwkrediet and KBC).

In the 'Categories' sheet, different keywords linked to the category name need to be filled in, this could be the name of a company or the account number. The keyword will be looked up in the account and comment of each transaction. And this will make it possible to automatically categorize each bank transaction and automate some analysis/summary overview on the transactions.

Every now and then, I copy the data from the online banking system into the 'data' Excel sheets. All expenses are categorized automatically with my formula in the column 'Auto Type', but if some exceptional category needs to be assigned, a 'Manual Type' column can be set to override the 'Auto Type'. Based on these categories, I created some sheets with an summary overview for each month and some averages per month and per year. This way, I can get a clean overview on our expenses and incomes and keep a copy of our banking data offline as well (since many banks only keep last 2 years online).

Based on my personal sheet I created this empty (dutch) template sheet, but it will still need some custom changes to be usable for someone else. But it could be a nice starting point.

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.