Pokud data z emailu nekopíruješ tak to jde vložit přes JPG
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 HTML As String
Dim CellsImage As String, tempCellsFile As String
Dim answer As Integer
answer = MsgBox("Opravdu chceš odeslat email?", vbQuestion + vbYesNo + vbDefaultButton2, "Opravdu chceš odeslat email?")
If answer = vbYes Then
Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"
Active = ActiveSheet.Name
Set ExcelCells = ThisWorkbook.Worksheets(Active).Range("A1:AC152")
SendTo = "email@email.com"
Subject = "Předmět emailu"
CellsImage = Replace(Timer, ".", "") & "image.jpg"
tempCellsFile = Environ("temp") & "\" & CellsImage
Save_Object_As_Picture ExcelCells, tempCellsFile
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
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
+ to odešle JPG jako přílohucitovat
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 HTML As String
Dim CellsImage As String, tempCellsFile As String
Dim answer As Integer
answer = MsgBox("Opravdu chceš odeslat email?", vbQuestion + vbYesNo + vbDefaultButton2, "Opravdu chceš odeslat email?")
If answer = vbYes Then
Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"
Active = ActiveSheet.Name
Set ExcelCells = ThisWorkbook.Worksheets(Active).Range("A1:AC152")
SendTo = "email@email.com"
Subject = "Předmět emailu"
CellsImage = Replace(Timer, ".", "") & "image.jpg"
tempCellsFile = Environ("temp") & "\" & CellsImage
Save_Object_As_Picture ExcelCells, tempCellsFile
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
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
+ to odešle JPG jako přílohucitovat
RSS nejnovější články