• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Mail versturen vanuit excel met opmaak

Status
Niet open voor verdere reacties.

luibak

Gebruiker
Lid geworden
20 sep 2011
Berichten
73
Beste forum gebruikers.

Ik zit met het probleem dat we op mijn werk automatisch email willen maken vanuit een adressen lijst.
Via de onderstaande code worden de mail gemaakt. Tot zo ver gaat het goed maar nu zouden we graag ook opmaak in de tekst krijgen.

Ik heb veelvuldig gezocht naar manieren, zo ben ik tegen gekomen dat dit via htmlbody kan maar telkens als ik iets uitprobeer loopt er iets anders vast.

Tevens nog een vraag is het ook mogelijk om via deze code ook de standaard handtekening erin te krijgen.

Alvast bedankt

PS de echte tekst is nog veel langer zo'n 30-40 regels totaal

Code:
Sub aanvragen_LEV_OA()
' Working in Office 2000-2010 MWE
    
    Application.ScreenUpdating = False
    Sheets("Blad1").Visible = True
    ActiveWorkbook.Worksheets("Overzicht inkoop calc.").AutoFilter.Sort.SortFields. _
        Clear
    ActiveSheet.Range("$A$14:$AC$422").AutoFilter Field:=2, Criteria1:="<>"
    ActiveSheet.ShowAllData
    Columns("AH:AH").Select
        Selection.Copy
    Columns("AI:AI").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    Columns("V:V").Select
    Selection.Copy
    Columns("AK:AK").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
        
    Application.ScreenUpdating = False
     
    Set OutApp = CreateObject("Outlook.Application")
        
 
    On Error GoTo cleanup
    For Each cell In Columns("AI").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" And _
           LCase(Cells(cell.Row, "U").Value) = "1" Then

            Set OutMail = OutApp.CreateItem(0)
            On Error Resume Next
            With OutMail
                .To = cell.Value
                .Subject = "Offerteaanvraag " & Sheets("Calculatie info").Range("B3").Value
                .body = "Geachte " & Cells(cell.Row, "AK").Value & (",") & vbCrLf & vbNewLine & _
              "Hierbij verzoeken wij u zo spoedig mogelijk doch uiterlijk " & Sheets("Overzicht inkoop calc.").Range("N11").Value & vbNewLine & _
              "This is line 2" & vbNewLine & _
              "This is line 3" & vbNewLine & _
              "This is line 4"
                
                .Attachments.Add Sheets("blad1").Range("A2").Value
                .Attachments.Add
                
                .Display  'Or use Send
            End With
            On Error GoTo 0
            Set OutMail = Nothing
        End If
    Next cell

cleanup:
    Set OutApp = Nothing
    
    Range("U15:U500").Select
    'Selection.ClearContents
    Range("R20").Select
    Sheets("Blad1").Visible = False
    Application.ScreenUpdating = True

End Sub
 
Status
Niet open voor verdere reacties.
Terug
Bovenaan Onderaan