Bypass Outlook Security Message using VB Code

We also ran into the same issue in our office two years ago. We used the Redemption DLL available here :

http://www.dimastr.com/redemption/

The site has the dll available for download, along with instructions, documentation and examples.

Below is some sample code that we've implemented. Looking back at it, we should have cleaned it up a lot, but it works. With the DLL registered, we use the SendEmail procedure by simply supplying it :

1. a comma delimited list of addresses
2. optional subject line
3. optional message
4. optional file path for an attachment

Let me know if you have any questions.



Public Sub SendEmail(strTo As String, _
                   Optional strSubject As String, _
                   Optional strMessage As String, _
                   Optional strFile As String)


Dim varArray() As Variant
Dim n As Integer

' outlook and redemption mail object variables
Dim appOutlook As Outlook.Application
Dim objMailItem As Redemption.SafeMailItem
Dim objSRecip As Redemption.SafeRecipient
Dim objItem As Object
Dim objBtn As Object
Dim objUtils As Object

' only used if Outlook is not open
Dim objExplorer As Outlook.Explorer
Dim objFolder As Outlook.MAPIFolder



ListToArray strTo, varArray


' checks to see if Outlook is running. if not, will go to the error handler
Set appOutlook = GetObject(, "Outlook.Application")
Set objExplorer = appOutlook.ActiveExplorer


' creates the outlook (redemption) mail item
' Set appOutlook = Outlook.Application
Set objMailItem = CreateObject("Redemption.SafeMailItem")
Set objItem = appOutlook.CreateItem(0)
objMailItem.Item = objItem

' the mail item has a subject assigned, valid emails supplied, and the report attached
With objMailItem
    .Subject = strSubject
    .Body = strMessage
    For n = 0 To UBound(varArray, 1)
        Set objSRecip = .Recipients.Add(varArray(n))
        objSRecip.Resolve
        ' if the address in not resolved, it is deleted from the list of recipients
        If objSRecip.Resolved = False Then
            objSRecip.Delete
        End If
        Set objSRecip = Nothing
    Next n
    If Not IsMissing(strFile) Or strFile <> "" Then
        .Attachments.Add strFile
    End If
    .Send
End With

' manually specify the send button to be executed
Set objBtn = appOutlook.ActiveExplorer.CommandBars.FindControl(1, 5488)
objBtn.Execute


CleanUp:


Set objBtn = Nothing
Set objItem = Nothing
Set objMailItem = Nothing
Set appOutlook = Nothing


' cleans up the Extended MAPI session cache
Set objUtils = CreateObject("Redemption.MAPIUtils")
objUtils.CleanUp
Set objUtils = Nothing



End Sub

Public Sub ListToArray(ByVal strList As String, ByRef varArray As Variant, Optional ByVal strDelim As String)

Dim n As Integer
Dim lngNumOfCommas As Long
Dim strLetter As String
Dim intCommaIndex As Long


' the default delimiter is a comma
If IsMissing(strDelim) Or strDelim = "" Then strDelim = ","
strList = Trim(strList)

' adds a delimiter at the end, if there isn't one, as a list index marker
If Right(strList, 1) <> strDelim Then strList = strList & strDelim

' loops through each character in the string, counting the number of commas
For n = 1 To Len(strList)
    If Mid(strList, n, 1) = strDelim Then
        lngNumOfCommas = lngNumOfCommas + 1
    End If
Next n



ReDim varArray(lngNumOfCommas - 1)

' places each list item in varArray
intCommaIndex = 0
For n = 1 To Len(strList)
    If Mid(strList, n, 1) <> strDelim Then
        strLetter = strLetter & Mid(strList, n, 1)
    Else
        varArray(intCommaIndex) = Trim(strLetter)
        intCommaIndex = intCommaIndex + 1
        strLetter = ""
    End If
Next n

End Sub