Import File To Outlook From Excel With Mapping

Hi

Some time ago, I found a macro on the web that would import a file from Excel into Outlook. The macro included "mapping code" such that you could map Excel columns to Outlook fields. I had a system crash and lost that code. I believe it ran from Outlook and not Excel.

Do any of you have an idea if that type of code is available?

John

I don't know of any general purpose code but if you post a description of what you are trying to achieve someone may have an answer for you.

Hi tony h

I recently found this code at http://www.codeforexcelandoutlook.co...ba-automation/

It does what I want but it writes the contacts to the default Contacts file. I'd like to do one of two things:

Modify the code to add a Contacts file from user input, create the file and then write the records to that file, or

Simply specify in the code the file name that the contacts are to be written to.

Option Explicit
Dim bWeStartedOutlook As Boolean
Sub test()
Dim success As Boolean
success = CreateContactsFromList
End Sub
Function CreateContactsFromList() As Boolean
' creates contacts in bulk from Excel worksheet
' Col A: First Name
' Col B: Last Name
' Col C: Email Address
' Col D: Company Name
' Col E: Business Telephone
' Col F: Business Fax
' Col G: Home Phone
' Row 1 should be a header row
On Error GoTo ErrorHandler
Dim lNumRows As Long
Dim lNumCols As Long
Dim lCount As Long
Dim varContactInfo As Variant
Dim olContact As Object ' Outlook.ContactItem
Dim strCurrentFirstName As String
Dim strCurrentLastName As String
Dim strCurrentEmailAddr As String
Dim strCurrentCompany As String
Dim strCurrentBusinessPhone As String
Dim strCurrentBusinessFax As String
Dim strCurrentHomePhone As String
' figure out how big our array needs to be, and size appropriately
lNumRows = Sheet6.Range(Range("A2"), Range("A" & Rows.Count).End(xlUp)).Count
lNumCols = Sheet6.Range(Range("A1"), Range("IV1").End(xlToLeft)).Count
ReDim varContactInfo(1 To lNumRows, 1 To lNumCols)
varContactInfo = Range(Cells(2, 1), Cells(lNumRows + 1, lNumCols))
' get Outlook
Dim olApp As Object ' Outlook.Application
Set olApp = GetOutlookApp
lCount = 1
Do Until lCount = lNumRows
  ' assign variant values to intermediate string varbs
  strCurrentFirstName = varContactInfo(lCount, 1)
  strCurrentLastName = varContactInfo(lCount, 2)
  strCurrentEmailAddr = varContactInfo(lCount, 3)
  strCurrentCompany = varContactInfo(lCount, 4)
  strCurrentBusinessPhone = varContactInfo(lCount, 5)
  strCurrentBusinessFax = varContactInfo(lCount, 6)
  strCurrentHomePhone = varContactInfo(lCount, 7)
 
  ' CreateItem will create a contact in the default folder
  Set olContact = olApp.CreateItem(2) ' olContactItem
  With olContact
    .FirstName = strCurrentFirstName
    .LastName = strCurrentLastName
    .Email1Address = strCurrentEmailAddr
    .CompanyName = strCurrentCompany
    .BusinessTelephoneNumber = strCurrentBusinessPhone
    .BusinessFaxNumber = strCurrentBusinessFax
    .HomeTelephoneNumber = strCurrentHomePhone
  End With
  olContact.Close olSave
 
  lCount = lCount + 1
Loop
' if we got this far, assume success
CreateContactsFromList = True
GoTo ExitProc
ErrorHandler:
CreateContactsFromList = False
ExitProc:
Set olContact = Nothing
If bWeStartedOutlook Then
  olApp.Quit
End If
Set olApp = Nothing
End Function
Function GetOutlookApp() As Object
On Error Resume Next
  Set GetOutlookApp = GetObject(, "Outlook.Application")
  If Err.Number <> 0 Then
    Set GetOutlookApp = CreateObject("Outlook.Application")
    bWeStartedOutlook = True
  End If
On Error GoTo 0
End Function

I also found this code at http://forums.techguy.org/business-a...nto-new-2.html

Same questions regarding modification.

'Option Explicit
Dim appOutlook As Outlook.Application
Dim objNameSpace As Outlook.Namespace
Dim objContactFolder As Outlook.MAPIFolder
Dim objContacts As Outlook.ContactItem
Dim myDistList As Outlook.DistListItem
Sub DistList()
 
Set appOutlook = GetObject(, "Outlook.Application")
Set objNameSpace = appOutlook.GetNamespace("MAPI")
Set objContactFolder = objNameSpace.GetDefaultFolder(olFolderContacts)
Set myMailItem = appOutlook.CreateItem(olMailItem)
Set myRecipients = myMailItem.Recipients
Set myDistList = appOutlook.CreateItem(olDistributionListItem)
For i = 2 To Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Set objContacts = objContactFolder.Items.Add(olContactItem)
With objContacts
    If Not Range("I" & i) = "" Then
'    .CompanyName = Range("B" & i).Value
    .LastName = Range("C" & i).Value
    .FirstName = Range("B" & i).Value
    .HomeAddressStreet = Range("D" & i).Value
    .HomeAddressCity = Range("E" & i).Value
    .HomeAddressState = Range("F" & i).Value
    .HomeAddressPostalCode = Range("G" & i).Value
'    .BusinessAddressCountry = Range("I" & i).Value
    .JobTitle = Range("J" & i).Value
    .HomeTelephoneNumber = Range("H" & i).Value
'    .BusinessFaxNumber = Range("L" & i).Value
    .Email1Address = Range("I" & i).Value
    .Body = Range("N" & i).Value
    .Save
 
    End If
End With
 
    myRecipients.Add (Range("I" & i).Value)
 
 
   Next
 
   myRecipients.ResolveAll
   myDistList.AddMembers myRecipients
   myDistList.Display
 
End Sub

Any ideas?

John

Hi darbid and tony h

Thanks forr your input. I've spent MANY hours on this project and have finally resolved it to what I want to do. The code creates an Outlook contacts file from an Excel data file then manipulates the Outlook contacts file such that it uploads the file into a named contacts file in Outlook and creats a distribution list in the named contacts file for those contacts that have an Email address. It also provides for up to two Email addresses for each contact (I suppose this could be expanded).

I'm including the code in the event others may have similar issues

Option Explicit
Sub OutlookContacts()
    Dim Arr As Variant
    Dim i As Integer
    Dim rng As Range
    Dim fCell As Range
    Dim LR As Long
    Sheets("OutlookContacts").Activate
    Sheets("OutlookContacts").Cells.ClearContents
    Sheets("Sheet2").Columns("A:N").Copy Destination:=Sheets("OutlookContacts").Range("A1")
    With Sheets("OutlookContacts")
        LR = .Range("B" & .Rows.Count).End(xlUp).Row
        .Range("A" & LR & ":A" & LR + 4).EntireRow.Delete
        .Columns("D:D").EntireColumn.Delete
        LR = .Range("A" & .Rows.Count).End(xlUp).Row
        .Columns("F:G").EntireColumn.Insert
        .Range("E1").Value = "City"
        .Range("F1").Value = "State"
        .Range("G1").Value = "Zip"
        .Columns("G:G").NumberFormat = "@"
        Set rng = .Range("E2:E" & LR)
        With rng
            For Each fCell In rng
                Arr = Split(fCell.Value, "  ")
                For i = LBound(Arr) To UBound(Arr)
                    fCell.Offset(0, i) = LTrim(Arr(i))
                Next i
            Next fCell
        End With
    End With
    Call CreateEmailRows
    Call DistList
End Sub
 
 
Public Sub CreateEmailRows()
    Dim rng As Range
    Dim LR As Long
    Dim Ctr As Long
    LR = Range("A" & Rows.Count).End(xlUp).Row
    Set rng = ActiveSheet.Range("J2:J" & LR)
    For Ctr = LR To 2 Step -1
        If Not Range("J" & Ctr).Value = "" Then
            Range("J" & Ctr + 1).EntireRow.Insert
            Range("J" & Ctr).EntireRow.Copy Destination:=Range("J" & Ctr).Offset(1, -9)
            Range("J" & Ctr).Select
            Range("J" & Ctr).Offset(1, -1).Value = Range("J" & Ctr).Value
            Range("J" & Ctr).ClearContents
            Range("J" & Ctr).Offset(1, 0).ClearContents
            Range("J" & Ctr).Offset(0, -7).Value = Range("J" & Ctr).Offset(0, -7).Value & " (1)"
            Range("J" & Ctr).Offset(1, -7).Value = Range("J" & Ctr).Offset(1, -7).Value & " (2)"
        End If
    Next Ctr
End Sub

'Option Explicit
Dim appOutlook As Outlook.Application
Dim objNameSpace As Outlook.Namespace
Dim objContactFolder As Outlook.MAPIFolder
Dim myDistList As Outlook.DistListItem
Dim myMailItem As Outlook.MailItem
Dim olFolder As Object
Dim myContacts As Outlook.Folder
Dim myFolder As Outlook.MAPIFolder
Sub DistList()
    Call OpenOutlook
    Set appOutlook = New Outlook.Application
    Set objNameSpace = appOutlook.GetNamespace("MAPI")
    Set objContactFolder = objNameSpace.GetDefaultFolder(olFolderContacts)
    Set myMailItem = appOutlook.CreateItem(olMailItem)
    Set myRecipients = myMailItem.Recipients
    Set myDistList = appOutlook.CreateItem(olDistributionListItem)
    Sheet6.Activate
    Set myFolder = objNameSpace.GetDefaultFolder(olFolderContacts)
    On Error Resume Next
    Set myFolder = myFolder.Folders("Glens Residents")
    myFolder.Delete
    On Error GoTo 0
    Set myFolder = objNameSpace.GetDefaultFolder(olFolderContacts)
    Set objNameSpace = appOutlook.GetNamespace("MAPI")
    Set olFolder = objNameSpace.GetDefaultFolder(olFolderContacts)
    olFolder.Folders.Add ("Glens Residents")
    Set olFolder = myFolder.Folders("Glens Residents")
    olFolder.ShowAsOutlookAB = True
    Set olContacts = olFolder.Items.Add
    For i = 2 To Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        Set olContacts = olFolder.Items.Add
        With olContacts
            .CompanyName = Range("A" & i).Value
            .LastName = Range("C" & i).Value
            .FirstName = Range("B" & i).Value
            .HomeAddressStreet = Range("K" & i).Value
            .HomeAddressCity = Range("L" & i).Value
            .HomeAddressState = Range("M" & i).Value
            .HomeAddressPostalCode = Range("N" & i).Value
            .Email2Address = Range("J" & i).Value
            .BusinessTelephoneNumber = Range("O" & i).Value
            .Email1Address = Range("I" & i).Value
            .OtherAddressStreet = Range("D" & i).Value
            .OtherAddressCity = Range("E" & i).Value
            .OtherAddressState = Range("F" & i).Value
            .OtherAddressPostalCode = Range("G" & i).Value
            .OtherTelephoneNumber = Range("H" & i).Value
            .Save
        End With
        If Not Range("I" & i).Value = "" Then
            myRecipients.Add olContacts.FullName
        End If
    Next
    Call ChangeEmailDisplayName
    myRecipients.ResolveAll
    myDistList.AddMembers myRecipients
    myDistList.DLName = "Glens Residents EMail List"
    myDistList.Save
'        'Used for debugging only
'        For j = 1 To myDistList.MemberCount
'        Next j
'        MsgBox "Count is " & myDistList.MemberCount
    Call MoveItems
End Sub
 
 
Sub OpenOutlook()
    Dim ol As Outlook.Application
    Dim olNameSpace As Outlook.Namespace
    Dim olContacts As Outlook.MAPIFolder
    'Error 429 occurs with GetObject if Outlook is not running.
    On Error Resume Next
    Set objOutlook = GetObject(, "Outlook.Application")
    If Err.Number = 429 Then    'Outlook is NOT running.
        Shell ("Outlook")
    Else
        AppActivate objOutlook.ActiveExplorer.Caption
    End If
    Set olNameSpace = ol.GetNamespace("MAPI")
    Set olContacts = olNameSpace.GetDefaultFolder(olFolderContacts)
    olContacts.Display
End Sub
 
 
Sub MoveItems()
    Dim myNameSpace As Outlook.Namespace
    Dim myContacts As Outlook.MAPIFolder
    Dim myDestFolder As Outlook.MAPIFolder
    Dim myItems As Outlook.Items
    Dim myItem As Object
    Set myNameSpace = appOutlook.GetNamespace("MAPI")
    Set myContacts = myNameSpace.GetDefaultFolder(olFolderContacts)
    Set myItems = myContacts.Items
    Set myDestFolder = myContacts.Folders(olFolder.Name)
    Set myItem = myItems.Find("[name] = 'Glens Residents EMail List'")
    While TypeName(myItem) <> "Nothing"
        myItem.Move myDestFolder
        Set myItem = myItems.FindNext
    Wend
End Sub
 
 
Public Sub ChangeEmailDisplayName()
    Dim objOL As Outlook.Application
    Dim objNS As Outlook.Namespace
    Dim objContact As Outlook.ContactItem
    Dim objItems As Outlook.Items
    Dim objContactsFolder As Outlook.MAPIFolder
    Dim obj As Object
    Dim strFileAs As String
    On Error Resume Next
    Set objOL = CreateObject("Outlook.Application")
    Set objNS = objOL.GetNamespace("MAPI")
    Set objContactsFolder = objNS.GetDefaultFolder(olFolderContacts)
    Set objItems = objContactsFolder.Items
    Set objContactsFolder = objContactsFolder.Folders("Glens Residents")
    Set objItems = objContactsFolder.Items
    For Each obj In objItems
        'Test for contact and not distribution list
        If obj.Class = olContact Then
            Set objContact = obj
            With objContact
                'Lastname, Firstname format
                strFileAs = .LastNameAndFirstName
                .Email1DisplayName = strFileAs
                .Save
            End With
        End If
        Err.Clear
    Next
    Set objOL = Nothing
    Set objNS = Nothing
    Set obj = Nothing
    Set objContact = Nothing
    Set objItems = Nothing
    Set objContactsFolder = Nothing
End Sub

Hope this helps someone.

John