Email vanuit bepaald mail adres (mailbox) en logo

Set OutApp = CreateObject("Outlook.Application")
    

            Set OutMail = OutApp.CreateItem(0)
            On Error Resume Next
            With OutMail
                
                .SentOnBehalfOfName = "email@adres.nl"
                .bcc = strto
                .Subject = "List " & Range("a3") & " en " & Range("a3") + 1
                .body = ""
                
                Open "c:\users\" & Environ("username") & "\appdata\roaming\Microsoft\Handtekeningen\mysig.htm" For Input As #1
                .htmlbody = StrBody & RangetoHTML(rng) & "<br><br>" & Input(LOF(1), #1)
                Close #1
                
                .display  
            End With
            On Error GoTo 0
            Set OutMail = Nothing
        
cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub

Sub hsv()
Dim strbody As String, mailaccount, objOutlook As Object, objOutlookAccount As Object
  Set objOutlook = CreateObject("Outlook.Application")
  Set objOutlookAccount = GetOutlookAccount(objOutlook, [COLOR=#ff0000]"email@adres.nl"[/COLOR])
  With objOutlook.createitem(0)
    Set .sendusingaccount = objOutlookAccount
        .Bcc = [COLOR=#ff0000]"zomaariemand@gmail.com"[/COLOR]
        .Subject = "Onderwerp"
        .body = "De groeten van @hsv"
        .display
 End With
End Sub


Function GetOutlookAccount(objOutlook As Object, strEmailId As String) As Object
Dim objOAccount As Object
    For Each objOAccount In objOutlook.Session.Accounts
     If objOAccount.DisplayName = strEmailId Then
       Set GetOutlookAccount = objOAccount
       Exit For
     End If
    Next objOAccount
End Function

Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm

rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    ' Publish the sheet to an .htm file.
        With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
 
    ' Read all data from the .htm file into the RangetoHTML subroutine.
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
 
    ' Close TempWB.
    TempWB.Close savechanges:=False
 
    ' Delete the htm file.
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Function GetOutlookAccount(objOutlook As Object, strEmailId As String) As Object
Dim objOAccount As Object
For Each objOAccount In objOutlook.Session.Accounts
If objOAccount.DisplayName = strEmailId Then
Set GetOutlookAccount = objOAccount
Exit For
End If
Next objOAccount
End Function

Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function

Sub Create_Mail_From_List()
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim cell As Range
Dim strto As String
Dim strbody As String
Dim SigString As String
Dim mailaccount As Object
Dim objOutlook As Object
Dim objoutlookaccount As Object  


‘Bepalen e-mailadressenlijst 
    For Each cell In ThisWorkbook.Sheets("blad2").Range("e2:e25")
    If cell.Value Like "?*@?*.?*" Then
        strto = strto & cell.Value & ";"
    End If
Next cell
If Len(strto) > 0 Then strto = Left(strto, Len(strto) - 1)
    Application.ScreenUpdating = False
    Set rng = Nothing
    On Error Resume Next

‘Bepalen te mailen range
    Set rng = Sheets("blad1").Range("a2:D41").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    If rng Is Nothing Then
        MsgBox "De selectie is geen range, of het blad is beveiligd. " & _
               vbNewLine & "Controleer en probeer opnieuw.", vbOKOnly
        Exit Sub
    End If

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

‘Email tekst maken in lettertype Calibri, grootte 11
  strbody = "<BODY style=font-size:11pt;font-family:Calibri>Hallo allemaal," & "<br><br>" & _
            "Hierbij het overzicht van afgelopen week.</BODY>"

‘Bepalen handtekening
  SigString = Environ("appdata") & _
                "\Microsoft\Signatures\mysign.htm"

    'Change only Mysig.htm to the name of your signature
    'de map signatures heet soms handtekeningen
    SigString = Environ("appdata") & _
                "\Microsoft\Handtekeningen\mysign.htm"
    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If
    On Error Resume Next

‘Outlook openen
                Set objOutlook = CreateObject("Outlook.Application")
                Set objoutlookaccount = GetOutlookAccount(objOutlook, "scheidsrechters@obw.nl")
                With objOutlook.CreateItem(0)
                Set .sendusingaccount = objoutlookaccount
                .display
                .BCC = strto
                .Subject = "Overzicht”
                .HTMLbody = strbody & RangetoHTML(rng) & .HTMLbody
                .display  
       'Or use send om de mail direct te versturen/ in outbox te plaatsen.
            End With
            On Error GoTo 0
            Set OutMail = Nothing
cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub