Option Compare Database
Option Explicit
Private MAPISession As MAPI.Session
Private MAPIMessage As MAPI.Message
Private MAPIRecipient As MAPI.Recipient
Private MAPIAttachment As MAPI.Attachment
Private reciparray
Private strFileName As String
Private oUtils As redemption.MAPIUtils
'Private oMAPISession as Redemption.mapisession
Private oMail As redemption.SafeMailItem
Private oMailItem As Object
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Private Const REG_SZ As Long = 1
Private Const REG_DWORD As Long = 4
Private Const HKEY_CURRENT_USER = &H80000001
Private Const ERROR_NONE = 0
Private Const ERROR_BADDB = 1
Private Const ERROR_BADKEY = 2
Private Const ERROR_CANTOPEN = 3
Private Const ERROR_CANTREAD = 4
Private Const ERROR_CANTWRITE = 5
Private Const ERROR_OUTOFMEMORY = 6
Private Const ERROR_INVALID_PARAMETER = 7
Private Const ERROR_ACCESS_DENIED = 8
Private Const ERROR_INVALID_PARAMETERS = 87
Private Const ERROR_NO_MORE_ITEMS = 259
Private Const KEY_ALL_ACCESS = &H3F
Private Const REG_OPTION_NON_VOLATILE = 0
Private Declare Function GetVersionEx Lib "kernel32" _
Alias "GetVersionExA" _
(ByRef lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" _
Alias "RegOpenKeyExA" _
(ByVal hKey As Long, _
ByVal lpSubKey As String, _
ByVal ulOptions As Long, _
ByVal samDesired As Long, _
phkResult As Long) As Long
Private Declare Function RegQueryValueExString Lib "advapi32.dll" _
Alias "RegQueryValueExA" _
(ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal lpReserved As Long, _
lpType As Long, _
ByVal lpData As String, _
lpcbData As Long) As Long
Private Declare Function RegQueryValueExLong Lib "advapi32.dll" _
Alias "RegQueryValueExA" _
(ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal lpReserved As Long, _
lpType As Long, lpData As Long, _
lpcbData As Long) As Long
Private Declare Function RegQueryValueExNULL Lib "advapi32.dll" _
Alias "RegQueryValueExA" _
(ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal lpReserved As Long, _
lpType As Long, _
ByVal lpData As Long, _
lpcbData As Long) As Long
Private Declare Function GetTempPath Lib "kernel32" _
Alias "GetTempPathA" (ByVal nBufferLength As Long, _
ByVal lpBuffer As String) As Long
Public Enum accSendObjectOutputFormat2
accOutputRTF2 = 1
accOutputTXT2 = 2
accOutputSNP2 = 3
accOutputXLS2 = 4
End Enum
Public Sub SendObject2(Optional ObjectType As Access.AcSendObjectType = acSendNoObject, _
Optional ObjectName, _
Optional OutputFormat As accSendObjectOutputFormat, _
Optional EmailAddress, _
Optional CC, _
Optional BCC, _
Optional Subject, _
Optional MessageText, _
Optional EditMessage)
Dim strTmpPath As String * 512
Dim sTmpPath As String
Dim strExtension As String
Dim nRet As Long
StartMessagingAndLogon
Set MAPIMessage = MAPISession.Outbox.Messages.Add
Set oMail = CreateObject("Redemption.SafeMailItem")
Set oMailItem = MAPIMessage
oMail.Item = oMailItem
If ObjectType <> -1 Then
If IsMissing(ObjectName) Or IsMissing(OutputFormat) Then
MsgBox "The object type, name, or output format is not valid. Cannot send message.", vbCritical
MAPISession.Outbox.Messages.Delete
GoTo accSendObject_Exit
Else
strExtension = GetExtension(OutputFormat)
nRet = GetTempPath(512, strTmpPath)
If (nRet > 0 And nRet < 512) Then
If InStr(strTmpPath, Chr(0)) > 0 Then
sTmpPath = RTrim(Left(strTmpPath, InStr(1, strTmpPath, Chr(0)) - 1))
End If
strFileName = sTmpPath & ObjectName & strExtension
End If
On Error Resume Next
DoCmd.OutputTo ObjectType, ObjectName, GetOutputFormat(OutputFormat), strFileName, False
If Err.Number = 0 Then
'Set MAPIAttachment = MAPIMessage.Attachments.Add
'With MAPIAttachment
' .Name = ObjectName
' .Type = CdoFileData
' .Source = strFileName
'End With
oMail.Attachments.Add strFileName, CdoFileData, , ObjectName
Kill strFileName
Else
MsgBox "The object type, name, or output format is not valid. Cannot send message.", vbCritical
MAPISession.Outbox.Messages.Delete
GoTo accSendObject_Exit
End If
End If
End If
If Not IsMissing(EmailAddress) Then
reciparray = Split(EmailAddress, ";", -1, vbTextCompare)
ParseAddress "To"
Erase reciparray
End If
If Not IsMissing(CC) Then
reciparray = Split(CC, ";", -1, vbTextCompare)
ParseAddress "Cc"
Erase reciparray
End If
If Not IsMissing(BCC) Then
reciparray = Split(BCC, ";")
ParseAddress "Bcc"
Erase reciparray
End If
If Not IsMissing(Subject) Then
'MAPIMessage.Subject = Subject
oMail.Subject = Subject
End If
If Not IsMissing(MessageText) Then
'MAPIMessage.Text = MessageText
'oMail.Body = MessageText
oMail.Text = MessageText
End If
If IsMissing(EditMessage) Then EditMessage = True
'MAPIMessage.Update
'MAPIMessage.Send savecopy:=True, ShowDialog:=EditMessage
oMail.Send
accSendObject_Exit:
'Log off the MAPI session.
Set MAPIAttachment = Nothing
Set MAPIRecipient = Nothing
Set MAPIMessage = Nothing
Set MAPISession = Nothing
Exit Sub
End Sub
Private Sub ParseAddress(RecipientType As String)
Dim i As Variant
For Each i In reciparray
'Set MAPIRecipient = MAPIMessage.Recipients.Add
oMail.Recipients.Add i
'With MAPIRecipient
' .Name = i
' .Type = RecipientType
' .Resolve
'End With
'Set MAPIRecipient = Nothing
oMail.Recipients.ResolveAll
Next
End Sub
Private Function GetExtension(ObjectType As Long) As String
Select Case ObjectType
Case 1 'RTF
GetExtension = ".RTF"
Case 2 'TXT
GetExtension = ".TXT"
Case 3 'SNP
GetExtension = ".SNP"
Case 4 'XLS
GetExtension = ".XLS"
End Select
End Function
Private Function GetOutputFormat(ObjectType As Long)
Select Case ObjectType
Case 1 'RTF
GetOutputFormat = Access.acFormatRTF
Case 2 'TXT
GetOutputFormat = Access.acFormatTXT
Case 3 'SNP
GetOutputFormat = Access.acFormatSNP
Case 4 'XLS
GetOutputFormat = Access.acFormatXLS
End Select
End Function