Hi
The declarations section here and the first two subs can be used to
connect & disconnect with Outlook from Excel which you will be able to
use as is.
The last sub I use to create a Contacts folder from information in
excel (i.e. Excel TO Outlook). It takes information from four columns
starting from A1 (and assumes first row is headers). You should be
able to reverse the write bit
i.e. With objStudent
.LastName = MailInfo(i + 1, 1)
.FirstName = MailInfo(i + 1, 2)
.Email1Address = MailInfo(i + 1, 3)
.BusinessAddress = MailInfo(i + 1, 4)
.Save
End With
to go from Outlook to Excel by reading the info from objFolder =
objNamespace.GetDefaultFolder(olFolderContacts)
regards
Paul
***CODE****
Option Explicit
Option Base 1
Public objOutlook As Outlook.Application
Public objNamespace As Outlook.Namespace
Public OutlookWasRunning As Boolean
'Interface with Outlook objects required will be through this sub.
'It is called by any sub requiring access to Outlook.
Public Sub DeclareOutlookObjects()
Application.ScreenUpdating = False
On Error Resume Next
Err.Clear
Set objOutlook = GetObject(, "Outlook.Application") 'If
Outlook is already open, flag it with Boolean
If Err.Number <> 0 Then OutlookWasRunning = False Else
OutlookWasRunning = True
On Error GoTo 0
Err.Clear 'keep err tidy
If Not OutlookWasRunning Then
Set objOutlook = CreateObject("Outlook.Application") 'fresh
version of Outlook
End If
Set objNamespace = objOutlook.GetNamespace("MAPI")
objNamespace.Logon
End Sub
'Releases Public variable objects after Outlook session
Public Sub ReleaseOutlookObjects()
Application.ScreenUpdating = False
objNamespace.Logoff
Set objNamespace = Nothing
If Not OutlookWasRunning Then objOutlook.Quit
Set objOutlook = Nothing
End Sub
Public Sub MakeContactsFolders()
Dim EmailFolderName As String
Dim objFolder As MAPIFolder, objNewFolder As MAPIFolder, objStudent As
Outlook.ContactItem
Dim Delegates As Long, i As Long
Dim MailInfo As Variant
Application.ScreenUpdating = False
EmailFolderName = InputBox("What is the email folder name?", "Make
an Outlook Contacts Folder")
If EmailFolderName = "" Then Exit Sub
DeclareOutlookObjects
'DeclareOutlookObjects() already run to Connect up to Outlook and
creates objNameSpace
'create a new contacts folder in the Contacts Folders, if that
exists
'need to delete it first if it already exists
Set objFolder = objNamespace.GetDefaultFolder(olFolderContacts)
On Error Resume Next 'see if "My Contacts" exists
Set objNewFolder = objFolder.Folders(EmailFolderName)
On Error GoTo 0
'If folder already exists, it is last years so delete it
If Not objNewFolder Is Nothing Then objNewFolder.Delete
Set objNewFolder = objFolder.Folders.Add(EmailFolderName,
olFolderContacts)
'get the contact info
MailInfo = ActiveSheet.Range("A1").CurrentRegion.Value
Delegates = UBound(MailInfo, 1) - 1 'not header
'Add the contact info to the created folder
For i = 1 To Delegates 'all attendees
Set objStudent = objNewFolder.Items.Add(olContactItem)
With objStudent
.LastName = MailInfo(i + 1, 1)
.FirstName = MailInfo(i + 1, 2)
.Email1Address = MailInfo(i + 1, 3)
.BusinessAddress = MailInfo(i + 1, 4)
.Save
End With
Next i
objNewFolder.ShowAsOutlookAB = True 'see it in address book
If objNewFolder.Items.Count = 0 Then objNewFolder.Delete
'not required if empty
MsgBox "Your email folder is a subfolder of your Contacts Folder",
vbOKOnly
Set objStudent = Nothing
Set objNewFolder = Nothing 'GroupContacts
Set objFolder = Nothing 'contacts folder
ReleaseOutlookObjects 'disconnect from Outlook
End Sub
