Is there a way to link MS Outlook with Access? 1

[Lucylucy]

I am interested in somehow linking MS Outlook with Access if possible. I want to create froms that would automaticaly send emails in Access just like it is done in Outlook by creating groups. Does anyone know if there is such a thing?

Please help! Thanks in advance!

 

[scking]

If you create it it will be so. There are many ways to integrate MSOutlook to Access.

1) You can link the portfolios from Outlook to be tables in Access. Your inbox for instance.
2) You can use SendObject which will use your default mail client (Probably Outlook) to send mail.
3) You can use COM by referencing Outlook and writing code for automation.
4) You can design tables to have group information, another table to have individual emails, and a link table to link the users to each group. Then use the SendObject to send emails.

I strongly prefer not to have to reenter EMail names of individuals that are already in the users Outlook system. Try to either use link tables, or even automation to get certain groups or emails for combo boxes or whatever. I can also use journaling, calendars, etc. from Outlook from within Access.

Here's a little sample to work with.

Public Function xSendEMail()

On Error GoTo HandleErr

Dim db As Database
'Dim rst As Recordset
Dim lst As ListBox
Dim rstVersions As Recordset
Dim strSendMsg As String
Dim strCriteria As String
Dim intCurrentRow As Integer
Dim strSQL As String
Dim strSRBDate As String
Dim varReturn As Variant
Dim bReturn As Boolean
Dim strApp As String
Dim rst As Recordset

Set db = GetCurrentDb
Set rst = db.OpenRecordset("tblContacts", dbOpenDynaset)
Set lst = Me.lstScheduled
mstrFileString = ""

strSQL = _
"SELECT * " _
& "FROM tblContacts " _
& "ORDER BY tblContacts.LastName, tblContacts.FirstName;"

strSendMsg = "The " & Me.ProjectID & " Software Review Board is scheduled " _
& "for " & Me.DateOfSRB & " at " & Me.TimeOfSRB & ". " _
& "Please review the listed Incident Reports with their analysis or design documentation and have copies available at " _
& "the time of the meeting. Developers should be prepared to discuss the extent of " _
& "the changes required and proposed designs. If you have any agenda additions or changes please " _
& "notify me as soon as possible. " & vbCrLf & vbCrLf _
& "The SRB will be determining a disposition for each IR, whether the changes for " _
& "approved IRs will require minor or major changes to the DMATS software, and " _
& "tentatively assign the IR for release on a version. The current versions " _
& "scheduled include:" & vbCrLf & vbCrLf

strSRBDate = Format(pdSRBDate, "ddmmmyy&quot
Set rstVersions = db.OpenRecordset("qryVersions", dbOpenDynaset)
If rstVersions.RecordCount <> 0 Then
rstVersions.MoveFirst
For intCurrentRow = 0 To rstVersions.RecordCount - 1
strSendMsg = strSendMsg _
& &quot; &quot; & rstVersions!VersionID & &quot; &quot; _
& rstVersions!VersionDate & &quot; &quot; _
& rstVersions!Narrative & vbCrLf
rstVersions.MoveNext
Next intCurrentRow
strSendMsg = strSendMsg & vbCrLf & vbCrLf _
& &quot;IRs Scheduled include:&quot; & vbCrLf & vbCrLf
End If

'From the Scheduled ListBox find the ProjID and the IRNbr
'and create criteria
For intCurrentRow = 0 To lst.ListCount - 1
strCriteria = &quot;[ProjID] = &quot; & &quot;'&quot; & lstScheduled.Column(0, intCurrentRow) & &quot;'&quot; & &quot; And &quot; _
& &quot;[IRNbr] = '&quot; & lstScheduled.Column(1, intCurrentRow) & &quot;'&quot;
' Then search the IncidentReports recordset for a match
' and update the TRBResult so it isn't selected again for a candidate
If InStr(1, lstScheduled.Column(3, intCurrentRow), &quot;Analysis&quot Then
bReturn = PackageDocs(lstScheduled.Column(1, intCurrentRow), &quot;Analysis&quot
End If
If InStr(1, lstScheduled.Column(3, intCurrentRow), &quot;Design&quot Then
bReturn = PackageDocs(lstScheduled.Column(1, intCurrentRow), &quot;Design&quot
End If
With lst
strSendMsg = strSendMsg & &quot; &quot; & .Column(1, intCurrentRow) _
& &quot; (&quot; & .Column(3, intCurrentRow) & &quot &quot; & .Column(2, intCurrentRow) & vbCrLf
End With
Next intCurrentRow

'PackageDocs:
'Debug.Print &quot;&quot;&quot;&quot; & &quot;c:\Program Files\WinZip\wzzip.exe&quot; & &quot;&quot;&quot;&quot; & &quot; f:\groups\sdv\dmats\srb\&quot; & strSRBDate & &quot; &quot; & mstrFileString
' strApp = &quot;c:\Program Files\WinZip\wzzip.exe&quot;
' varReturn = Dir(strApp)
' If Len(varReturn) > 0 Then
' varReturn = Shell(&quot;&quot;&quot;&quot; & strApp & &quot;&quot;&quot;&quot; & &quot; f:\groups\sdv\dmats\srb\&quot; & strSRBDate _
& &quot; -u &quot; & mstrFileString, vbMinimizedFocus)
' End If

strSendMsg = strSendMsg & vbCrLf & &quot;Automatically generated agenda&quot; & vbCrLf _
& &quot;Steve King&quot; & vbCrLf & &quot;DMATS Acting Configuration Manager&quot;

DoCmd.SendObject _
OutputFormat:=acFormatTXT, _
To:=&quot;tmawby, pbarnett, scking, kneuner&quot;, _
CC:=&quot;gbock, rgagnon&quot;, _
Subject:=Me.ProjectID & &quot; SRB Agenda (&quot; _
& Me.DateOfSRB & &quot; &quot; & Me.TimeOfSRB & &quot&quot;, _
MessageText:=strSendMsg, _
EditMessage:=True

strCriteria = &quot;[ProjID] = &quot; & &quot;&quot;&quot;&quot; & Me.ProjectID & &quot;&quot;&quot;&quot; _
& &quot; AND [TRB_Date] = #&quot; & Me.DateOfSRB & &quot;#&quot;

With rst
.FindFirst strCriteria
.Edit
!DateAgendaMailed = Date
.Update
End With

ExitProc:
Set rst = Nothing
Set lst = Nothing
Set rstVersions = Nothing
Set db = Nothing
Exit Function

HandleErr:

Select Case Err.Number
Case 2501
varReturn = MsgBox(MSGTXT_CANCELZIPFILE, vbYesNo, MSGTITLE_CANCELZIPFILE)
If varReturn = vbYes Then
GoTo ExitProc
Else
'GoTo PackageDocs
End If
Case 3022
'Next intCurrentRow
Case 94
MsgBox &quot;Select an SRB date and re-request the report&quot;
GoTo ExitProc
Case Else
End Select

ERRRET = MsgBox(&quot;Error number &quot; & Err.Number & &quot;: &quot; & Err.Description & vbCrLf & _
&quot;Module frmSRBSchedulerWizard procedure cmdBuildAgenda_Click. &quot; & _
&quot;Would you want to log this error?&quot; & vbCrLf, _
vbYesNo, &quot;Error Notice&quot

' Give the user the ability to choose whether to log this error'
If ERRRET = vbYes Then
ERRRET = ErrorLogger(Err.Number, Err.Description, CurrentUser(), &quot;frmSRBSchedulerWizard&quot;, &quot;cmdBuildAgenda_Click&quot;, usrFrm)
End If
' Do Not log errors found in ErrorLogger automatically as this could put the application in a loop
' ERRRET = ErrorLogger(Err.Number, Err.Description, CurrentUser(), &quot;basCommonProcs&quot;, &quot;HideSwitchboard&quot

GoTo ExitProc
Resume Next
End Function

Public Function CreateContactItem(strLName As String, strFName As String, _
strBody As String, strBusCity As String)

Set oOutlook = New COutlookApps
miReturn = oOutlook.CreateContact(strLName, strFName, _
strBody, strBusCity)
Set oOutlook = Nothing

End Function

Public Function CreateTaskItem(dtDue As Date, strSubject As String, _
strBody As String, lImportance As Long)

Set oOutlook = New COutlookApps
miReturn = oOutlook.CreateTask(dtDue, strSubject, strBody, lImportance)
Set oOutlook = Nothing

End Function

COutlookApps
Option Compare Database
Option Explicit

Private Type Contact
strContact As String
strFirstName As String
strBody As String
strCity As String
End Type

Private Type Task
strBody As String
dtDueDate As Date
bMarkComplete As Boolean
bReminderSet As Boolean
strReminderTime As String
strRecipients As String
strResponseState As String
dtStartDate As Date
strSubject As String
lImportance As Long
End Type

Private Type ErrorType
ErrObj As ErrObject
End Type
Dim UErr As ErrorType

Private Const SUCCESS As Integer = -1
Private Const UNSUCCESSFUL As Integer = 0

Dim mOutlookApp As Outlook.Application
Dim mMapiNamespace As Outlook.NameSpace
Dim mAppointment As AppointmentItem
Dim mAttendee As Recipient
Dim mDefaultCalendarFolder As Object
Dim mDefaultContactsFolder As Object
Dim mDefaultInboxFolder As Object
Dim mDefaultJournalFolder As Object
Dim mDefaultTasksFolder As Object
Dim mResource As Object

Public Function CreateTask(dtDue As Date, strSubject As String, _
strBody As String, lImportance As Long)

Dim myTaskItem As TaskItem
Set mOutlookApp = GetObject(&quot;&quot;, &quot;Outlook.Application&quot
Set myTaskItem = mOutlookApp.CreateItem(olTaskItem)
myTaskItem.Body = strBody
myTaskItem.DueDate = Date
'myTaskItem.MarkComplete
'myTaskItem.ReminderSet = True
'myTaskItem.ReminderTime = &quot;:15&quot;
'myTaskItem.Recipients
'myTaskItem.ResponseState
myTaskItem.StartDate = dtDue
myTaskItem.Subject = strSubject
myTaskItem.Importance = lImportance
myTaskItem.Save
CreateTask = True

End Function

Public Function CreateNote(strBody As String)

Dim myNote As NoteItem

If mOutlookApp Is Nothing Then
SetOutlook
End If

Set myNote = mOutlookApp.CreateItem(olNoteItem)
myNote.Body = strBody
myNote.Save

CreateNote = True

End Function

Public Function GetContact(strName As String) As String

On Error Resume Next

Dim myAddressLists As AddressLists
Dim myAddressList As AddressList
Dim myAddrEntries As AddressEntries
Dim myEntry As AddressEntry
Dim intNameLen As Integer
Dim intCnt As Integer
Dim intCnt2 As Integer
Dim strUser As String
Dim strTempAddr As String
Dim strCategory As String

On Error GoTo HandleErr

If mOutlookApp Is Nothing Then
SetOutlook
End If

Set mMapiNamespace = mOutlookApp.GetNamespace(&quot;MAPI&quot
intNameLen = Len(strName)

For Each myAddressList In mMapiNamespace.AddressLists
If myAddressList.Name = &quot;Contacts&quot; _
Or myAddressList.Name = &quot;Personal Address Book&quot; Then
For Each myEntry In myAddressList.AddressEntries
If InStr(1, myEntry.Name, strName) Then
strTempAddr = myEntry.Address
If InStr(1, strTempAddr, &quot;=&quot Then
strTempAddr = GetShortAddr(myEntry.Members(intCnt).Address)
End If

' Details pops up the properties dialog
'myEntry.Details (0)
'Debug.Print myEntry.Name & &quot; (&quot; & myEntry.Address & &quot&quot;
'If myEntry.DisplayType
strUser = myEntry.Name & &quot; (&quot; & strTempAddr & &quot&quot;
strTempAddr = &quot;&quot;
Select Case myEntry.DisplayType
Case olDistList, olPrivateDistList '4, 5
Debug.Print &quot; Distribution List: &quot; & strUser
For intCnt = 1 To myEntry.Members.Count
strTempAddr = myEntry.Members(intCnt).Address
If InStr(1, strTempAddr, &quot;=&quot Then
strTempAddr = GetShortAddr(myEntry.Members(intCnt).Address)
End If
Debug.Print &quot; Member: &quot; & myEntry.Members(intCnt).Name _
& &quot; (&quot; & strTempAddr & &quot&quot;
strTempAddr = &quot;&quot;
Next intCnt
Case olRemoteUser '6
Debug.Print &quot; Remote User: &quot; & strUser

Case olUser '0
Debug.Print &quot; User: &quot; & strUser
Case Else
Debug.Print &quot; Unknown &quot; & strUser
End Select
End If
Next myEntry
End If
Next myAddressList
GetContact = strUser

Exit_Proc:
Exit Function

HandleErr:
Err.Source = &quot;COutlookApps_GetContact&quot;
Set UErr.ErrObj = Err
Resume Exit_Proc
Resume

End Function
Private Sub SetOutlook()

'Dim mOutlook As Outlook.Application ' Variable to hold reference
' to Microsoft Excel.
Dim OutlookWasNotRunning As Boolean ' Flag for final release.

' Test to see if there is a copy of Microsoft Excel already running.
On Error Resume Next ' Defer error trapping.
' Getobject function called without the first argument returns a
' reference to an instance of the application. If the application isn't
' running, an error occurs. Note the comma used as the first argument
' placeholder.
Set mOutlookApp = GetObject(, &quot;Outlook.Application&quot
If Err.Number <> 0 Then OutlookWasNotRunning = True
Err.Clear ' Clear Err object in case error occurred.

' Check for Excel. If Excel is running,
' enter it into the Running Object table.
' DetectExcel

' Set the object variable to reference the file you want to see.
' Set MyOutlook = GetObject(&quot;c:\vb4\MYTEST.XLS&quot

' Show Microsoft Excel through its Application property. Then
' show the actual window containing the file using the Windows
' collection of the MyXL object reference.
'MyOutllok.Application.Visible = True
'MyXL.Parent.Windows(1).Visible = True

' Do manipulations of your
' file here.
' ...
' If this copy of Microsoft Outlook was not already running when you
' started, close it using the Application property's Quit method.
' Note that when you try to quit Microsoft Excel, the Microsoft Excel
' title bar blinks and Microsoft Excel displays a message asking if you
' want to save any loaded files.
If OutlookWasNotRunning = True Then
mOutlookApp.Application.Quit
End If

' application and spreadsheet.
End Sub


Private Function GetShortAddr(strAddr As String) As String

Dim intCnt As Integer
Dim strTempAddr As String
Dim bFound As Boolean

'strTempAddr = strAddr
For intCnt = Len(strAddr) To 0 Step -1
If InStr(1, strAddr, &quot;=&quot And Not bFound Then
strTempAddr = Mid$(strAddr, intCnt, 1) & strTempAddr
If Left$(strTempAddr, 1) = &quot;=&quot; Then
strTempAddr = Mid$(strTempAddr, 2)
GetShortAddr = strTempAddr
bFound = True
End If
End If
Next intCnt

If Not bFound Then
GetShortAddr = &quot;&quot;
End If

End Function

Public Function CreateAppointment(Subject As String, Location As String, _
Start As Date, Duration As Integer)

If mOutlookApp Is Nothing Then
SetOutlook
End If

If Not mAppointment Is Nothing Then
Set mAppointment = Nothing
End If

Set mAppointment = mOutlookApp.CreateItem(olAppointmentItem)
With mAppointment
.MeetingStatus = olMeeting
.Subject = Subject
.Location = Location
.Start = Start
.Duration = Duration
End With

End Function

Public Function AddAttendee(Name As String, TypeAttendee As Long) As Boolean

' olRequired = 1
' olOptional = 2

If Not mAppointment Is Nothing Then
Set mAttendee = mAppointment.Recipients.Add(Name)
mAttendee.Type = TypeAttendee
'mAttendee.ResolveAll
AddAttendee = True
Else
AddAttendee = False
'MsgBox &quot;Appointment not valid.&quot;
End If

End Function


Public Function AddResource(Name As String) As Boolean

If Not mAppointment Is Nothing Then
Set mResource = _
mAppointment.Recipients.Add(Name)
mResource.Type = olResource
AddResource = True
Else
AddResource = False
End If

End Function

Public Function SendAppointment() As Boolean

If Not mAppointment Is Nothing Then
mAppointment.Send
Set mAppointment = Nothing
SendAppointment = True
Else
SendAppointment = False
End If

End Function

Private Function CreateJournal(strFile As String, Optional strType As String, _
Optional strFileLabel As String)

Dim myJournal As JournalItem

If mOutlookApp Is Nothing Then
SetOutlook
End If

Set myJournal = mOutlookApp.CreateItem(olJournalItem)
'myJournal.Body = &quot;Journal Test&quot;
myJournal.Subject = strFile
If Not IsMissing(strType) Then
Select Case Right$(strFile, 3)
Case &quot;doc&quot;
myJournal.Type = &quot;Microsoft Word&quot;
Case &quot;xls&quot;, &quot;xlw&quot;, &quot;xla&quot;
myJournal.Type = &quot;Microsoft Excel&quot;
Case &quot;ppt&quot;
myJournal.Type = &quot;Microsoft PowerPoint&quot;
Case &quot;mdb&quot;, &quot;mde&quot;, &quot;mda&quot;
myJournal.Type = &quot;Microsoft Access&quot;
Case &quot;txt&quot;, &quot;bat&quot;, &quot;mpx&quot;
myJournal.Type = &quot;Text Files&quot;
Case &quot;mpt&quot;, &quot;mpp&quot;
myJournal.Type = &quot;Microsoft Project&quot;
Case Else
myJournal.Type = &quot;Unknown&quot;
End Select
Else
myJournal.Type = &quot;Unknown&quot;
End If
myJournal.Companies = &quot;ARINC, Inc.&quot;
myJournal.ContactNames = &quot;SCKing&quot;
' The subject is displayed on the journal at the day
' note: the file validity is tested by Outlook
' the label is displayed as the label for the file
If Not IsMissing(strFileLabel) And Len(strFileLabel) > 0 Then
myJournal.Attachments.Add strFile, _
olByValue, 1, strFileLabel
Else
myJournal.Attachments.Add strFile
End If
myJournal.Save
CreateJournal = True

End Function

Public Function CreateContact(strLName As String, strFName As String, _
Optional strBody As String, Optional strBusCity As String) As Integer

Dim myContact As ContactItem

On Error Resume Next

If mOutlookApp Is Nothing Then
SetOutlook
End If
Set myContact = mOutlookApp.CreateItem(olContactItem)
With myContact
.FirstName = strFName
.LastName = strLName
If Not IsMissing(.Body) Then
.Body = strBody
End If
If Not IsMissing(.BusinessAddressCity) Then
.BusinessAddressCity = strBusCity
End If
.Save
End With
CreateContact = True

End Function


Private Sub Class_Initialize()

' Initialize the objects
Set mOutlookApp = CreateObject(&quot;Outlook.Application&quot
Set mMapiNamespace = mOutlookApp.GetNamespace(&quot;MAPI&quot
Set mDefaultCalendarFolder = mMapiNamespace.GetDefaultFolder(olFolderCalendar)
Set mDefaultContactsFolder = mMapiNamespace.GetDefaultFolder(olFolderContacts)
Set mDefaultInboxFolder = mMapiNamespace.GetDefaultFolder(olFolderInbox)
Set mDefaultJournalFolder = mMapiNamespace.GetDefaultFolder(olFolderJournal)
Set mDefaultTasksFolder = mMapiNamespace.GetDefaultFolder(olFolderTasks)

End Sub
Public Sub GetContactInfo()

Dim myContact As ContactItem
Dim myAddressLists As AddressLists
Dim myAddressList As AddressList
Dim myAddrEntries As AddressEntries
Dim myEntry As AddressEntry
Dim intNameLen As Integer
Dim intCnt As Integer
Dim intCnt2 As Integer
Dim strUser As String
Dim strTempAddr As String
Dim strCategory As String

'On Error GoTo HandleErr

If mOutlookApp Is Nothing Then
SetOutlook
End If

Set mMapiNamespace = mOutlookApp.GetNamespace(&quot;MAPI&quot
Set mDefaultContactsFolder = mMapiNamespace.GetDefaultFolder(olFolderContacts)
On Error Resume Next

For Each myContact In mDefaultContactsFolder
With myContact
Debug.Print myContact.Categories
End With
Next myContact

End Sub


Steve King Growth follows a healthy professional curiosity