Adding function to send email button via itemsend event

See more:

Outlook

email

I 'm trying to add function to the send email button that modifies the email address and the subject but have been running into a weird issue. If I run debug and step though the code it works but if I let the code run the email is sent out with no recipients.



I've added msgbox before the code to check the values and after to make sure the code was working correctly. Thank You for any help.



Outlook 2010 Daemon email server and plugin

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
 Dim e As MailItem
 Set e = Item

MsgBox e.Recipients(1)
 MsgBox e.Subject
 RPostOffice.Show
 MsgBox e.Recipients(1)
 MsgBox e.Subject

Rem Cancel = True

End Sub






 Public Sub CreateEmail(EmailType As Integer)

Dim msg As Outlook.MailItem
 Dim pa As Outlook.PropertyAccessor
 Dim recips As Outlook.Recipients
 Dim recip As Outlook.Recipient

On Error GoTo MyError

Const PR_SMTP_ADDRESS As String = _
         "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"

Set msg = Application.ActiveInspector.currentItem
 Set recips = msg.Recipients

Dim myString As String
 Dim myAddress As String
 Dim mySubject As String

Select Case EmailType
 Case 0
     'Encrypt
     msg.Body = msg.Body & newline & newline & "Encrypted by RPost " & LabelVersionNumb.Caption
     mySubject = "RPSX() "
 Case 1
 'eSign
     msg.Body = msg.Body & newline & newline & "eSign by RPost " & LabelVersionNumb.Caption
     mySubject = "(RPX) "
 Case 2
 'Registered
     msg.Body = msg.Body & newline & newline & "Registered by RPost " & LabelVersionNumb.Caption
     mySubject = ""
 Case 3
 'Secure_eSign
     msg.Body = msg.Body & newline & newline & "Secure_eSign by RPost " & LabelVersionNumb.Caption
     mySubject = "(RPX)RPSX() "
 Case 4
 'Unmarked
     msg.Body = msg.Body & newline & newline & "Unmarked by RPost " & LabelVersionNumb.Caption
     mySubject = "(C) "
 Case Else
     GoTo MyError
     
 End Select

msg.Save

For Each recip In recips
     Set pa = recip.PropertyAccessor
     myAddress = pa.GetProperty(PR_SMTP_ADDRESS)

    If myAddress Like "*xxxxxxxxxx.com*" Then
     Rem replace xxxxxx  domanin with  xxxx
     myAddress = Replace(myAddress, "xxxxxx.com", "xxxxxxx.com")
     End If

    Rem Check for internal address and if rpost.org is already added.

    If myAddress Like "*.rpost.org*" Then
     Rem remove .rpost.org domain
     myAddress = Replace(myAddress, ".rpost.org", "")
     End If

    If myAddress Like "*xxxxxxx.com*" Then
     myString = myAddress & ";" & myString
     Else
     
     myString = myAddress & ".rpost.org; " & myString
     End If

Next

msg.To = myString
 If msg.Subject Like "*" & mySubject & "*" Then
 msg.Subject = Replace(msg.Subject, mySubject, "")
 End If

msg.Subject = mySubject & msg.Subject
 msg.CC = ""
 msg.BCC = ""
 msg.Save
 Rem MsgBox ("Email Sent")
 Rem MsgBox "Check email addresses are shown correctly before sending!"
 Unload RPostOffice

Exit Sub
 '**************************************
 'Error handler Section
 '**************************************

MyError:

   MsgBox "Error " & Err.Number & " " & Err.Description
    
    
 Unload RPostOffice

End Sub


 Private Sub CancelButton_Click()
 Unload RPostOffice
 Exit Sub
 End Sub

Private Sub Encrypt_Click()
 CreateEmail (0)
 End Sub

Private Sub eSign_Click()
 CreateEmail (1)
 End Sub

Private Sub LabelVersionNumb_Click()

End Sub

Private Sub Registered_Click()
 CreateEmail (2)
 End Sub

Private Sub Secure_eSignButton1_Click()
 CreateEmail (3)
 End Sub

Private Sub Unmarked_Click()
 CreateEmail (4)
 End Sub

Private Sub UserForm_Initialize()
 LabelVersionNumb.Caption = "Ver M 3.16"
 End Sub

What I have tried:

I've added the msgbox before the code that changes the properties and after. The msgbox report correctly. I thought the call for the object was pulling two different objects. Step though works. If I throw an error (Put msg.send in the senditem event) the code works but run it correctly and the recipient is blank in the email sent.