Outlook e-mails automatisch versturen zonder toestemming te geven

    Set OL = CreateObject("outlook.application")

    Set bericht = OL.CreateItem(olMailItem)
    
    With bericht

        .Subject = "ONDERWERP”

        .HTMLBody = “HTML BERICHT”

        .Recipients.Add e-mail@hotmail.com

        .Send

    End With

Sub Office365_Email_Test()
    Dim objMessage, objConfig, fields
    Set objMessage = New CDO.Message
    Set objConfig = New CDO.Configuration
    Set fields = objConfig.fields
    With fields
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.office365.com"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "username@office365.com"
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "Office365Password"
        '.Item("http://schemas.microsoft.com/cdo/configuration/sendtls") = True
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
        .Update
    End With
    Set objMessage.Configuration = objConfig
    
    With objMessage
        .Subject = "Test Message"
        .From = "username@office365.com"
        .To = "someone@somedomain.com"
        .HTMLBody = "Test Message"
    End With
    objMessage.Send
End Sub

Public Function FnSendMailSafe(strTo As String, strCC As String, strBCC As String, strSubject As String, _
    strMessageBody As String, Optional strAttachments As String) As Boolean

' Simply sends an e-mail using Outlook/Simple MAPI.
' Calling this function by Automation will prevent the warnings
' A program is trying to send a mesage on your behalf...'
' Also features optional HTML message body and attachments by file path.
'
' The To/CC/BCC/Attachments function parameters can contain multiple items by seperating
' them by a semicolon. (e.g. for the strTo parameter, 'test@test.com; test2@test.com' is
' acceptable for sending to multiple recipients.
'
' (c) 2005 Wayne Phillips - Written 07/05/2005
' Last updated 26/03/2008 - Bugfix for empty varRecipient strings
' http://www.everythingaccess.com

On Error GoTo ErrorHandler:

Dim MAPISession As Outlook.NameSpace
Dim MAPIFolder As Outlook.MAPIFolder
Dim MAPIMailItem As Outlook.MailItem
Dim oRecipient As Outlook.Recipient
Dim TempArray() As String
Dim varArrayItem As Variant
Dim strEmailAddress As String
Dim strAttachmentPath As String
Dim blnSuccessful As Boolean

    'Get the MAPI NameSpace object
    Set MAPISession = Application.Session

    If Not MAPISession Is Nothing Then
        'Logon to the MAPI session
        MAPISession.Logon , , True, False
        'Create a pointer to the Outbox folder
        Set MAPIFolder = MAPISession.GetDefaultFolder(olFolderOutbox)
        If Not MAPIFolder Is Nothing Then
            'Create a new mail item in the "Outbox" folder
            Set MAPIMailItem = MAPIFolder.Items.Add(olMailItem)
            If Not MAPIMailItem Is Nothing Then
                With MAPIMailItem
                    'Create the recipients TO
                    TempArray = Split(strTo, ";")
                    For Each varArrayItem In TempArray
                        strEmailAddress = Trim(varArrayItem)
                        If Len(strEmailAddress) > 0 Then
                            Set oRecipient = .Recipients.Add(strEmailAddress)
                            oRecipient.Type = olTo
                            Set oRecipient = Nothing
                        End If
                    Next varArrayItem
                    'Create the recipients CC
                    TempArray = Split(strCC, ";")
                    For Each varArrayItem In TempArray
                        strEmailAddress = Trim(varArrayItem)
                        If Len(strEmailAddress) > 0 Then
                            Set oRecipient = .Recipients.Add(strEmailAddress)
                            oRecipient.Type = olCC
                            Set oRecipient = Nothing
                        End If
                    Next varArrayItem
                    'Create the recipients BCC
                    TempArray = Split(strBCC, ";")
                    For Each varArrayItem In TempArray
                        strEmailAddress = Trim(varArrayItem)
                        If Len(strEmailAddress) > 0 Then
                            Set oRecipient = .Recipients.Add(strEmailAddress)
                            oRecipient.Type = olBCC
                            Set oRecipient = Nothing
                        End If
                    Next varArrayItem
                    'Set the message SUBJECT
                    .Subject = strSubject
                    'Set the message BODY (HTML or plain text)
                    If StrComp(Left(strMessageBody, 6), "<HTML>", vbTextCompare) = 0 Then
                        .HTMLBody = strMessageBody
                    Else
                        .Body = strMessageBody
                    End If
                    'Add any specified attachments
                    TempArray = Split(strAttachments, ";")
                    For Each varArrayItem In TempArray
                        strAttachmentPath = Trim(varArrayItem)
                            If Len(strAttachmentPath) > 0 Then
                            .Attachments.Add strAttachmentPath
                            End If
                    Next varArrayItem
                    .Send 'No return value since the message will remain in the outbox if it fails to send
                    Set MAPIMailItem = Nothing
                End With
            End If
            Set MAPIFolder = Nothing
        End If
        MAPISession.Logoff
    End If

    'If we got to here, then we shall assume everything went ok.
    blnSuccessful = True

ExitRoutine:
    Set MAPISession = Nothing
    FnSendMailSafe = blnSuccessful

    Exit Function

ErrorHandler:
    MsgBox "An error has occured in the user defined Outlook VBA function FnSendMailSafe()" & vbCrLf & vbCrLf & _
            "Error Number: " & CStr(Err.Number) & vbCrLf & _
            "Error Description: " & Err.Description, vbApplicationModal + vbCritical
    Resume ExitRoutine

End Function