嵌入的图像未显示在电子邮件中 VBA
Embedded image not showing on email VBA
我有一些发送电子邮件的代码,但嵌入的图像显示为红色 "X"。
对 C19 的引用是 "Image.png"(此文件名根据其他数据不断变化)和文件名。
前 2 个宏将文件保存到下载文件夹,第 3 个宏当前正在输出红色 "X"。
Sub CandidCamera()
Sheets("Total Hours Check").Range("M5").AutoFilter Field:=2, Criteria1:="<>"
If Sheets("Total Hours Check").Range("N6") > 0 Then
Call CapturePivottable
Else
MsgBox "No High Hours Reported"
Exit Sub
End If
End Sub
Private Sub CapturePivottable()
Dim si As Excel.SlicerItem, siDummy As Excel.SlicerItem
Dim pt As Excel.PivotTable
Dim co As Excel.ChartObject
Dim wsBlank As Excel.Worksheet
Set pt = Sheets("Total Hours Check").PivotTables(1)
' add a blank sheet to get a blank Chart instead of PivotChart later
Set wsBlank = ActiveWorkbook.Sheets.Add
With pt.TableRange2 ' or TableRange1
.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Set co = wsBlank.ChartObjects.Add(1, 1, .Width, .Height)
co.Select
co.Chart.Paste
co.Chart.Export _
Filename:=Environ("USERPROFILE") & "\Downloads\" & Sheets("Private").Range("B7").Value & ".png", filtername:="PNG"
co.Delete
End With
Call Email
Application.DisplayAlerts = False
wsBlank.Delete
Application.DisplayAlerts = True
End Sub
Sub Email()
'Sends the last saved version of the Activeworkbook
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = Worksheets("Private").Range("A19").Value
.CC = "email1@gmail.com; "
'.BCC = ""
.Subject = Worksheets("Private").Range("H29").Value
'.Body =
.Attachments.Add ActiveWorkbook.FullName
.Attachments.Add Filepath, olByValue, 1
Filepath = Environ("USERPROFILE") & "\Downloads\" & Filename
Filename = Sheets("Private").Range("C19").Value
.HTMLBody = "<img src=cid:Filename></img>"
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Filename = Sheets("Private").Range("A19")
Filepath = Environ("USERPROFILE") & "\Downloads\" & Filename
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set colattach = OutMail.Attachments
Set oAttach = colattach.Add(Filepath)
Set olkPA = oAttach.PropertyAccessor
Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"
'--- Rest of code
.HTMLBody = "<IMG src =""cid:Filename"">"
'--- Rest of code
问题在于 HTML Body 语句。我添加了引号,现在可以正确嵌入了。
Sub Email()
'Sends the last saved version of the Activeworkbook
Dim OutApp As Object
Dim OutMail As Object
Dim Filepath As String
Dim Filename As String
Filename = Sheets("Private").Range("C19").Value
Filepath = Environ("USERPROFILE") & "\Downloads\" & Filename
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = Worksheets("Private").Range("A19").Value
'.BCC =
.Subject = Worksheets("Private").Range("H29").Value
'.Body =
.Attachments.Add ActiveWorkbook.FullName
.Attachments.Add Filepath, olByValue, 0
'Change "1" value to 0 to hide
.HTMLBody = "<img src=""" & Filepath & """>"
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
我有一些发送电子邮件的代码,但嵌入的图像显示为红色 "X"。 对 C19 的引用是 "Image.png"(此文件名根据其他数据不断变化)和文件名。
前 2 个宏将文件保存到下载文件夹,第 3 个宏当前正在输出红色 "X"。
Sub CandidCamera()
Sheets("Total Hours Check").Range("M5").AutoFilter Field:=2, Criteria1:="<>"
If Sheets("Total Hours Check").Range("N6") > 0 Then
Call CapturePivottable
Else
MsgBox "No High Hours Reported"
Exit Sub
End If
End Sub
Private Sub CapturePivottable()
Dim si As Excel.SlicerItem, siDummy As Excel.SlicerItem
Dim pt As Excel.PivotTable
Dim co As Excel.ChartObject
Dim wsBlank As Excel.Worksheet
Set pt = Sheets("Total Hours Check").PivotTables(1)
' add a blank sheet to get a blank Chart instead of PivotChart later
Set wsBlank = ActiveWorkbook.Sheets.Add
With pt.TableRange2 ' or TableRange1
.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Set co = wsBlank.ChartObjects.Add(1, 1, .Width, .Height)
co.Select
co.Chart.Paste
co.Chart.Export _
Filename:=Environ("USERPROFILE") & "\Downloads\" & Sheets("Private").Range("B7").Value & ".png", filtername:="PNG"
co.Delete
End With
Call Email
Application.DisplayAlerts = False
wsBlank.Delete
Application.DisplayAlerts = True
End Sub
Sub Email()
'Sends the last saved version of the Activeworkbook
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = Worksheets("Private").Range("A19").Value
.CC = "email1@gmail.com; "
'.BCC = ""
.Subject = Worksheets("Private").Range("H29").Value
'.Body =
.Attachments.Add ActiveWorkbook.FullName
.Attachments.Add Filepath, olByValue, 1
Filepath = Environ("USERPROFILE") & "\Downloads\" & Filename
Filename = Sheets("Private").Range("C19").Value
.HTMLBody = "<img src=cid:Filename></img>"
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Filename = Sheets("Private").Range("A19")
Filepath = Environ("USERPROFILE") & "\Downloads\" & Filename
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set colattach = OutMail.Attachments
Set oAttach = colattach.Add(Filepath)
Set olkPA = oAttach.PropertyAccessor
Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"
'--- Rest of code
.HTMLBody = "<IMG src =""cid:Filename"">"
'--- Rest of code
问题在于 HTML Body 语句。我添加了引号,现在可以正确嵌入了。
Sub Email()
'Sends the last saved version of the Activeworkbook
Dim OutApp As Object
Dim OutMail As Object
Dim Filepath As String
Dim Filename As String
Filename = Sheets("Private").Range("C19").Value
Filepath = Environ("USERPROFILE") & "\Downloads\" & Filename
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = Worksheets("Private").Range("A19").Value
'.BCC =
.Subject = Worksheets("Private").Range("H29").Value
'.Body =
.Attachments.Add ActiveWorkbook.FullName
.Attachments.Add Filepath, olByValue, 0
'Change "1" value to 0 to hide
.HTMLBody = "<img src=""" & Filepath & """>"
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub