MS Excel
Téma: Outlook email - přidání více příloh 
Zaslal/a Fantasyk 18.7.2023 13:23
Zdravím,
potřeboval bych poradit s přidáním více příloh do emailu.
Mám makro ve kterém posílám z listu "active" to mi funguje, ale potřeboval bych posílat ještě jeden soubor se stejnou Range, ale z listu REPORT_EN
Sub mailAscreen()
Dim OutApp As Object 'Outlook.Application
Dim OutMail As Object 'Outlook.MailItem
Dim OutAttachment As Object 'Outlook.Attachment
Dim OutPropertyAcc As Object 'Outlook.PropertyAccessor
Dim SendTo As String
Dim CC As String
Dim Subject As String
Dim ExcelCells As Range
Dim ExcelCells_EN As Range
Dim HTML As String
Dim CellsImage As String, tempCellsFile As String
Dim answer As Integer
Dim shift1 As String
Dim shift2 As String
Dim shiftall As String
answer = MsgBox("Opravdu chceš odeslat report smeny?", vbQuestion + vbYesNo + vbDefaultButton2, "Odeslání Reportu smeny")
If answer = vbYes Then
On Error GoTo bugy
Range("T11").Comment.Visible = True
Range("T11").Comment.Shape.Select True
Selection.ShapeRange.IncrementLeft -12#
Selection.ShapeRange.IncrementTop -145.25
bugy:
On Error GoTo bugy2
Range("L11").Comment.Visible = True
Range("L11").Comment.Shape.Select True
Selection.ShapeRange.IncrementLeft -12#
Selection.ShapeRange.IncrementTop -145.25
bugy2:
shift1 = Range("F12").Value2
shift1 = Format(shift1, "0.00%")
shift2 = Range("N12").Value
shift2 = Format(shift2, "0.00%")
shiftall = Range("AE3").Value
shiftall = Format(shiftall, "0.00%")
Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"
Active = ActiveSheet.Name
Set ExcelCells = ThisWorkbook.Worksheets(Active).Range("A1:AF166") 'range includes cells and charts
Set ExcelCells_EN = ThisWorkbook.Worksheets("REPORT_EN").Range("A1:AF166") 'range includes cells and charts
SendTo = "ahoj@ahoj.com"
CC = "hello@hello.com"
Subject = "Report smeny - (" & Range("AA2").Value & ") -" & Range("V2").Value & " Denní: " & shift1 & " / Nocní " & shift2 & " / Total: " & shiftall
CellsImage = Replace(Timer, ".", "") & "image.jpg"
tempCellsFile = Environ("temp") & "\" & CellsImage
Save_Object_As_Picture ExcelCells, tempCellsFile
'Construct email body as HTML string, with the range image in an img tag with corresponding src='cid:xxxx.jpg' attribute
HTML = "<html>"
'HTML = HTML & "<a href=""http://www.seznam.cz"">seznam.cz</a>"
HTML = HTML & "<img src='cid:" & CellsImage & "'>"
HTML = HTML & "</html>"
Set OutApp = CreateObject("Outlook.Application") 'New Outlook.Application
Set OutMail = OutApp.CreateItem(0) 'olMailItem
With OutMail
.To = SendTo
.CC = CC
.Subject = Subject
' pridání prílohy
.Attachments.Add tempCellsFile, olByValue, 1, ""
Set OutAttachment = .Attachments.Add(tempCellsFile)
Set OutPropertyAcc = OutAttachment.PropertyAccessor
OutPropertyAcc.SetProperty PR_ATTACH_CONTENT_ID, CellsImage
.HTMLBody = HTML
' .send
.Display
End With
'Delete the temporary image file
Kill tempCellsFile
Set OutMail = Nothing
Set OutApp = Nothing
End If
For Each C In ActiveSheet.Comments
C.Visible = False
Next
ThisWorkbook.Application.Caption = " poslední odeslaný report: " & Date & " - " & Time
End Sub
Private Sub Save_Object_As_Picture(saveObject As Object, imageFileName As String)
Dim temporaryChart As ChartObject
Application.ScreenUpdating = False
saveObject.CopyPicture xlScreen, xlPicture
Set temporaryChart = ActiveSheet.ChartObjects.Add(0, 0, saveObject.Width, saveObject.Height)
With temporaryChart
.Activate
.Border.LineStyle = xlLineStyleNone 'No border
.Chart.Paste
.Chart.Export imageFileName
.Delete
End With
Application.ScreenUpdating = True
Set temporaryChart = Nothing
End Sub
Díky za radu
Uživatelské menu
\nMenu
On-line nástroje
Formulář Faktura
Formulář Faktura IV
Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.
RSS nejnovější články