Hi,
I'm attempting to send an encrypted email through excel vba. I've found some code to use that is suppose to encrypt the email. I've put it in blue text. please don't mind the URL, that part is ok, I checked but it wouldn't let me keep it in this post.
I've spit out the encryption values and they seem to be ok, but for some reason the email doesn't encrypt? Do I have everything in the right place? Should my email be encrypted? I'm looking for a second set of eyes and opinion as I've been starring at this for hours.
Here's my code:
Sub Mail_Tasks(Query_num As String, topic As String, Company As String, ByRef question As String, assign_to As String, notes As String, due_date As Date)
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
With ThisWorkbook.Sheets("Query Tracker")
strbody = "Topic: " & topic & vbNewLine & _
"Date Query Recieved: " & due_date & vbNewLine & _
"Recieved from: " & Company & vbNewLine & _
"Assign to: " & assign_to & vbNewLine & _
"Question: " & question & vbNewLine & _
"Status Comments: " & notes
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
End With
On Error Resume Next
With OutMail
Const PR_SECURITY_FLAGS = "Microsoft schema link"
Dim oProp As Long
oProp = CLng(OutMail.PropertyAccessor.GetProperty(PR_SECURITY_FLAGS))
MsgBox "Original flag value is: " & oProp
uFlags = 0
ulFlags = ulFlags Or &H1 ' Add the encrypted flag
ulFlags = ulFlags Or &H2 ' Add the signed flag
Item.PropertyAccessor.SetProperty PR_SECURITY_FLAGS, ulFlags
MsgBox "Updated flag value is: " & ulFlags
.To = "My Email"
.CC = ""
.BCC = ""
.Subject = Query_num & "- A Response for this Query is Due: " & due_date & " " & topic
.Body = strbody
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
I'm attempting to send an encrypted email through excel vba. I've found some code to use that is suppose to encrypt the email. I've put it in blue text. please don't mind the URL, that part is ok, I checked but it wouldn't let me keep it in this post.
I've spit out the encryption values and they seem to be ok, but for some reason the email doesn't encrypt? Do I have everything in the right place? Should my email be encrypted? I'm looking for a second set of eyes and opinion as I've been starring at this for hours.
Here's my code:
Sub Mail_Tasks(Query_num As String, topic As String, Company As String, ByRef question As String, assign_to As String, notes As String, due_date As Date)
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
With ThisWorkbook.Sheets("Query Tracker")
strbody = "Topic: " & topic & vbNewLine & _
"Date Query Recieved: " & due_date & vbNewLine & _
"Recieved from: " & Company & vbNewLine & _
"Assign to: " & assign_to & vbNewLine & _
"Question: " & question & vbNewLine & _
"Status Comments: " & notes
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
End With
On Error Resume Next
With OutMail
Const PR_SECURITY_FLAGS = "Microsoft schema link"
Dim oProp As Long
oProp = CLng(OutMail.PropertyAccessor.GetProperty(PR_SECURITY_FLAGS))
MsgBox "Original flag value is: " & oProp
uFlags = 0
ulFlags = ulFlags Or &H1 ' Add the encrypted flag
ulFlags = ulFlags Or &H2 ' Add the signed flag
Item.PropertyAccessor.SetProperty PR_SECURITY_FLAGS, ulFlags
MsgBox "Updated flag value is: " & ulFlags
.To = "My Email"
.CC = ""
.BCC = ""
.Subject = Query_num & "- A Response for this Query is Due: " & due_date & " " & topic
.Body = strbody
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub