Macro: transfering bodytext from excel to e-mail problem

blaksnm

Well-known Member
Joined
Dec 15, 2009
Messages
554
Office Version
  1. 365
Platform
  1. Windows
Hi guys
See macro (Sub Faktura_Send) below save printarea as filename.pdf and attach this pdf to my e-mail (=ok). The problem is that the bodytext will not be copied to the mail e-.mail.

Alternative I would really find a way to format the e-mail as html and use default signature - this is tried in macro but fails

Sub Faktura_Send()
Dim SigString As String
Dim Signature As String

Calculate

If ActiveWindow.SelectedSheets.Count > 1 Then
MsgBox "Du har valgt å sende mer enn 1 ark, dette er ikke mulig," & vbNewLine & "Sjekk og velg kun ett ark for utskrift - og prøv igjen"
Else
FileName = RDB_Create_PDF(Range("FakturaUtskrift"), Range("CompleteFileName").Value, True, True)

If FileName <> "" Then

' Working in Office 2000-2013
Dim OutApp As Object
Dim OutMail As Object
Dim strbody1 As String

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

'strbody1 = Range("Emne").Value
On Error Resume Next

If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If


With OutMail
.Display
.To = Range("Epost").Value
.CC = Range("EpostMotakerKopi").Value
.BCC = ""
.Subject = Range("EPost_Emne").Value
.HTMLBody = strbody & "<H4><br>" & .HTMLBody
.HTMLBody = "<font style='color: black; font-family:Arial Narrow; font-size: 12pt;>" & "<br><font style='color: black; font-family:Arial Narrow; font-size: 12pt;'>" _
& "<br>" & Range("EPost_TekstLinje01").Value _
& "<br>" & Range("EPost_TekstLinje02").Value
.Attachments.Add (Range("CompleteFileName").Value)
'.Send

End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Else
MsgBox "Feil ved generering av PDF-filen." & vbNewLine & _
"Det kan skyldes èn av disse årsakene:" & vbNewLine & _
"1) Microsoft Add-in er ikke installert" & vbNewLine & _
"2) Du avbrøt LagreSom prosedyren" & vbNewLine & _
"3) Du prøver å lagre på en ugyldig fil-bane" & vbNewLine & _
"4) Du overlagret ikke (=avbrøt) den eksisterende utskriftsfilen"
End If
End If

Sheets("Faktura").Select

End Sub

Sub Mail_Outlook_With_Signature_Html_2()

' Don't forget to copy the function GetBoiler in the module.
' Working in Office 2000-2013
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim SigString As String
Dim Signature As String

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

strbody = "<font style='color: black; font-family:Arial Narrow; font-size: 12pt;>" & "<br><font style='color: black; font-family:Arial Narrow; font-size: 12pt;'>" _
& "<br>" & Range("EPost_TekstLinje1").Value _
& "<br>" & Range("EPost_TekstLinje2").Value _

'Change only Mysig.htm to the name of your signature
SigString = Environ("appdata") & "\Microsoft\Signaturer\grane.htm"

If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If

On Error Resume Next

With OutMail
.To = Range("Medlem_EpostMottakere").Value
.CC = Range("Medlem_EpostMotakerKopi").Value
.BCC = ""
.Subject = Range("Emne").Value
.HTMLBody = strbody & "<br>" & Signature
.Display

.Attachments.Add (Range("Medlem_CompleteFileName").Value)

End With

On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing

Range("FakturaNrKopi").Value = ""

End Sub

Function GetBoiler(ByVal sFile As String) As String
'**** Kusleika
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
 
Last edited:

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.

Forum statistics

Threads
1,213,489
Messages
6,113,947
Members
448,534
Latest member
benefuexx

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top