REPOST: Sending Emails from Access 2000

  • Thread starter Thread starter ChrisBat
  • Start date Start date
C

ChrisBat

REPOST
I'm reposting this because I really, really need to figure
this out and don't want anybody to see it because the
message is down at the bottom. Thank you very, very much
to anyone who can help.
What I'm trying to do is build a form that will allow me
to link directly with Outlook. Below is the code that I
took from the Microsoft paper How to Use Automation to
Send a Microsoft Outlook Message Using Access 2000 (ID
209948). The code works splendidly, except for two small
glitches. (1) The code only seems to work testing it from
the immediate window. This just won't do. (2) I want the
information to be taken using a form, with the recipient,
subject and body to be text boxes; Importance to default
to Normal (I figured out this part); and Send and Attach
to be buttons, with the Attach button opening the Attach
Which File window. Does anybody have any ideas? I'm
running Access 2000 on a Windows NT 4.0 machine.
Thank you very, very much.
Chris

Option Compare Database
Option Explicit

Sub SendMessage(Optional AttachmentPath)
Dim objOutlook As Outlook.Application
Dim objOUtlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment

' Create the Outlook Session
Set objOutlook = CreateObject("Outlook.Application")

' Create the Message
Set objOUtlookMsg = objOutlook.CreateItem(olMailItem)

With objOUtlookMsg
' Add the To reciepient(s) to the message
Set objOutlookRecip = .Recipients.Add("_____@____.com")
objOutlookRecip = .Type = olTo

' Add the CC recipient(s) to the message
Set objOutlookRecip = .Recipients.Add("_____@____.com")
objOutlookRecip = .Type = olCC

' Set the subject, body and importance of the message
.Subject = "_____________"
.Body = "_______________________"
.Importance = olImportanceNormal

' Add attachments to the message
If Not IsMissing(AttachmentPath) Then
Set objOutlookAttach = .Attachments.Add
(AttachmentPath)
End If

' Resolve each recipient's name
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
If Not objOutlookRecip.Resolve Then
objOUtlookMsg.Display
End If
Next
.Send

End With
Set objOUtlookMsg = Nothing
Set objOutlook = Nothing

End Sub
 
Hi,

The example sub needs to be modified, to include more arguments. That way
you can call the sub and supply the arguments from a button click event on
your form.

Here is a revised sub that I use:
'Start of Code
Public Sub SendEmailMessage(blnShowMsg As Boolean, strSubject As String,
strBody As String, _
Optional strToWhom As String, Optional strCC As String, _
Optional AttachmentPath As String)

Dim olookApp As Object 'Outlook.Application
Dim olookMsg As Object 'Outlook.MailItem
Dim olookRecipient As Object 'Outlook.Recipient
Dim olookAttach As Object 'Outlook.Attachment
Dim blnMultiSelection As Boolean
Dim kounter As Integer, strTemp As String
Dim strFilesSelected(30) As String
Dim strWhomTemp As String
Dim strCCTemp As String
On Error GoTo HandleErr
Const olMailItem = 0
Const olTo = 1
Const olCC = 2
Const olImportanceLow = 0

If InStr(1, AttachmentPath, Chr(9), vbTextCompare) > 0 Then
blnMultiSelection = True
Else
blnMultiSelection = False
End If
' create the Outlook session.
Set olookApp = CreateObject("Outlook.Application")

' create the message.
Set olookMsg = olookApp.CreateItem(olMailItem)

With olookMsg
' add the To recipient(s) to the message.

If Not IsMissing(strToWhom) Then
If Len(strToWhom) > 0 Then
If InStr(strToWhom, "|") > 0 Then
Do
strWhomTemp = Left(strToWhom, InStr(strToWhom, "|") - 1)
Set olookRecipient = .Recipients.Add(strWhomTemp)
olookRecipient.Type = olTo
strToWhom = Mid(strToWhom, InStr(strToWhom, "|") + 1)
If InStr(strToWhom, "|") = 0 Then Exit Do
Loop
Set olookRecipient = .Recipients.Add(strToWhom)
olookRecipient.Type = olTo
Else
Set olookRecipient = .Recipients.Add(strToWhom)
olookRecipient.Type = olTo
End If
End If
End If

' add the CC recipient(s) to the message.
If Not IsMissing(strCC) Then
If Len(strCC) > 0 Then
If InStr(strCC, "|") > 0 Then
Do
strCCTemp = Left(strCC, InStr(strCC, "|") - 1)
Set olookRecipient = .Recipients.Add(strCCTemp)
olookRecipient.Type = olCC
strCC = Mid(strCC, InStr(strCC, "|") + 1)
If InStr(strCC, "|") = 0 Then Exit Do
Loop
Set olookRecipient = .Recipients.Add(strCC)
olookRecipient.Type = olCC
Else
Set olookRecipient = .Recipients.Add(strCC)
olookRecipient.Type = olCC
End If
End If
End If
' set the Subject, Body, and Importance of the message.
.Subject = strSubject
.Body = strBody
.Importance = olImportanceLow 'Low importance

' add attachments to the message.
If Len(AttachmentPath) > 0 Then
If blnMultiSelection Then
strFilesSelected(1) = Left(AttachmentPath, InStr(1,
AttachmentPath, Chr(9), vbTextCompare) - 1)
strTemp = Mid(AttachmentPath, InStr(1, AttachmentPath,
Chr(9), vbTextCompare) + 1)
Set olookAttach = .Attachments.Add(strFilesSelected(1))
For kounter = 2 To 30
If InStr(1, strTemp, Chr(9), vbTextCompare) = 0 Then
strFilesSelected(kounter) = strTemp
Set olookAttach =
..Attachments.Add(strFilesSelected(kounter))
Exit For
Else
strFilesSelected(kounter) = Mid(strTemp, 1, InStr(1,
strTemp, Chr(9), vbTextCompare) - 1)
End If
Set olookAttach =
..Attachments.Add(strFilesSelected(kounter))
strTemp = Mid(strTemp, InStr(1, strTemp, Chr(9),
vbTextCompare) + 1)
Next
Else
Set olookAttach = .Attachments.Add(AttachmentPath)
End If
End If

' resolve each Recipient's name
For Each olookRecipient In .Recipients
olookRecipient.Resolve
If Not olookRecipient.Resolve Then
olookMsg.Display ' display any names that can't be resolved
End If
Next

If blnShowMsg Then
olookMsg.Display
Else
.Send
End If


End With
Set olookMsg = Nothing
Set olookApp = Nothing
End Sub
'End of code

The calling code would look something like this:

SendEmailMessage True, Me.txtSubject, _
Me.txtBody, Me.txtEMailTo, Me.txtEmailCC, Me.txtFilename

Note; this code will attached multiple files if they are delimited by a tab
character - chr(9).

HTH

--

Cheers
Mark

Free Access/Office Add-Ins at:
http://mphillipson.users.btopenworld.com/
 
Back
Top