"A program is trying to automatically send e-mail on your behalf." (1 Viewer)

Public Sub SendMessage(strTo As String, strFrom As String, strBCC As String, strAttachment2 As String)
    'Send using the Port on a SMTP server
    Dim attList() As String
    Dim item As Integer
    Dim iMsg 
    Dim iConf 
    Dim Flds 
    Dim strHTML
    Dim stBody1 As String, stBody2 As String, stSubject As String
    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.configuration")
    Set Flds = iConf.Fields
    'Set lfsFile1 = CreateObject("Scripting.FileSystemObject")
    With Flds
        .item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 'cdoSendUsingPort
         .item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
        .item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "YOUR.MAIL.SERVER"
        'Use SSL to connect to the SMTP server:
        .item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 10
        .Update
    End With

    If InStr(strAttachment2, ";") Then attList = Split(strAttachment2, ";")

    With iMsg
        Set .Configuration = iConf
        .To = strTo
        '.CC = strCC
        .FROM = strFrom
        .BCC = strBCC
        '.Subject = strSubject
        '.HTMLBody = strHTML
        '.TextBody = strMessage
        '.Nocoverpage: True
        '.confirmsend: true
        If InStr(strAttachment2, ";") Then
            For item = 1 To UBound(attList)
                .addAttachment (attList(item))
            Next
        Else
            If Not IsNull(strAttachment2) And Len(strAttachment2) > 0 Then .addAttachment strAttachment2
        End If
        .Send
    End With
    
    ' cleanup of variables
    Set iMsg = Nothing
    Set iConf = Nothing
    Set Flds = Nothing
End Sub

Function GetOutlookId(argId As String)
' -------------------------------------------------------------------------------------
' Resolve a specified full or partial Exchange user name and return the resolved unique
' name.
' -------------------------------------------------------------------------------------
    'Dim gobj_Outlook As Outlook.Application
    Dim objRecipient As Recipient
    Dim objMailItem As MailItem
    Dim strAddressElement() As String, strAddressId As String, strNameId As String, strNameElement() As String
    Dim lngDelayCount As Long, lngLimitDelay As Long
    
    'If a null name was passed, return an empty string.
    If IsNull(argId) Then
        GetOutlookId = ""
        Exit Function
    End If
    
    'Create a new Outlook mail object.
    Set objMailItem = gobj_Outlook.CreateItem(olMailItem)
    
    With objMailItem
        'Add the name as a recipient to the mail object, and attempt to resolve it.
        Set objRecipient = .Recipients.Add(argId)
        objRecipient.Resolve
        If Not objRecipient.Resolved Then
            'If name could not be resolved, return an empty string.
            GetOutlookId = ""
        Else
            'Split the name into two parts; the last part is the desired id.
            strAddressElement = Split(objRecipient.Address, "=")
            strAddressId = strAddressElement(UBound(strAddressElement))
            'Verify that id found matches fragment supplied, otherwise could cause problems
            'with people whose names have changed. If not, use the name found.
            If Left(strAddressId, Len(argId)) = argId Then
                'Return the found id.
                GetOutlookId = strAddressId
            Else
                'Extract the id from the resolved name.
                strNameElement = Split(objRecipient.Name, " ")
                If UBound(strNameElement) > 0 Then
                    'Construct an alternative id from the first initial and the last name.
                    strNameId = LCase(Left(strNameElement(UBound(strNameElement) - 1), 1) & strNameElement(UBound(strNameElement)))
                    'Verify that id found matches fragment supplied.
                    If Left(strNameId, Len(argId)) = argId Then
                        GetOutlookId = strNameId
                    Else
                        'No match, so revert to the original passed id.
                        GetOutlookId = argId
                    End If
                Else
                    'No match, so revert to the original passed id.
                    GetOutlookId = argId
                End If
            End If
        End If
    End With
    
    'Clean up resources used.
    Set objRecipient = Nothing
    Set objMailItem = Nothing
End Function