Need Redemption to add Report for Outlook (1 Viewer)

modest

Registered User.
Local time
Today, 13:23
Joined
Jan 4, 2005
Messages
1,220
Code:
Public Function Email()
    Dim olApp       As Outlook.Application
    Dim olNamespace As Outlook.Namespace
    Dim olFolder    As Outlook.MAPIFolder
    Dim olMailItem  As Outlook.MailItem
    Dim strBodyText As String
    Dim objSafeMail As Redemption.SafeMailItem
    
    Set olApp = CreateObject("Outlook.Application")
    Set olNamespace = olApp.GetNamespace("MAPI")
    Set olFolder = olNamespace.GetDefaultFolder(olFolderInbox)
    Set olMailItem = olFolder.Items.Add("IPM.Note")

    strBodyText = "Test Message"
    With olMailItem
        .Subject = "Test Subject"
        .To = "john.doe@neverland.com"
        .Body = strBodyText
    End With
    
    Set objSafeMail = New Redemption.SafeMailItem
    objSafeMail.Item = olMailItem
    objSafeMail.Send
    
    
  'clean up variables/memory
    Set objSafeMail = Nothing
    Set olMailItem = Nothing
    Set olFolder = Nothing
    Set olNamespace = Nothing
    Set olApp = Nothing
End Function

I use redemption so that i don't get that annoying security message. Redemption wraps everything in the MAPI. Therefore I can't use .SendObject, I need to know how to add a report :(

I have a different function that loops through my email lists so that I can send these reports to my contacts (there's like 30 different reports... which is why the security message is a no no).

Requesting assistance..Thank you kindly,
Modest
 

modest

Registered User.
Local time
Today, 13:23
Joined
Jan 4, 2005
Messages
1,220
The only way I can seem to do this as of yet is to save the report and just add it as an attachment. I'd like to do this without saving though because it takes a while to save these rather large reports.
 

RoyVidar

Registered User.
Local time
Today, 18:23
Joined
Sep 25, 2000
Messages
805
Some time ago, I encountered something like that, and started playing a little with it. You know, there's a bug in the SendObject method, and Microsoft has a KB article with a CDO workaround. This works very well, but then again the security thingies. I started rewriting the class in that library to use Redemption, but I can't remember if I finished it completely. At lest it works on my setup for some simple sending. First, the original code can be found here:
http://support.microsoft.com/default.aspx?scid=kb;en-us;260819

Because I have both classes in my testdb, the new class is named accSendObject2, and some of the formats/parameters also have the number 2 as extention - I'm sure you'll find them by comparing the classes, and hopefully it can be a starting point...

Oh - I hit the text length limitation of the site - the rest of the code is in next post;)

Call it with something like this:
Code:
sub SendMail(<some parameters?>)
    dim clsSendObject as accSendObject2
    set clsSendObject = new accSendObject2
    clsSendObject2.SendObject2, acSendReport, "some report", _
                               accOutputSNP2, strEMail,,,"Your subject",,False
    set clsSendObject = nothing
end sub

i e - except for the declaration and instantiation of the class, it's just like the "good old" SendObject.



Code:
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
 
Last edited:

RoyVidar

Registered User.
Local time
Today, 18:23
Joined
Sep 25, 2000
Messages
805
...and the rest
Code:
Private Sub StartMessagingAndLogon()
    Dim sKeyName As String
    Dim sValueName As String
    Dim sDefaultUserProfile As String
    Dim osinfo As OSVERSIONINFO
    Dim retvalue As Integer

    On Error GoTo ErrorHandler
    Set MAPISession = CreateObject("MAPI.Session")

    'Try to log on.  If this fails, the most likely reason is
    'that you do not have an open session.  The error
    '-2147221231  MAPI_E_LOGON_FAILED returns.  Trap
    'the error in the ErrorHandler.
    MAPISession.Logon ShowDialog:=False, NewSession:=False
    Exit Sub

ErrorHandler:
    Select Case Err.Number
       Case -2147221231  'MAPI_E_LOGON_FAILED
          'Need to determine what operating system is in use. The keys are different
          'for WinNT and Win95.
          osinfo.dwOSVersionInfoSize = 148
          osinfo.szCSDVersion = Space$(128)
          retvalue = GetVersionEx(osinfo)
          Select Case osinfo.dwPlatformId
             Case 0   'Unidentified
                MsgBox "Unidentified Operating System.  " & _
                   "Cannot log on to messaging."
                Exit Sub
             Case 1   'Win95
                sKeyName = "Software\Microsoft\" & _
                           "Windows Messaging " & _
                           "Subsystem\Profiles"

             Case 2   'NT
                 sKeyName = "Software\Microsoft\Windows NT\" & _
                            "CurrentVersion\" & _
                            "Windows Messaging Subsystem\Profiles"
          End Select

          sValueName = "DefaultProfile"
          sDefaultUserProfile = QueryValue(sKeyName, sValueName)
          MAPISession.Logon ProfileName:=sDefaultUserProfile, _
                           ShowDialog:=False
          Set oUtils = CreateObject("Redemption.MAPIUtils")
          oUtils.MAPIOBJECT = MAPISession.MAPIOBJECT
          Exit Sub
       Case Else
          MsgBox "An error has occured while trying" & Chr(10) & _
          "to create and to log on to a new ActiveMessage session." & _
          Chr(10) & "Report the following error to your " & _
          "System Administrator." & Chr(10) & Chr(10) & _
          "Error Location: frmMain.StartMessagingAndLogon" & _
          Chr(10) & "Error Number: " & Err.Number & Chr(10) & _
          "Description: " & Err.Description
    End Select
End Sub


Private Function QueryValue _
    (sKeyName As String, _
    sValueName As String)

    Dim lRetVal As Long     'Result of the API functions.
    Dim hKey As Long        'Handle of the opened key.
    Dim vValue As Variant   'Setting of the queried value.

    lRetVal = RegOpenKeyEx(HKEY_CURRENT_USER, _
                sKeyName, _
                0, _
                KEY_ALL_ACCESS, _
                hKey)

    lRetVal = QueryValueEx(hKey, _
                sValueName, _
                vValue)
    QueryValue = vValue
    RegCloseKey (hKey)

End Function

Private Function QueryValueEx _
       (ByVal lhKey As Long, _
       ByVal szValueName As String, _
       vValue As Variant) As Long

    Dim cch As Long
    Dim lrc As Long
    Dim lType As Long
    Dim lValue As Long
    Dim sValue As String

    On Error GoTo QueryValueExError

    ' Determine the size and the type of the data to be read.
    lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
    If lrc <> ERROR_NONE Then Error 5

    Select Case lType
       ' For strings
       Case REG_SZ:
          sValue = String(cch, 0)
          lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, _
             sValue, cch)
          If lrc = ERROR_NONE Then
             vValue = Left$(sValue, cch)
          Else
             vValue = Empty
          End If
       ' For DWORDS
       Case REG_DWORD:
          lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, _
             lValue, cch)
          If lrc = ERROR_NONE Then vValue = lValue
       Case Else
          'All other data types that are not supported.
          lrc = -1
    End Select

QueryValueExExit:
    QueryValueEx = lrc
    Exit Function
QueryValueExError:
    Resume QueryValueExExit
End Function
 

modest

Registered User.
Local time
Today, 13:23
Joined
Jan 4, 2005
Messages
1,220
Thanks for responding Roy,

I'm sorry that I did not reply earlier, for I was caught ill. The good thing is that I applied your code to some other code I had recently developed and came up with a solution that runs smoothe. So far no problem sending 15 reports to 150-200 people. However, this was the smaller database and hasn't been running that long.

We'll see if there are problems with mis-sends in time... and with the addition of more people/reports. I'm sure the looping I have initiated in my program may prove to be a bad choice.

Modest
 

carlnewboult

Registered User.
Local time
Today, 17:23
Joined
Sep 27, 2005
Messages
90
i would be interested in seeing the just the part which sends to multiple people as I am finding it very difficult to produce.

Many Thanks
 

modest

Registered User.
Local time
Today, 13:23
Joined
Jan 4, 2005
Messages
1,220
I no longer use redemption and instead use the microsoft schemas. It's amazing how far things have come in two years. This was a pretty old post :) If you use an email list table, which has the report name assigned to it, the pseudocode goes as follows:

Code:
Dim sTo As String
Dim rs  As DAO.Recordset
Set rs = CurrentDb.OpenRecordset("Email List Table",dbReadOnly)
Do until rs.EOF
    sTo = rs.Fields("To") & ";" & sTo
    rs.MoveNext
Loop

' Then you call the SendEmail() function, which requires the To, Subject, Body, and Attachment Information

The actual code can get lengthy, but can be provided, should you need.
 

carlnewboult

Registered User.
Local time
Today, 17:23
Joined
Sep 27, 2005
Messages
90
that would be great if you could

many thanks for your speedy response and your help in this it is driving me crazy
 

modest

Registered User.
Local time
Today, 13:23
Joined
Jan 4, 2005
Messages
1,220
I've added a stripped down version of an email interface I made. It doesn't use any API calls (besides for the background gradient of forms). Data included is test data and does not actually exist, so don't try emailing those people :)

Take time and study it first. And make sure to show hidden files - I didn't feel like going through and unhiding them.

DIRCETIONS:
1) Open "frm_Email_Send"
2) Click "Manage Emails"
3) Click "Add New Report"
4) Fill out information - you don't need to include filters as those were for a different function of the email system that I needed
5) Click "Add Report" to go back to the Email Organizer
6) Click "Add New Address"
7) Fill out the information on this page (preloaded from tbl_Associate)
8) Close form when done to go back to Send Email form

NOTE:
The majority of this was written about 2 years ago and I have hardly done and updates. My programming practices have changed since then, so please refrain from posting criticisms.
 

Attachments

  • Access-Programmers Email System.zip
    163.6 KB · Views: 650

Users who are viewing this thread

Top Bottom