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
var
This content, along with any associated source code and files, is licensed under The Code Project Open License (CPOL)