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"
Set rstVersions = db.OpenRecordset("qryVersions", dbOpenDynaset)
If rstVersions.RecordCount <> 0 Then
rstVersions.MoveFirst
For intCurrentRow = 0 To rstVersions.RecordCount - 1
strSendMsg = strSendMsg _
& " " & rstVersions!VersionID & " " _
& rstVersions!VersionDate & " " _
& rstVersions!Narrative & vbCrLf
rstVersions.MoveNext
Next intCurrentRow
strSendMsg = strSendMsg & vbCrLf & vbCrLf _
& "IRs Scheduled include:" & 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 = "[ProjID] = " & "'" & lstScheduled.Column(0, intCurrentRow) & "'" & " And " _
& "[IRNbr] = '" & lstScheduled.Column(1, intCurrentRow) & "'"
' 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), "Analysis"
Then
bReturn = PackageDocs(lstScheduled.Column(1, intCurrentRow), "Analysis"
End If
If InStr(1, lstScheduled.Column(3, intCurrentRow), "Design"
Then
bReturn = PackageDocs(lstScheduled.Column(1, intCurrentRow), "Design"
End If
With lst
strSendMsg = strSendMsg & " " & .Column(1, intCurrentRow) _
& " (" & .Column(3, intCurrentRow) & "
" & .Column(2, intCurrentRow) & vbCrLf
End With
Next intCurrentRow
'PackageDocs:
'Debug.Print """" & "c:\Program Files\WinZip\wzzip.exe" & """" & " f:\groups\sdv\dmats\srb\" & strSRBDate & " " & mstrFileString
' strApp = "c:\Program Files\WinZip\wzzip.exe"
' varReturn = Dir(strApp)
' If Len(varReturn) > 0 Then
' varReturn = Shell("""" & strApp & """" & " f:\groups\sdv\dmats\srb\" & strSRBDate _
& " -u " & mstrFileString, vbMinimizedFocus)
' End If
strSendMsg = strSendMsg & vbCrLf & "Automatically generated agenda" & vbCrLf _
& "Steve King" & vbCrLf & "DMATS Acting Configuration Manager"
DoCmd.SendObject _
OutputFormat:=acFormatTXT, _
To:="tmawby, pbarnett, scking, kneuner", _
CC:="gbock, rgagnon", _
Subject:=Me.ProjectID & " SRB Agenda (" _
& Me.DateOfSRB & " " & Me.TimeOfSRB & "
", _
MessageText:=strSendMsg, _
EditMessage:=True
strCriteria = "[ProjID] = " & """" & Me.ProjectID & """" _
& " AND [TRB_Date] = #" & Me.DateOfSRB & "#"
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 "Select an SRB date and re-request the report"
GoTo ExitProc
Case Else
End Select
ERRRET = MsgBox("Error number " & Err.Number & ": " & Err.Description & vbCrLf & _
"Module frmSRBSchedulerWizard procedure cmdBuildAgenda_Click. " & _
"Would you want to log this error?" & vbCrLf, _
vbYesNo, "Error Notice"
' Give the user the ability to choose whether to log this error'
If ERRRET = vbYes Then
ERRRET = ErrorLogger(Err.Number, Err.Description, CurrentUser(), "frmSRBSchedulerWizard", "cmdBuildAgenda_Click", 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(), "basCommonProcs", "HideSwitchboard"
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("", "Outlook.Application"
Set myTaskItem = mOutlookApp.CreateItem(olTaskItem)
myTaskItem.Body = strBody
myTaskItem.DueDate = Date
'myTaskItem.MarkComplete
'myTaskItem.ReminderSet = True
'myTaskItem.ReminderTime = ":15"
'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("MAPI"
intNameLen = Len(strName)
For Each myAddressList In mMapiNamespace.AddressLists
If myAddressList.Name = "Contacts" _
Or myAddressList.Name = "Personal Address Book" Then
For Each myEntry In myAddressList.AddressEntries
If InStr(1, myEntry.Name, strName) Then
strTempAddr = myEntry.Address
If InStr(1, strTempAddr, "="
Then
strTempAddr = GetShortAddr(myEntry.Members(intCnt).Address)
End If
' Details pops up the properties dialog
'myEntry.Details (0)
'Debug.Print myEntry.Name & " (" & myEntry.Address & "
"
'If myEntry.DisplayType
strUser = myEntry.Name & " (" & strTempAddr & "
"
strTempAddr = ""
Select Case myEntry.DisplayType
Case olDistList, olPrivateDistList '4, 5
Debug.Print " Distribution List: " & strUser
For intCnt = 1 To myEntry.Members.Count
strTempAddr = myEntry.Members(intCnt).Address
If InStr(1, strTempAddr, "="
Then
strTempAddr = GetShortAddr(myEntry.Members(intCnt).Address)
End If
Debug.Print " Member: " & myEntry.Members(intCnt).Name _
& " (" & strTempAddr & "
"
strTempAddr = ""
Next intCnt
Case olRemoteUser '6
Debug.Print " Remote User: " & strUser
Case olUser '0
Debug.Print " User: " & strUser
Case Else
Debug.Print " Unknown " & strUser
End Select
End If
Next myEntry
End If
Next myAddressList
GetContact = strUser
Exit_Proc:
Exit Function
HandleErr:
Err.Source = "COutlookApps_GetContact"
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(, "Outlook.Application"
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("c:\vb4\MYTEST.XLS"
' 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, "="
And Not bFound Then
strTempAddr = Mid$(strAddr, intCnt, 1) & strTempAddr
If Left$(strTempAddr, 1) = "=" Then
strTempAddr = Mid$(strTempAddr, 2)
GetShortAddr = strTempAddr
bFound = True
End If
End If
Next intCnt
If Not bFound Then
GetShortAddr = ""
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 "Appointment not valid."
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 = "Journal Test"
myJournal.Subject = strFile
If Not IsMissing(strType) Then
Select Case Right$(strFile, 3)
Case "doc"
myJournal.Type = "Microsoft Word"
Case "xls", "xlw", "xla"
myJournal.Type = "Microsoft Excel"
Case "ppt"
myJournal.Type = "Microsoft PowerPoint"
Case "mdb", "mde", "mda"
myJournal.Type = "Microsoft Access"
Case "txt", "bat", "mpx"
myJournal.Type = "Text Files"
Case "mpt", "mpp"
myJournal.Type = "Microsoft Project"
Case Else
myJournal.Type = "Unknown"
End Select
Else
myJournal.Type = "Unknown"
End If
myJournal.Companies = "ARINC, Inc."
myJournal.ContactNames = "SCKing"
' 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("Outlook.Application"
Set mMapiNamespace = mOutlookApp.GetNamespace("MAPI"
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("MAPI"
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
![[ponytails]](/data/assets/smilies/ponytails.gif "[ponytails] [ponytails]")
