More Outlook Resource Sites

Microsoft Developer Network (MSDN)

FAQs and other general resources

share code 31-Oct-2014 03:14

Looking for help with Outlook programming projects — VSTO, add-ins, VBA, custom Outlook forms, etc.? You′ve come to the right place!

NEW! >> Subscribe to this site via RSS. For more RSS options, see the complete list of feeds on our main news page.

Login Password
Remember me
Register | Send my password
Code level: beginner    Code area: Outlook and .NET Printer Friendly Version
Title: VB .NET Import from Excel to Outlook
Description: VB .NET Console application, made with VS2008. Import contacts and birthdays (as appointments) from an Excel spreadsheet into Outlook (public) folders. Customizable. Contains two private functions that should probably be in a general library.
Date: 27-Oct-2008  14:00
Code level: beginner
Code area: Outlook and .NET
Posted by: Wilm Boerhout
This message is displayed as VB.NET
 Imports Outlook = Microsoft.Office.Interop.Outlook
Imports Excel = Microsoft.Office.Interop.Excel

''' <summary>
''' Import Outlook contacts and appointments (birthdays) from an Excel spreadsheet
''' </summary>
''' <remarks>
'''     Layout of columns in spreadsheet:
''' 1.	Organisatie-ID
''' 2.	Sorteernaam
''' 3.	Voornaam 
''' 4.	Initialen 
''' 5.	Achternaam 
''' 6.	Middelstenaam 
''' 7.	Broodjescode 
''' 8.	Telefoon op werk 
''' 9.	Mobiele telefoon 
'''10.	Telefoon thuis 
'''11.	Verjaardag 
'''12.	Huisadres, straat 
'''13.	Huisadres, postcode 
'''14.	Huisadres, plaats 
'''15.	Wpl 
'''16.	L 
'''17.	AfdelingX 
'''18.	Afdeling 
'''19.	Bedrijf 
'''20.	Functie 
'''21.	Geslacht 
'''22.	Categorieën 
'''23.	Onderwerp 
'''24.	Begindatum 
'''25.	Einddatum 
'''26.	Herinneringen aan/uit 
'''27.	Gebeurtenis, duurt hele dag 
'''28.	Tijd weergeven als 
'''29.	E-mailadres 
'''30.	Weergavenaam voor e-mail 
'''31.	Bedrijf2 
''' </remarks>
Module mImportFromExcel

    Private strID As String = "Synchronizer VB.NET 0.9 [Wilm Boerhout]"
    Private SP As String = " "

    '### USER OPTIONS ###
    Private strContactFolder As String = "Openbare Mappen\Alle Openbare Mappen\VXers\Test"
    Private strBirthdayFolder As String = "Openbare Mappen\Alle Openbare Mappen\Verjaardagen\Test"
    ' Private strWorkbook As String = "S:\Algemene Lijsten\VX Synchronizer.xls"
    ' Private strPicPath As String = "S:\Portrait Gallery\Nieuw\output\images\"
    Private strWorkbook As String = "D:\VX Synchronizer.xls"
    Private strPicPath As String = "D:\Portrait Gallery\"
    Private bTest As Boolean = True ' Exit after 10 rows
    '### END USER OPTIONS ###

    Sub Main()

        Dim myOutlook As Outlook.Application
        Dim myNameSpace As Outlook.NameSpace
        Dim myContFolder, myApptFolder As Outlook.Folder
        Dim myContacts, myAppointments As Outlook.Items
        Dim myContact As Outlook.ContactItem
        Dim myAppointment As Outlook.AppointmentItem
        Dim myRecurrPatt As Outlook.RecurrencePattern

        Dim myExcel As Excel.Application
        Dim myWorkbook As Excel.Workbook
        Dim myWorksheet As Excel.Worksheet
        Dim myRange As Excel.Range

        Dim strName, strNameUnDia, strFile1, strFile2 As String

        Dim i, j, iConts, iAppts, iRows, iPics As Integer
        Dim bWeOpenedOutlook, bWeOpenedExcel As Boolean

        Console.BackgroundColor = ConsoleColor.DarkGreen
        Console.ForegroundColor = ConsoleColor.Green
        Console.WindowWidth = 132
        Console.BufferWidth = 132
        Console.WriteLine(Now() & SP & strID)

        On Error Resume Next

        bWeOpenedExcel = False
        myExcel = GetObject(, "Excel.Application")
        If myExcel Is Nothing Then
            myExcel = CreateObject("Excel.Application")
            bWeOpenedExcel = True
        End If

        bWeOpenedOutlook = False
        myOutlook = GetObject(, "Outlook.Application")
        If myOutlook Is Nothing Then
            myOutlook = CreateObject("Outlook.Application")
            bWeOpenedOutlook = True
        End If

        myWorkbook = myExcel.Workbooks.Open(strWorkbook, , True) 'ReadOnly
        myWorksheet = myWorkbook.Worksheets(1)
        myRange = myWorksheet.UsedRange

        If bTest Then
            iRows = 10 + 1
        Else
            iRows = myRange.Rows.Count
        End If

        iConts = 0
        iAppts = 0
        iPics = 0

        ' Skip header row

        If iRows > 1 Then

            Console.WriteLine(Now() & SP & "Cleaning up...")

            myContFolder = GetFolder(strContactFolder)
            myContacts = myContFolder.Items
            j = myContacts.Count

            For i = myContacts.Count To 1 Step -1
                myContact = myContacts.Item(i)
                myContact.Delete()
            Next

            If j <> 0 Then _
            Console.WriteLine(Now() & SP & "Contacts folder emptied (" & CStr(j) & " items)")

            myApptFolder = GetFolder(strBirthdayFolder)
            myAppointments = myApptFolder.Items
            j = myAppointments.Count

            For i = myAppointments.Count To 1 Step -1
                myAppointment = myAppointments.Item(i)
                myAppointment.Delete()
            Next

            If j <> 0 Then _
            Console.WriteLine(Now() & SP & "Appointments folder emptied (" & CStr(j) & " items)")

            Console.WriteLine(Now() & SP & "Starting IMPORT operation for " & CStr(iRows - 1) & " contacts... ")

            ' skip header row
            For i = 2 To iRows

                myContact = myContFolder.Items.Add("IPM.Contact")
                Console.Write(Now() & SP & "Adding contact " & CStr(i - 1) & _
                                  " [PN=" & myRange.Cells(i, 1).Value & "," & _
                                  myRange.Cells(i, 5).Value & "]... ")

                With myContact

                    .OrganizationalIDNumber = myRange.Cells(i, 1).Value
                    .FirstName = myRange.Cells(i, 3).Value
                    .LastName = myRange.Cells(i, 5).Value
                    .MiddleName = myRange.Cells(i, 6).Value
                    .User1 = myRange.Cells(i, 7).Value 'Broodjescode
                    .BusinessTelephoneNumber = myRange.Cells(i, 8).Value
                    .MobileTelephoneNumber = myRange.Cells(i, 9).Value
                    .HomeTelephoneNumber = myRange.Cells(i, 10).Value

                    ' .Birthday = myRange.Cells(i, 11).Value  [could have done it here, but
                    ' when Appointments are added by Outlook from Contact birthdays,
                    ' we have no control over their appearance. So, not here, but below...

                    .HomeAddressStreet = myRange.Cells(i, 12).Value
                    .HomeAddressPostalCode = myRange.Cells(i, 13).Value
                    .HomeAddressCity = myRange.Cells(i, 14).Value
                    .Department = myRange.Cells(i, 18).Value
                    .CompanyName = myRange.Cells(i, 19).Value
                    .JobTitle = myRange.Cells(i, 20).Value
                    If UCase(Left(myRange.Cells(i, 21).Value, 1)) = "V" Or _
                        UCase(Left(myRange.Cells(i, 21).Value, 1)) = "F" Then
                        .Gender = Outlook.OlGender.olFemale
                    ElseIf UCase(Left(myRange.Cells(i, 21).Value, 1)) = "M" Then
                        .Gender = Outlook.OlGender.olMale
                    Else
                        .Gender = Outlook.OlGender.olUnspecified
                    End If
                    .Categories = myRange.Cells(i, 22).Value
                    .Email1Address = myRange.Cells(i, 29).Value
                    .Email1AddressType = "SMTP"
                    .Email1DisplayName = myRange.Cells(i, 30).Value

                    ' Add picture, from Portrait Gallery

                    If .MiddleName = "" Then
                        strName = .FirstName & SP & .LastName
                        strNameUnDia = UnDia(.FirstName & SP & .LastName)
                    Else
                        strName = .FirstName & SP & .MiddleName & SP & .LastName
                        strNameUnDia = UnDia(.FirstName & SP & .MiddleName & SP & .LastName)
                    End If

                    ' We have not ruled out persons with same name 
                    ' They (well, he) get special treatment:

                    If strName = "Marcel Meijer" Then
                        If .User1 = "MMei" Then
                            strName = "Marcel H Meijer"
                            strNameUnDia = "Marcel H Meijer"
                        End If
                    End If

                    strFile1 = strPicPath & strNameUnDia & ".jpg"
                    strFile2 = strPicPath & strNameUnDia & ".JPG"

                    If My.Computer.FileSystem.FileExists(strFile1) Then
                        iPics = iPics + 1
                        .AddPicture(strFile1)
                    ElseIf My.Computer.FileSystem.FileExists(strFile2) Then
                        iPics = iPics + 1
                        .AddPicture(strFile2)
                    End If

                    .Save()
                    If Err.Number = 0 Then
                        iConts = iConts + 1
                    Else
                        Err.Clear()
                    End If
                End With
                Console.Write("saved, ")

                ' Birthdays as recurring appointments:

                myAppointment = myApptFolder.Items.Add("IPM.Appointment")
                Console.Write("adding birthday... ")

                With myAppointment

                    .Categories = myRange.Cells(i, 22).Value
                    .Subject = myRange.Cells(i, 23).Value
                    .ReminderSet = False
                    .AllDayEvent = True
                    .BusyStatus = Outlook.OlBusyStatus.olFree

                    myRecurrPatt = .GetRecurrencePattern
                    With myRecurrPatt
                        .RecurrenceType = Outlook.OlRecurrenceType.olRecursYearly
                        .PatternStartDate = myRange.Cells(i, 11).Value 'Birthday
                        .DayOfMonth = DatePart(DateInterval.Day, myRange.Cells(i, 11).Value)
                        .MonthOfYear = DatePart(DateInterval.Month, myRange.Cells(i, 11).Value)
                    End With

                    .Save()
                    If Err.Number = 0 Then
                        iAppts = iAppts + 1
                    Else
                        Err.Clear()
                    End If
                End With
                Console.WriteLine("saved.")
            Next
        End If

        myWorkbook.Close(False)
        If bWeOpenedExcel Then myExcel.Quit()
        If bWeOpenedOutlook Then myOutlook.Quit()

        Console.WriteLine(vbCrLf & _
                "----------------------------------------" & vbCrLf & _
                "Contacts imported/saved: " & CStr(iConts) & vbCrLf & _
                "Appointments imported/saved: " & CStr(iAppts) & vbCrLf & _
                "Pictures added: " & CStr(iPics) & vbCrLf & _
                "----------------------------------------" & vbCrLf)

        myExcel = Nothing
        myWorkbook = Nothing
        myWorksheet = Nothing
        myRange = Nothing

        myOutlook = Nothing
        myNameSpace = Nothing
        myContact = Nothing
        myContacts = Nothing
        myAppointment = Nothing
        myAppointments = Nothing
        myContFolder = Nothing
        myApptFolder = Nothing
        myRecurrPatt = Nothing

        Console.WriteLine(Now() & SP & "Finished.")

    End Sub ' Breakpoint to keep console window open
    ''' <summary>Convert string folder path to folder object</summary>
    ''' <param name="strFolderPath">
    ''' A slash or backslash-delimited string containing an Exchange server folder path
    ''' </param>
    ''' <returns>Folder object pointing to the specified folder</returns>
    ''' <remarks>
    ''' strFolderPath needs to be something like
    ''' "Public Folders\All Public Folders\Company\Sales" or
    ''' "Personal Folders\Inbox\My Folder"
    ''' </remarks>
    Private Function GetFolder(ByVal strFolderPath As String) As Outlook.Folder

        Dim myNamespace As Outlook.NameSpace
        Dim someFolders As Outlook.Folders
        Dim myFolder As Outlook.Folder

        Dim arrFolders() As String
        Dim i As Integer
        On Error Resume Next

        myNamespace = GetObject("", "Outlook.Application").GetNamespace("MAPI")

        arrFolders = Split(Replace(strFolderPath, "/", "\"), "\")

        myFolder = myNamespace.Folders.Item(arrFolders(0))

        If Not myFolder Is Nothing Then

            For i = 1 To UBound(arrFolders)

                someFolders = myFolder.Folders
                myFolder = Nothing
                myFolder = someFolders.Item(arrFolders(i))

                If myFolder Is Nothing Then
                    Exit For
                End If
            Next
        End If

        GetFolder = myFolder

        someFolders = Nothing
        myFolder = Nothing
        myNamespace = Nothing

    End Function

    ''' <summary>Convert string with diacriticals to string without</summary>
    ''' <param name="StrIn">String with possible diacritical marks</param>
    ''' <returns>Same string, with letters replaced from collection (see below)</returns>
    ''' <remarks>
    ''' This function may be used in Excel or Access, or in any VB/VBA project.
    ''' Function evaluates an ANSI string that may have special characters, identified
    ''' in the collection populated below.  If a special character is found, the function
    ''' replaces that character with a designated replacement string (may be any number
    ''' of characters).
    ''' There is limited support for Unicode, in that you have to use ChrW and find the 
    ''' code from CHARMAP yourself.
    ''' 
    ''' The function conserves case, so if the special character is uppercase, then the
    ''' first character of the replacement string will be uppercase as well.
    ''' While the intent of this function is to "replace" characters with diacritical
    ''' marks with their Roman alphabet equivalents (you should feel free to change the
    ''' mapping below if you do not think it's right or it does not suit your purposes;
    ''' I am no linguist).  However, you could use the code to replace any single ANSI
    ''' character with whatever string you desire.    
    ''' </remarks>
    Private Function UnDia(ByVal strIn As String) As String

        Dim i As Integer
        Static coll As Collection
        Dim strCheck, strLetter As String
        Dim bWasLower As Boolean

        ' See if the collection exists.  The collection is set up as a static variable, so
        ' that it will persist between function calls; that will save a few cycles on later
        ' function calls as there will be no need to create and populate the collection again.
        ' There wil be no "Set coll = Nothing" to release the object variable, though; we
        ' will rely on VBA to clean up the collection object for us when the user exits the
        ' application

        UnDia = Nothing

        If coll Is Nothing Then

            coll = New Collection

            ' Populate a Collection with the mapping.
            ' The Key is the special character, and the Item is the replacement.
            ' The key must always be a single character, but the item may be 1+ characters.
            ' Use lower case in this list, and continue the list as needed.

            coll.Add(Item:="a", Key:="á")
            coll.Add(Item:="a", Key:="à")
            coll.Add(Item:="a", Key:="â")
            coll.Add(Item:="a", Key:="ã")
            coll.Add(Item:="a", Key:="å")
            coll.Add(Item:="a", Key:="ä")
            coll.Add(Item:="ae", Key:="æ")
            coll.Add(Item:="c", Key:="ç")
            coll.Add(Item:="c", Key:=ChrW(&H107)) 'c with accent aigu
            coll.Add(Item:="e", Key:="è")
            coll.Add(Item:="e", Key:="é")
            coll.Add(Item:="e", Key:="ê")
            coll.Add(Item:="e", Key:="ë")
            coll.Add(Item:="i", Key:="ì")
            coll.Add(Item:="i", Key:="í")
            coll.Add(Item:="i", Key:="î")
            coll.Add(Item:="i", Key:="ï")
            coll.Add(Item:="n", Key:="ñ")
            coll.Add(Item:="o", Key:="ó")
            coll.Add(Item:="o", Key:="ô")
            coll.Add(Item:="o", Key:="ò")
            coll.Add(Item:="o", Key:="õ")
            coll.Add(Item:="o", Key:="ö")
            coll.Add(Item:="o", Key:="ø")
            coll.Add(Item:="oe", Key:="œ")
            coll.Add(Item:="ss", Key:="ß") ' German sharp s
            coll.Add(Item:="th", Key:="ð") ' Old English eth
            coll.Add(Item:="th", Key:="þ") ' Old English thorn
            coll.Add(Item:="u", Key:="ù")
            coll.Add(Item:="u", Key:="ú")
            coll.Add(Item:="u", Key:="û")
            coll.Add(Item:="u", Key:="ü")
            coll.Add(Item:="y", Key:="ý")
            coll.Add(Item:="y", Key:="ÿ")
        End If

        ' Loop through string to look for special characters needing replacement

        For i = 1 To Len(strIn)

            ' Look in collection to see if the current character being considered 
            ' is a "special" character

            On Error Resume Next
            strLetter = Mid(strIn, i, 1)
            strCheck = coll(strLetter)

            ' Check to see if original character was upper or lower case

            bWasLower = (StrComp(strLetter, LCase(strLetter), vbBinaryCompare) = 0)

            ' If there was no error, that means character was in collection and thus is a
            ' special character needing replacement

            If Err.Number <> 0 Then
                Err.Clear()
                strCheck = strLetter
            End If
            On Error GoTo 0

            ' If character was lower case, return the translation in lower case.
            ' If upper case, return in proper case (first character capitalized)

            UnDia = UnDia & IIf(bWasLower, LCase(strCheck), StrConv(strCheck, vbProperCase))
        Next

    End Function
End Module
All 0comments