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

Zaslat odpověď >

Nebyly zaslány žádné odpovědi.

Uživatelské menu

Nejste přihlášen(a)

Formulář Faktura

Formulář Faktura IV

Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.

Helios iNuvio

Používáte podnikový systém Helios iNuvio? Potřebujete pomoci se správou nebo vyvinout SQL proceduru? Více informací naleznete na stránce Helios iNuvio.