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
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