Új hozzászólás Aktív témák

• #46447 spe88 senior tag Pakliman #46446

  Új Válasz 2021-04-14 15:19:41 #46447

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  spe88

  senior tag

  válasz Pakliman #46446 üzenetére

  az enyém ilyen, de nem értem ott mi a baj. Igaz nem is értek hozzá túlzottan

  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 = 2 ' 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
' HTML tag's are not displayed properly in the post of MrExcel forum, thus replacing is used to fix this problem
HtmlBody = "Hello, (br)" _
& ".(br)" _
& "Proba."
HtmlBody = Replace(HtmlBody, "(", "<")
HtmlBody = Replace(HtmlBody, ")", ">")

  ' Set the font for the html-body (parentheses are just because of MrExcel posting limitation)
HtmlFont = HtmlFont = "(body font: " & 11 & "pt " & Arial & ";color:black"")"
HtmlFont = Replace(HtmlFont, "(", "<")
HtmlFont = Replace(HtmlFont, ")", ">")

  ' Define PDF filename
PdfFile = Range("'Report MOS'!L1")

  ' Replace illegal symbols in PdfFile by underscore
For Each char In Split("? "" / \ < > * | :")
PdfFile = Replace(PdfFile, char, "_")
Next

  ' Apply %TEMP% path to the file name and limit lenght of the pathname
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 activesheet 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("'Report MOS'!L1")
.To = Range("'Report MOS'!L2") ' <-- 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

Új hozzászólás Aktív témák