S
scott
I found the below module, class and functions at
http://www.mvps.org/access/modules/mdl0019.htm that send emails using the
Microsoft CDO 1.21 library. It works fine except for one problem. It will
send an attachment, but it renames the file's extention to ".dat", no matter
what type of file you try to send as an attachment.
I realize this code is quite long, but could someone take a look at the sub
function TestMAPIEmail() part and also the Public Sub function
MAPIAddAttachment() that resides in the clsMAPIEmail Class Module? I think
that's the sub function that handles attachments.
If I could just find a way to prevent Outlook 2003 from renaming the file
extention of attachments sent, this would be a great solution for email via
Outlook and handling attachments.
'**************** mdlMAPITest Module Start ***********************
Sub TestMAPIEmail()
Dim clMAPI As clsMAPIEmail
Set clMAPI = New clsMAPIEmail
With clMAPI
.MAPILogon
.MAPIAddMessage
.MAPISetMessageBody = "Test From Access"
.MAPISetMessageSubject = "Testing Access Email"
.MAPIAddRecipient stPerson:="(e-mail address removed)", _
intAddressType:=1 'To
' .MAPIAddRecipient stPerson:="Dev Ashish", _
' intAddressType:=2 'cc
' .MAPIAddRecipient stPerson:="smtp:[email protected]", _
' intAddressType:=3 'bcc
.MAPIAddAttachment "C:\temp\test.pdf", "Jet Readme"
' .MAPIAddAttachment stFile:="C:\temp\test.doc"
.MAPIUpdateMessage
.MAPISendMessage boolSaveCopy:=False
.MAPILogoff
End With
End Sub
'**************** mdlMAPITest Module End ***********************
'**************** clsMAPI Class Module Start ***********************
'This code was originally written by Dev Ashish.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
'Code courtesy of
'Dev Ashish
'
Option Compare Database
Option Explicit
Private Const mcERR_DOH = vbObjectError + 10000
Private Const mcERR_DECIMAL = 261144 'low word order +1000
Private Const mcMAXFLD = 16
Private mobjSession As MAPI.Session
Private mobjFolder As Folder
Private mobjMessage As Message
Private mobjMsgColl As Messages
Private mlngFolderType As Long
Private mstStatus As String
Private mstTable As String
Private mstFolderName As String
Private mastFld(0 To mcMAXFLD, 1) As String
Private mboolErr As Boolean
Private mlngCount As Long
Private Sub Class_Initialize()
mboolErr = False
mlngCount = 0
mstStatus = SysCmd(acSysCmdSetStatus, "Initializing...")
End Sub
Private Sub Class_Terminate()
On Error Resume Next
Erase mastFld
Set mobjMessage = Nothing
Set mobjMsgColl = Nothing
Set mobjFolder = Nothing
mobjSession.Logoff
Set mobjSession = Nothing
mstStatus = SysCmd(acSysCmdClearStatus)
End Sub
Public Sub MAPIImportMessages()
Dim db As Database, rs As Recordset
Dim objRecipient As Recipient
Dim objAttachment As Attachment
Dim stOut As String
On Error GoTo MAPIImportMessages_Error
If Not mboolErr Then
Set db = CurrentDb
Set rs = db.OpenRecordset(mstTable, dbOpenDynaset)
'***Must change this to QUERIES somehow
Set mobjMsgColl = mobjFolder.Messages
If Not 0 = mobjMsgColl.Count Then
Set mobjMessage = mobjMsgColl.GetFirst()
Do While Not mobjMessage Is Nothing
With rs
.AddNew
!Class = mobjMessage.Class
!FolderID = mobjMessage.FolderID
!ID = mobjMessage.ID
stOut = vbNullString
For Each objRecipient In
mobjMessage.Recipients
stOut = stOut & objRecipient.Name & " ("
_
& objRecipient.Address & ") ;"
Next
'some emails don't have your name in the To:
field
If mobjMessage.Recipients.Count > 0 Then
stOut = Left$(stOut, Len(stOut) - 2)
!Recipients = stOut
End If
stOut = vbNullString
'Attachments at the moment are generating
'E_OutofMemory error code.
'
'For Each objAttachment In
mobjMessage.Attachments
' stOut = stOut & objAttachment.Name & ";"
' Next
'If mobjMessage.Attachments.Count > 0 Then
' stOut = Left$(stOut, Len(stOut) - 1)
' !Attachments = stOut
' End If
!SenderEmailAddress =
mobjMessage.Sender.Address
!Sender = mobjMessage.Sender.Name
'!Sensitivity = mobjMessage.Sensitivity
!MsgSize = mobjMessage.Size
!StoreID = mobjMessage.StoreID
!Subject = mobjMessage.Subject
!Messagebody = mobjMessage.Text
!TimeCreated = mobjMessage.TimeCreated
!TimeLastModified =
mobjMessage.TimeLastModified
!TimeReceived = mobjMessage.TimeReceived
!TimeSent = mobjMessage.TimeSent
.Update
mlngCount = mlngCount + 1
mstStatus = SysCmd(acSysCmdSetStatus, "Imported " &
mlngCount & " message(s)....")
Set mobjMessage = mobjMsgColl.GetNext
End With
Loop
End If
End If
Set rs = Nothing
Set db = Nothing
stOut = "Imported " & mlngCount & " messages from the folder '" &
mobjFolder.Name & "'."
MsgBox stOut, vbOKOnly, "Success!!"
MAPIImportMessages_Exit:
Exit Sub
MAPIImportMessages_Error:
stOut = "Finished importing " & mlngCount & " Messages." & vbCrLf
stOut = stOut & "Couldn't import the message titled " & vbCrLf
stOut = stOut & "'" & mobjMessage.Subject & "'." & vbCrLf & "Aborting!"
& vbCrLf
stOut = stOut & "Error returned was:" & vbCrLf
stOut = stOut & Err & ": " & Err.Description
MsgBox stOut, vbCritical + vbOKOnly, "Critical error encountered!"
Set mobjMessage = Nothing
Set mobjMsgColl = Nothing
Set mobjFolder = Nothing
mobjSession.Logoff
Set mobjSession = Nothing
Resume MAPIImportMessages_Exit
End Sub
Public Property Let MAPISetImportTable(stTableName As String)
Dim stMsg As String
stMsg = "The table name '" & stTableName & "' already exists " _
& "in this database!"
stMsg = stMsg & "@Continuing beyond this step will delete and recreate
it."
stMsg = stMsg & "@Do you wish to proceed?"
mboolErr = False
If Not fTableNotExist(stTableName) Then
If MsgBox(stMsg, vbExclamation + vbYesNo, "Warning!") = vbYes Then
DoCmd.DeleteObject acTable, stTableName
CurrentDb.TableDefs.Refresh
End If
End If
mstTable = stTableName
If Not fCreateMsgTable(stTableName) Then
MsgBox "Error encountered while creating table. Aborting.", _
vbCritical + vbOKOnly, "Critical Error"
mboolErr = True
Exit Property
End If
End Property
Public Property Get MAPIGetImportTable() As String
MAPIGetImportTable = mstTable
End Property
Private Function fCreateMsgTable(stTable As String) As Boolean
Dim tdf As TableDef, db As Database
Dim fld As Field, boolErr As Boolean
Dim i As Integer
On Error GoTo Error_fCreateMsgTable
mstStatus = SysCmd(acSysCmdSetStatus, "Creating Import table...")
Set db = CurrentDb
boolErr = False
db.TableDefs.Refresh
Call sInitFldArray
Set tdf = db.CreateTableDef(stTable)
With tdf
For i = 0 To mcMAXFLD
If CInt(mastFld(i, 1)) = dbText Then
Set fld = .CreateField(mastFld(i, 0), CInt(mastFld(i,
1)), 255)
Else
Set fld = .CreateField(mastFld(i, 0), CInt(mastFld(i,
1)))
End If
If CInt(mastFld(i, 1)) = dbText Or CInt(mastFld(i, 1) =
dbMemo) Then
'must do this since some subjects/emails are blanks
fld.AllowZeroLength = True
End If
With fld
If .Name = "CounterID" Then
.Attributes = dbAutoIncrField
End If
End With
.Fields.Append fld
Next
End With
db.TableDefs.Append tdf
db.TableDefs.Refresh
fCreateMsgTable = True
Exit_fCreateMsgTable:
Set fld = Nothing
Set tdf = Nothing
Set db = Nothing
If boolErr Then
On Error Resume Next
DoCmd.DeleteObject acTable, stTable
End If
Exit Function
Error_fCreateMsgTable:
MsgBox "Error in creating table '" & stTable & "'. Aborting!", _
vbCritical + vbOKOnly, "Critical error encountered"
boolErr = True
fCreateMsgTable = False
Resume Exit_fCreateMsgTable
End Function
Sub sInitFldArray()
mastFld(0, 0) = "Class": mastFld(0, 1) =
CStr(dbLong)
mastFld(1, 0) = "FolderID": mastFld(1, 1) =
CStr(dbText)
mastFld(2, 0) = "ID": mastFld(2, 1) =
CStr(dbText)
mastFld(3, 0) = "Recipients": mastFld(3, 1) =
CStr(dbMemo)
mastFld(4, 0) = "Sender": mastFld(4, 1) =
CStr(dbText)
mastFld(5, 0) = "SenderEmailAddress": mastFld(5, 1) = CStr(dbText)
mastFld(6, 0) = "Sensitivity": mastFld(6, 1) = CStr(dbLong)
mastFld(7, 0) = "MsgSize": mastFld(7, 1) = CStr(dbLong)
mastFld(8, 0) = "StoreID": mastFld(8, 1) = CStr(dbText)
mastFld(9, 0) = "Subject": mastFld(9, 1) = CStr(dbText)
mastFld(10, 0) = "MessageBody": mastFld(10, 1) = CStr(dbMemo)
mastFld(11, 0) = "TimeCreated": mastFld(11, 1) = CStr(dbDate)
mastFld(12, 0) = "TimeLastModified": mastFld(12, 1) = CStr(dbDate)
mastFld(13, 0) = "TimeReceived": mastFld(13, 1) = CStr(dbDate)
mastFld(14, 0) = "TimeSent": mastFld(14, 1) = CStr(dbDate)
mastFld(15, 0) = "Attachments": mastFld(15, 1) = CStr(dbMemo)
mastFld(16, 0) = "CounterID": mastFld(16, 1) = CStr(dbLong)
End Sub
Private Function fTableNotExist(stTable) As Boolean
Dim db As Database
Dim tdf As TableDef
Set db = CurrentDb
On Error Resume Next
Set tdf = db.TableDefs(stTable)
fTableNotExist = (Err <> 0)
Set tdf = Nothing
Set db = Nothing
End Function
Public Property Get MAPIGetImportFolder() As String
MAPIGetImportFolder = mstFolderName
End Property
Public Property Let MAPISetImportFolder(stFolderName As String)
Dim stID As String
On Error GoTo MAPISetImportFolder_Error
stID = vbNullString
Select Case UCase(stFolderName)
Case "CALENDAR":
mlngFolderType = CdoDefaultFolderCalendar
Case "CONTACTS":
mlngFolderType = CdoDefaultFolderContacts
Case "DELETED ITEMS":
mlngFolderType = CdoDefaultFolderDeletedItems
Case "INBOX":
mlngFolderType = CdoDefaultFolderInbox
Case "JOURNAL":
mlngFolderType = CdoDefaultFolderJournal
Case "NOTES":
mlngFolderType = CdoDefaultFolderNotes
Case "OUTBOX":
mlngFolderType = CdoDefaultFolderOutbox
Case "SENT ITEMS":
mlngFolderType = CdoDefaultFolderSentItems
Case "TASKS":
mlngFolderType = CdoDefaultFolderTasks
Case Else:
stID = fSearchFolder(stFolderName)
If Not stID = vbNullString Then
Set mobjFolder = mobjSession.GetFolder(stID)
End If
End Select
If stID = vbNullString Then
Set mobjFolder = mobjSession.GetDefaultFolder(mlngFolderType)
End If
mstFolderName = mobjFolder.Name
MAPISetImportFolder_Exit:
Exit Property
MAPISetImportFolder_Error:
If Err = CdoE_NOT_FOUND - mcERR_DECIMAL Then
MsgBox "Folder '" & stFolderName & "' not found! Please try
again.", _
vbCritical + vbOKOnly, "Error in folder name"
End If
Set mobjMessage = Nothing
Set mobjMsgColl = Nothing
Set mobjFolder = Nothing
Set mobjSession = Nothing
Resume MAPISetImportFolder_Exit
End Property
Private Function fSearchFolder(stFolderName) As String
Dim objFolder As Folder ' local
Dim objInfoStoresColl As InfoStores
Dim objInfoStore As InfoStore
Dim objFoldersColl As Folders
Dim stID As String
Dim boolEnd As Boolean
On Error GoTo fSearchFolder_Err
mstStatus = SysCmd(acSysCmdSetStatus, "searching for folder...")
fSearchFolder = False: boolEnd = False
Set objInfoStoresColl = mobjSession.InfoStores
For Each objInfoStore In objInfoStoresColl
With objInfoStore
If .Name <> "Public Folders" Then
Set objFoldersColl = .RootFolder.Folders
Set objFolder = objFoldersColl.GetFirst
Do While Not objFolder Is Nothing
If objFolder.Name = stFolderName Then
stID = objFolder.ID
boolEnd = True
Exit Do
Else
Set objFolder = objFoldersColl.GetNext
End If
Loop
If boolEnd Then Exit For
End If
End With
Next
If boolEnd Then
fSearchFolder = stID
Else
fSearchFolder = vbNullString
End If
fSearchFolder_Exit:
On Error Resume Next
Set objFolder = Nothing
Set objFoldersColl = Nothing
Set objInfoStore = Nothing
Set objInfoStoresColl = Nothing
Exit Function
fSearchFolder_Err:
fSearchFolder = vbNullString
Resume fSearchFolder_Exit
End Function
Public Sub MAPILogon()
On Error GoTo err_sMAPILogon
mstStatus = SysCmd(acSysCmdSetStatus, "Login....")
Set mobjSession = CreateObject("MAPI.Session")
mobjSession.Logon
exit_sMAPILogon:
Exit Sub
err_sMAPILogon:
If Err = CdoE_LOGON_FAILED - mcERR_DECIMAL Then
MsgBox "Logon Failed", vbCritical + vbOKOnly, "Error"
Else
MsgBox "Error number " & Err - mcERR_DECIMAL & " description. " &
Error$(Err)
End If
Resume exit_sMAPILogon
End Sub
Public Sub MAPILogoff()
On Error GoTo err_sMAPILogoff
mstStatus = SysCmd(acSysCmdSetStatus, "Logging off...")
Set mobjMessage = Nothing
Set mobjMsgColl = Nothing
Set mobjFolder = Nothing
mobjSession.Logoff
Set mobjSession = Nothing
exit_sMAPILogoff:
Exit Sub
err_sMAPILogoff:
Resume exit_sMAPILogoff
End Sub
'**************** clsMAPI Class Module End ***********************
'**************** clsMAPIEmail Class Module Start ***********************
'This code was originally written by Dev Ashish.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
'Code courtesy of Dev Ashish
Option Compare Database
Option Explicit
Private mobjSession As MAPI.Session
Private mobjMessage As Message
Private mboolErr As Boolean
Private mstStatus As String
Private mobjNewMessage As Message
Private Const mcERR_DOH = vbObjectError + 10000
Private Const mcERR_DECIMAL = 261144 'low word order +1000
Public Sub MAPIAddMessage()
With mobjSession
Set mobjNewMessage = .Outbox.Messages.Add
End With
End Sub
Public Sub MAPIUpdateMessage()
mobjNewMessage.Update
End Sub
Private Sub Class_Initialize()
mboolErr = False
End Sub
Private Sub Class_Terminate()
On Error Resume Next
Set mobjMessage = Nothing
mobjSession.Logoff
Set mobjSession = Nothing
End Sub
Public Property Let MAPISetMessageBody(stBodyText As String)
If Len(stBodyText) > 0 Then mobjNewMessage.Text = stBodyText
End Property
Public Property Let MAPISetMessageSubject(stSubject As String)
If Len(stSubject) > 0 Then mobjNewMessage.Subject = stSubject
End Property
Public Property Get MAPIIsError() As Boolean
MAPIIsError = mboolErr
End Property
Public Property Get MAPIRecipientCount() As Integer
MAPIRecipientCount = mobjNewMessage.Recipients.Count
End Property
Public Sub MAPIAddAttachment(stFile As String, _
Optional stLabel As Variant)
Dim objAttachment As Attachment
Dim stMsg As String
On Error GoTo Error_MAPIAddAttachment
If mboolErr Then Err.Raise mcERR_DOH
If Len(Dir(stFile)) = 0 Then Err.Raise mcERR_DOH + 10
mstStatus = SysCmd(acSysCmdSetStatus, "Adding Attachments...")
If IsMissing(stLabel) Then stLabel = CStr(stFile)
With mobjNewMessage
.Text = " " & mobjNewMessage.Text
Set objAttachment = .Attachments.Add
With objAttachment
.Position = 0
.Name = stLabel
.Type = CdoFileData
.ReadFromFile stFile
End With
.Update
End With
Exit_MAPIAddAttachment:
Set objAttachment = Nothing
Exit Sub
Error_MAPIAddAttachment:
mboolErr = True
If Err = mcERR_DOH + 10 Then
stMsg = "Couldn't locate the file " & vbCrLf
stMsg = stMsg & "'" & stFile & "'." & vbCrLf
stMsg = stMsg & "Please check the file name and path and try again."
MsgBox stMsg, vbExclamation + vbOKOnly, "File Not Found"
ElseIf Err <> mcERR_DOH Then
MsgBox "Error " & Err.Number & vbCrLf & Err.Description
End If
Resume Exit_MAPIAddAttachment
End Sub
Public Sub MAPIAddRecipient(stPerson As String, intAddressType As Integer)
Dim objNewRecipient As Recipient 'local
On Error GoTo Error_MAPIAddRecipient
mstStatus = SysCmd(acSysCmdSetStatus, "Adding Recipients...")
If mboolErr Then Err.Raise mcERR_DOH
'If there's no SMTP present in the stPerson var, then
'we have to use Name, else Address
With mobjNewMessage
If InStr(1, stPerson, "SMTP:") > 0 Then
Set objNewRecipient = .Recipients.Add(Address:=stPerson, _
Type:=intAddressType)
Else
Set objNewRecipient = .Recipients.Add(Name:=stPerson, _
Type:=intAddressType)
End If
objNewRecipient.Resolve
End With
Exit_MAPIAddRecipient:
Set objNewRecipient = Nothing
Exit Sub
Error_MAPIAddRecipient:
mboolErr = True
Resume Exit_MAPIAddRecipient
End Sub
Public Sub MAPISendMessage(Optional boolSaveCopy As Variant, _
Optional boolShowDialog As Variant)
mstStatus = SysCmd(acSysCmdSetStatus, "Sending message...")
If IsMissing(boolSaveCopy) Then
boolSaveCopy = True
End If
If IsMissing(boolShowDialog) Then
boolShowDialog = False
End If
mobjNewMessage.Send savecopy:=boolSaveCopy, showdialog:=boolShowDialog
mobjSession.DeliverNow
End Sub
Public Sub MAPILogon()
On Error GoTo err_sMAPILogon
Const cERROR_USERCANCEL = -2147221229
mstStatus = SysCmd(acSysCmdSetStatus, "Login....")
Set mobjSession = CreateObject("MAPI.Session")
mobjSession.Logon
exit_sMAPILogon:
Exit Sub
err_sMAPILogon:
mboolErr = True
If Err = CdoE_LOGON_FAILED - mcERR_DECIMAL Then
MsgBox "Logon Failed", vbCritical + vbOKOnly, "Error"
ElseIf Err = cERROR_USERCANCEL Then
MsgBox "Aborting since you pressed cancel.", _
vbOKOnly + vbInformation, "Operatoin Cancelled!"
Else
MsgBox "Error number " & Err - mcERR_DECIMAL & " description. " _
& Error$(Err)
End If
Resume exit_sMAPILogon
End Sub
Public Sub MAPILogoff()
On Error GoTo err_sMAPILogoff
mstStatus = SysCmd(acSysCmdSetStatus, "Logging off...")
mobjSession.Logoff
Set mobjNewMessage = Nothing
Set mobjSession = Nothing
mstStatus = SysCmd(acSysCmdClearStatus)
exit_sMAPILogoff:
Exit Sub
err_sMAPILogoff:
Resume exit_sMAPILogoff
End Sub
'**************** clsMAPIEmail Class Module End ***********************
http://www.mvps.org/access/modules/mdl0019.htm that send emails using the
Microsoft CDO 1.21 library. It works fine except for one problem. It will
send an attachment, but it renames the file's extention to ".dat", no matter
what type of file you try to send as an attachment.
I realize this code is quite long, but could someone take a look at the sub
function TestMAPIEmail() part and also the Public Sub function
MAPIAddAttachment() that resides in the clsMAPIEmail Class Module? I think
that's the sub function that handles attachments.
If I could just find a way to prevent Outlook 2003 from renaming the file
extention of attachments sent, this would be a great solution for email via
Outlook and handling attachments.
'**************** mdlMAPITest Module Start ***********************
Sub TestMAPIEmail()
Dim clMAPI As clsMAPIEmail
Set clMAPI = New clsMAPIEmail
With clMAPI
.MAPILogon
.MAPIAddMessage
.MAPISetMessageBody = "Test From Access"
.MAPISetMessageSubject = "Testing Access Email"
.MAPIAddRecipient stPerson:="(e-mail address removed)", _
intAddressType:=1 'To
' .MAPIAddRecipient stPerson:="Dev Ashish", _
' intAddressType:=2 'cc
' .MAPIAddRecipient stPerson:="smtp:[email protected]", _
' intAddressType:=3 'bcc
.MAPIAddAttachment "C:\temp\test.pdf", "Jet Readme"
' .MAPIAddAttachment stFile:="C:\temp\test.doc"
.MAPIUpdateMessage
.MAPISendMessage boolSaveCopy:=False
.MAPILogoff
End With
End Sub
'**************** mdlMAPITest Module End ***********************
'**************** clsMAPI Class Module Start ***********************
'This code was originally written by Dev Ashish.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
'Code courtesy of
'Dev Ashish
'
Option Compare Database
Option Explicit
Private Const mcERR_DOH = vbObjectError + 10000
Private Const mcERR_DECIMAL = 261144 'low word order +1000
Private Const mcMAXFLD = 16
Private mobjSession As MAPI.Session
Private mobjFolder As Folder
Private mobjMessage As Message
Private mobjMsgColl As Messages
Private mlngFolderType As Long
Private mstStatus As String
Private mstTable As String
Private mstFolderName As String
Private mastFld(0 To mcMAXFLD, 1) As String
Private mboolErr As Boolean
Private mlngCount As Long
Private Sub Class_Initialize()
mboolErr = False
mlngCount = 0
mstStatus = SysCmd(acSysCmdSetStatus, "Initializing...")
End Sub
Private Sub Class_Terminate()
On Error Resume Next
Erase mastFld
Set mobjMessage = Nothing
Set mobjMsgColl = Nothing
Set mobjFolder = Nothing
mobjSession.Logoff
Set mobjSession = Nothing
mstStatus = SysCmd(acSysCmdClearStatus)
End Sub
Public Sub MAPIImportMessages()
Dim db As Database, rs As Recordset
Dim objRecipient As Recipient
Dim objAttachment As Attachment
Dim stOut As String
On Error GoTo MAPIImportMessages_Error
If Not mboolErr Then
Set db = CurrentDb
Set rs = db.OpenRecordset(mstTable, dbOpenDynaset)
'***Must change this to QUERIES somehow
Set mobjMsgColl = mobjFolder.Messages
If Not 0 = mobjMsgColl.Count Then
Set mobjMessage = mobjMsgColl.GetFirst()
Do While Not mobjMessage Is Nothing
With rs
.AddNew
!Class = mobjMessage.Class
!FolderID = mobjMessage.FolderID
!ID = mobjMessage.ID
stOut = vbNullString
For Each objRecipient In
mobjMessage.Recipients
stOut = stOut & objRecipient.Name & " ("
_
& objRecipient.Address & ") ;"
Next
'some emails don't have your name in the To:
field
If mobjMessage.Recipients.Count > 0 Then
stOut = Left$(stOut, Len(stOut) - 2)
!Recipients = stOut
End If
stOut = vbNullString
'Attachments at the moment are generating
'E_OutofMemory error code.
'
'For Each objAttachment In
mobjMessage.Attachments
' stOut = stOut & objAttachment.Name & ";"
' Next
'If mobjMessage.Attachments.Count > 0 Then
' stOut = Left$(stOut, Len(stOut) - 1)
' !Attachments = stOut
' End If
!SenderEmailAddress =
mobjMessage.Sender.Address
!Sender = mobjMessage.Sender.Name
'!Sensitivity = mobjMessage.Sensitivity
!MsgSize = mobjMessage.Size
!StoreID = mobjMessage.StoreID
!Subject = mobjMessage.Subject
!Messagebody = mobjMessage.Text
!TimeCreated = mobjMessage.TimeCreated
!TimeLastModified =
mobjMessage.TimeLastModified
!TimeReceived = mobjMessage.TimeReceived
!TimeSent = mobjMessage.TimeSent
.Update
mlngCount = mlngCount + 1
mstStatus = SysCmd(acSysCmdSetStatus, "Imported " &
mlngCount & " message(s)....")
Set mobjMessage = mobjMsgColl.GetNext
End With
Loop
End If
End If
Set rs = Nothing
Set db = Nothing
stOut = "Imported " & mlngCount & " messages from the folder '" &
mobjFolder.Name & "'."
MsgBox stOut, vbOKOnly, "Success!!"
MAPIImportMessages_Exit:
Exit Sub
MAPIImportMessages_Error:
stOut = "Finished importing " & mlngCount & " Messages." & vbCrLf
stOut = stOut & "Couldn't import the message titled " & vbCrLf
stOut = stOut & "'" & mobjMessage.Subject & "'." & vbCrLf & "Aborting!"
& vbCrLf
stOut = stOut & "Error returned was:" & vbCrLf
stOut = stOut & Err & ": " & Err.Description
MsgBox stOut, vbCritical + vbOKOnly, "Critical error encountered!"
Set mobjMessage = Nothing
Set mobjMsgColl = Nothing
Set mobjFolder = Nothing
mobjSession.Logoff
Set mobjSession = Nothing
Resume MAPIImportMessages_Exit
End Sub
Public Property Let MAPISetImportTable(stTableName As String)
Dim stMsg As String
stMsg = "The table name '" & stTableName & "' already exists " _
& "in this database!"
stMsg = stMsg & "@Continuing beyond this step will delete and recreate
it."
stMsg = stMsg & "@Do you wish to proceed?"
mboolErr = False
If Not fTableNotExist(stTableName) Then
If MsgBox(stMsg, vbExclamation + vbYesNo, "Warning!") = vbYes Then
DoCmd.DeleteObject acTable, stTableName
CurrentDb.TableDefs.Refresh
End If
End If
mstTable = stTableName
If Not fCreateMsgTable(stTableName) Then
MsgBox "Error encountered while creating table. Aborting.", _
vbCritical + vbOKOnly, "Critical Error"
mboolErr = True
Exit Property
End If
End Property
Public Property Get MAPIGetImportTable() As String
MAPIGetImportTable = mstTable
End Property
Private Function fCreateMsgTable(stTable As String) As Boolean
Dim tdf As TableDef, db As Database
Dim fld As Field, boolErr As Boolean
Dim i As Integer
On Error GoTo Error_fCreateMsgTable
mstStatus = SysCmd(acSysCmdSetStatus, "Creating Import table...")
Set db = CurrentDb
boolErr = False
db.TableDefs.Refresh
Call sInitFldArray
Set tdf = db.CreateTableDef(stTable)
With tdf
For i = 0 To mcMAXFLD
If CInt(mastFld(i, 1)) = dbText Then
Set fld = .CreateField(mastFld(i, 0), CInt(mastFld(i,
1)), 255)
Else
Set fld = .CreateField(mastFld(i, 0), CInt(mastFld(i,
1)))
End If
If CInt(mastFld(i, 1)) = dbText Or CInt(mastFld(i, 1) =
dbMemo) Then
'must do this since some subjects/emails are blanks
fld.AllowZeroLength = True
End If
With fld
If .Name = "CounterID" Then
.Attributes = dbAutoIncrField
End If
End With
.Fields.Append fld
Next
End With
db.TableDefs.Append tdf
db.TableDefs.Refresh
fCreateMsgTable = True
Exit_fCreateMsgTable:
Set fld = Nothing
Set tdf = Nothing
Set db = Nothing
If boolErr Then
On Error Resume Next
DoCmd.DeleteObject acTable, stTable
End If
Exit Function
Error_fCreateMsgTable:
MsgBox "Error in creating table '" & stTable & "'. Aborting!", _
vbCritical + vbOKOnly, "Critical error encountered"
boolErr = True
fCreateMsgTable = False
Resume Exit_fCreateMsgTable
End Function
Sub sInitFldArray()
mastFld(0, 0) = "Class": mastFld(0, 1) =
CStr(dbLong)
mastFld(1, 0) = "FolderID": mastFld(1, 1) =
CStr(dbText)
mastFld(2, 0) = "ID": mastFld(2, 1) =
CStr(dbText)
mastFld(3, 0) = "Recipients": mastFld(3, 1) =
CStr(dbMemo)
mastFld(4, 0) = "Sender": mastFld(4, 1) =
CStr(dbText)
mastFld(5, 0) = "SenderEmailAddress": mastFld(5, 1) = CStr(dbText)
mastFld(6, 0) = "Sensitivity": mastFld(6, 1) = CStr(dbLong)
mastFld(7, 0) = "MsgSize": mastFld(7, 1) = CStr(dbLong)
mastFld(8, 0) = "StoreID": mastFld(8, 1) = CStr(dbText)
mastFld(9, 0) = "Subject": mastFld(9, 1) = CStr(dbText)
mastFld(10, 0) = "MessageBody": mastFld(10, 1) = CStr(dbMemo)
mastFld(11, 0) = "TimeCreated": mastFld(11, 1) = CStr(dbDate)
mastFld(12, 0) = "TimeLastModified": mastFld(12, 1) = CStr(dbDate)
mastFld(13, 0) = "TimeReceived": mastFld(13, 1) = CStr(dbDate)
mastFld(14, 0) = "TimeSent": mastFld(14, 1) = CStr(dbDate)
mastFld(15, 0) = "Attachments": mastFld(15, 1) = CStr(dbMemo)
mastFld(16, 0) = "CounterID": mastFld(16, 1) = CStr(dbLong)
End Sub
Private Function fTableNotExist(stTable) As Boolean
Dim db As Database
Dim tdf As TableDef
Set db = CurrentDb
On Error Resume Next
Set tdf = db.TableDefs(stTable)
fTableNotExist = (Err <> 0)
Set tdf = Nothing
Set db = Nothing
End Function
Public Property Get MAPIGetImportFolder() As String
MAPIGetImportFolder = mstFolderName
End Property
Public Property Let MAPISetImportFolder(stFolderName As String)
Dim stID As String
On Error GoTo MAPISetImportFolder_Error
stID = vbNullString
Select Case UCase(stFolderName)
Case "CALENDAR":
mlngFolderType = CdoDefaultFolderCalendar
Case "CONTACTS":
mlngFolderType = CdoDefaultFolderContacts
Case "DELETED ITEMS":
mlngFolderType = CdoDefaultFolderDeletedItems
Case "INBOX":
mlngFolderType = CdoDefaultFolderInbox
Case "JOURNAL":
mlngFolderType = CdoDefaultFolderJournal
Case "NOTES":
mlngFolderType = CdoDefaultFolderNotes
Case "OUTBOX":
mlngFolderType = CdoDefaultFolderOutbox
Case "SENT ITEMS":
mlngFolderType = CdoDefaultFolderSentItems
Case "TASKS":
mlngFolderType = CdoDefaultFolderTasks
Case Else:
stID = fSearchFolder(stFolderName)
If Not stID = vbNullString Then
Set mobjFolder = mobjSession.GetFolder(stID)
End If
End Select
If stID = vbNullString Then
Set mobjFolder = mobjSession.GetDefaultFolder(mlngFolderType)
End If
mstFolderName = mobjFolder.Name
MAPISetImportFolder_Exit:
Exit Property
MAPISetImportFolder_Error:
If Err = CdoE_NOT_FOUND - mcERR_DECIMAL Then
MsgBox "Folder '" & stFolderName & "' not found! Please try
again.", _
vbCritical + vbOKOnly, "Error in folder name"
End If
Set mobjMessage = Nothing
Set mobjMsgColl = Nothing
Set mobjFolder = Nothing
Set mobjSession = Nothing
Resume MAPISetImportFolder_Exit
End Property
Private Function fSearchFolder(stFolderName) As String
Dim objFolder As Folder ' local
Dim objInfoStoresColl As InfoStores
Dim objInfoStore As InfoStore
Dim objFoldersColl As Folders
Dim stID As String
Dim boolEnd As Boolean
On Error GoTo fSearchFolder_Err
mstStatus = SysCmd(acSysCmdSetStatus, "searching for folder...")
fSearchFolder = False: boolEnd = False
Set objInfoStoresColl = mobjSession.InfoStores
For Each objInfoStore In objInfoStoresColl
With objInfoStore
If .Name <> "Public Folders" Then
Set objFoldersColl = .RootFolder.Folders
Set objFolder = objFoldersColl.GetFirst
Do While Not objFolder Is Nothing
If objFolder.Name = stFolderName Then
stID = objFolder.ID
boolEnd = True
Exit Do
Else
Set objFolder = objFoldersColl.GetNext
End If
Loop
If boolEnd Then Exit For
End If
End With
Next
If boolEnd Then
fSearchFolder = stID
Else
fSearchFolder = vbNullString
End If
fSearchFolder_Exit:
On Error Resume Next
Set objFolder = Nothing
Set objFoldersColl = Nothing
Set objInfoStore = Nothing
Set objInfoStoresColl = Nothing
Exit Function
fSearchFolder_Err:
fSearchFolder = vbNullString
Resume fSearchFolder_Exit
End Function
Public Sub MAPILogon()
On Error GoTo err_sMAPILogon
mstStatus = SysCmd(acSysCmdSetStatus, "Login....")
Set mobjSession = CreateObject("MAPI.Session")
mobjSession.Logon
exit_sMAPILogon:
Exit Sub
err_sMAPILogon:
If Err = CdoE_LOGON_FAILED - mcERR_DECIMAL Then
MsgBox "Logon Failed", vbCritical + vbOKOnly, "Error"
Else
MsgBox "Error number " & Err - mcERR_DECIMAL & " description. " &
Error$(Err)
End If
Resume exit_sMAPILogon
End Sub
Public Sub MAPILogoff()
On Error GoTo err_sMAPILogoff
mstStatus = SysCmd(acSysCmdSetStatus, "Logging off...")
Set mobjMessage = Nothing
Set mobjMsgColl = Nothing
Set mobjFolder = Nothing
mobjSession.Logoff
Set mobjSession = Nothing
exit_sMAPILogoff:
Exit Sub
err_sMAPILogoff:
Resume exit_sMAPILogoff
End Sub
'**************** clsMAPI Class Module End ***********************
'**************** clsMAPIEmail Class Module Start ***********************
'This code was originally written by Dev Ashish.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
'Code courtesy of Dev Ashish
Option Compare Database
Option Explicit
Private mobjSession As MAPI.Session
Private mobjMessage As Message
Private mboolErr As Boolean
Private mstStatus As String
Private mobjNewMessage As Message
Private Const mcERR_DOH = vbObjectError + 10000
Private Const mcERR_DECIMAL = 261144 'low word order +1000
Public Sub MAPIAddMessage()
With mobjSession
Set mobjNewMessage = .Outbox.Messages.Add
End With
End Sub
Public Sub MAPIUpdateMessage()
mobjNewMessage.Update
End Sub
Private Sub Class_Initialize()
mboolErr = False
End Sub
Private Sub Class_Terminate()
On Error Resume Next
Set mobjMessage = Nothing
mobjSession.Logoff
Set mobjSession = Nothing
End Sub
Public Property Let MAPISetMessageBody(stBodyText As String)
If Len(stBodyText) > 0 Then mobjNewMessage.Text = stBodyText
End Property
Public Property Let MAPISetMessageSubject(stSubject As String)
If Len(stSubject) > 0 Then mobjNewMessage.Subject = stSubject
End Property
Public Property Get MAPIIsError() As Boolean
MAPIIsError = mboolErr
End Property
Public Property Get MAPIRecipientCount() As Integer
MAPIRecipientCount = mobjNewMessage.Recipients.Count
End Property
Public Sub MAPIAddAttachment(stFile As String, _
Optional stLabel As Variant)
Dim objAttachment As Attachment
Dim stMsg As String
On Error GoTo Error_MAPIAddAttachment
If mboolErr Then Err.Raise mcERR_DOH
If Len(Dir(stFile)) = 0 Then Err.Raise mcERR_DOH + 10
mstStatus = SysCmd(acSysCmdSetStatus, "Adding Attachments...")
If IsMissing(stLabel) Then stLabel = CStr(stFile)
With mobjNewMessage
.Text = " " & mobjNewMessage.Text
Set objAttachment = .Attachments.Add
With objAttachment
.Position = 0
.Name = stLabel
.Type = CdoFileData
.ReadFromFile stFile
End With
.Update
End With
Exit_MAPIAddAttachment:
Set objAttachment = Nothing
Exit Sub
Error_MAPIAddAttachment:
mboolErr = True
If Err = mcERR_DOH + 10 Then
stMsg = "Couldn't locate the file " & vbCrLf
stMsg = stMsg & "'" & stFile & "'." & vbCrLf
stMsg = stMsg & "Please check the file name and path and try again."
MsgBox stMsg, vbExclamation + vbOKOnly, "File Not Found"
ElseIf Err <> mcERR_DOH Then
MsgBox "Error " & Err.Number & vbCrLf & Err.Description
End If
Resume Exit_MAPIAddAttachment
End Sub
Public Sub MAPIAddRecipient(stPerson As String, intAddressType As Integer)
Dim objNewRecipient As Recipient 'local
On Error GoTo Error_MAPIAddRecipient
mstStatus = SysCmd(acSysCmdSetStatus, "Adding Recipients...")
If mboolErr Then Err.Raise mcERR_DOH
'If there's no SMTP present in the stPerson var, then
'we have to use Name, else Address
With mobjNewMessage
If InStr(1, stPerson, "SMTP:") > 0 Then
Set objNewRecipient = .Recipients.Add(Address:=stPerson, _
Type:=intAddressType)
Else
Set objNewRecipient = .Recipients.Add(Name:=stPerson, _
Type:=intAddressType)
End If
objNewRecipient.Resolve
End With
Exit_MAPIAddRecipient:
Set objNewRecipient = Nothing
Exit Sub
Error_MAPIAddRecipient:
mboolErr = True
Resume Exit_MAPIAddRecipient
End Sub
Public Sub MAPISendMessage(Optional boolSaveCopy As Variant, _
Optional boolShowDialog As Variant)
mstStatus = SysCmd(acSysCmdSetStatus, "Sending message...")
If IsMissing(boolSaveCopy) Then
boolSaveCopy = True
End If
If IsMissing(boolShowDialog) Then
boolShowDialog = False
End If
mobjNewMessage.Send savecopy:=boolSaveCopy, showdialog:=boolShowDialog
mobjSession.DeliverNow
End Sub
Public Sub MAPILogon()
On Error GoTo err_sMAPILogon
Const cERROR_USERCANCEL = -2147221229
mstStatus = SysCmd(acSysCmdSetStatus, "Login....")
Set mobjSession = CreateObject("MAPI.Session")
mobjSession.Logon
exit_sMAPILogon:
Exit Sub
err_sMAPILogon:
mboolErr = True
If Err = CdoE_LOGON_FAILED - mcERR_DECIMAL Then
MsgBox "Logon Failed", vbCritical + vbOKOnly, "Error"
ElseIf Err = cERROR_USERCANCEL Then
MsgBox "Aborting since you pressed cancel.", _
vbOKOnly + vbInformation, "Operatoin Cancelled!"
Else
MsgBox "Error number " & Err - mcERR_DECIMAL & " description. " _
& Error$(Err)
End If
Resume exit_sMAPILogon
End Sub
Public Sub MAPILogoff()
On Error GoTo err_sMAPILogoff
mstStatus = SysCmd(acSysCmdSetStatus, "Logging off...")
mobjSession.Logoff
Set mobjNewMessage = Nothing
Set mobjSession = Nothing
mstStatus = SysCmd(acSysCmdClearStatus)
exit_sMAPILogoff:
Exit Sub
err_sMAPILogoff:
Resume exit_sMAPILogoff
End Sub
'**************** clsMAPIEmail Class Module End ***********************