Ismét kéne egy kis segítség. Van egy PDF-küldős makróm.
Az alábbi pontokkal szembesülök.
1. Az A1 cellában egy hiperhivatkozás van. A PDF-ben ez nem jelenik meg, csak mint szöveg látom.
2. Az Outlook-üzenet első sora nem "Hallo Kollegen" ahogy megadtam, hanem "FalseHallo Kollegen"
2. Az e-mail törzsben az első sor ( "FalseHallo Kollegen") az Times New Roman 12-es betűméret, míg a 2-3. sor 9-es betűméret Calibri.
Megadtam milyen legyen a betűtípus a makróban és mégsem olyan. Illetve alapból Arial 10-es a betűtípus az e-mail-írásnál, szóval nem értem miért változtatja random Times New Romanra meg Calibrire.
Köszönöm
A makró:
Sub SendPDF_WithAccountSignatiure()
' --> User settings, change to suit
Const IsDisplay As Boolean = True ' Change to False for .Send instead of .Display
Const IsSilent As Boolean = False ' Change to True to show Send status
Const FontName = "Arial" ' Font name of the email body
Const FontSize = 11 ' Font size of the email body
Const Account = 1 ' Index or Name of the account to send from
' <-- End of the settings
Dim IsCreated As Boolean
Dim OutlApp As Object
Dim char As Variant
Dim PdfFile As String, HtmlFont As String, HtmlBody As String, HtmlSignature As String
' Edit the body's html text as required
' The tags are: h3 is for Header#3; b is for Bold; br is for line break
HtmlBody = "Hallo Kollegen, <br>" _
& "<br>" _
& "Im Anhang sehen Sie die aktuelle PIP-Liste von BOS MOS."
' Set the font for the html-body (parentheses are just because of MrExcel posting limitation)
HtmlFont = HtmlFont = "<body font: " & 11 & "pt " & Arial & ";color:black"">"
' Define PDF filename
PdfFile = Range("'help_MOS'!an1")
' Replace illegal symbols in PdfFile by underscore
For Each char In Split("? "" / \ < > * | :")
PdfFile = Replace(PdfFile, char, "_")
Next
' Apply %TEMP% path to the file name
PdfFile = Environ("F:\03_PROJEKTE\02_BOS\2.4 SERIENBETREUUNG") & PdfFile & ".pdf"
' Try to delete PDF file if present
If Len(Dir(PdfFile)) Then Kill PdfFile
' Export the specific worksheet as PDF
With Worksheets("Report MOS")
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With
' Use the already open Outlook if possible
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
OutlApp.Visible = True
On Error GoTo 0
' Prepare email with PDF attachment and the default signature
With OutlApp.CreateItem(0)
' Set HTML format
.BodyFormat = 2
' Add the attachment first for correct attachment's name with non English symbols
.Attachments.Add PdfFile
' Set the required account by const Account
Set .SendUsingAccount = OutlApp.Session.Accounts.Item(Account)
' Get default email signature without blinking (instead of .Display method)
With .GetInspector: End With
HtmlSignature = .HtmlBody
' Prepare e-mail
.Subject = Range("'help_MOS'!an1")
.To = Range("'help_MOS'!an2") ' <-- Put email of the recipient here
.HtmlBody = HtmlFont & HtmlBody & HtmlSignature
' Try to send or just display the e-mail
On Error Resume Next
If IsDisplay Then .Display Else .Send
' Show error of the .Send method
If Not IsDisplay Then
' Return focus to Excel's window
Application.Visible = True
' Show error/success message
If Err Then
MsgBox "E-mail was not sent for some reasons" & vbLf & "Please check it", vbExclamation
.Display
Else
If Not IsSilent Then
MsgBox "E-mail successfully sent", vbInformation
End If
End If
End If
On Error GoTo 0
End With
' Try to quit Outlook if it was not previously open
If IsCreated Then OutlApp.Quit
' Try to release the memory of object variable
Set OutlApp = Nothing
End Sub
Fototrend
Fferi50