blaksnm
Well-known Member
- Joined
- Dec 15, 2009
- Messages
- 554
- Office Version
- 365
- Platform
- 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
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: