VBA - 从工作表复制单元格到Outlook电子邮件

问题描述：

我是VBA的新手，并创建了以下用于发送电子邮件的代码。我的问题是我如何从我目前使用的excel表格中复制一些单元格粘贴到excel文件中？VBA - 从工作表复制单元格到Outlook电子邮件

感谢，

Sub CIR_Save_Email() 

Dim objoutlook As Object 
Set objoutlook = CreateObject("outlook.application") 

Dim objemail As Object 
Set objemail = objoutlook.createitem(olmailitem) 
Const olFormatHTML As Long = 2 

emailbodymessage = "<HTML><BODY>Hi Team," & _ 
"<br><br>Attached is the Display's CIR for today<br><br>" & _ 
"<b>Brief overview of CIR</b><br><br>" & _ 
"<b>Purpose:</b> To get a snapshot of what your current inventory levels by SKU are every day." & _ 
"<ul style=""list-style-type:circle"">" & _ 
    "<li><b>Unrestricted QTY</b> The total inventory at that DC (i.e.Deliveries Created + Available Qty)</li>" & _ 
    "<li><b>Deliveries Created:</b> Orders that are being processing at that DC (i.e. they will NOT be included in Available Inventory)</li>" & _ 
    "<li><b>Available:</b> How many cases are available to use at that DC </li>" & _ 
    "<li><b>Avail DOS:</b> How many DOS the available cases equate to</li>" & _ 
"<li><b>IT QTY:</b> How man cases are in transit</li>" & _ 
"<li><b>Avail +IT DOS:</b> How many DOS the available cases equate to</li>" & _ 
"</ul> </body> </html>" 

emailbodymessage2 = "<html><body><ul style=""list-style-type:circle"">" & _ 
"<li><b>Future Available:</b> The total DOS of cases Avail + IT</li>" & _ 
"<li><b>QI QTY:</b> How many cases are on Qualitiy (ie Non-Conformance)</li>" & _ 
"<li><b>Blocked QTY:</b> How many cases are blocked from ordering due to damages, short dating, expired, etc." & _ 
"<li><b>CM- months:</b> The forecasts of the months past (CM-1=July)</li>" & _ 
"<li><b>% to Fcst:</b> How much of your projected forecast has shipped this month</li>" & _ 
"<li><b>Current SNAP Fcst:</b> This month's projected forecast</li>" & _ 
"<li><b>CM+ months:</b> The forecasts of the months moving forward (CM+1= September)</li>" & _ 
"</ul> </body></html>" 

With objemail 
    .To = emaillist 
     .cc = "" 
    .Subject = "Display's CIR " & Date 
    .BodyFormat = olFormatHTML '// 2 
.HTMLBody = emailbodymessage & emailbodymessage2 

.display 

End With 

End Sub

你问如何插入电子邮件体内一些额外的内容？顺便说一句，你的两个HTML片段都有完整的开放/关闭标签（即每个HTML片段都是一个完整的HTML“页面”） - 你只需要一组开始和一组关闭'html'和'body'标签） –

是的，我是试着找出如何将工作表中复制的单元格添加到消息正文中。感谢您对HTML标签的输入！ –

您需要更详细地解释一下您需要包括的内容：整个范围？多大？或者只是个人价值观？邮件中需要去哪里？ –

答

您可以使用下面的函数（内部使用的出口范围为HTML），以Excel范围转换成HTML。然后生成的HTML应该包含到您生成的HTML主体中。

该函数正在将Range导出为HTML临时创建的文件，然后将内容仅剥离为div（不包括HTML标签）。

但是，我不确定格式和其他细节是否符合您的要求。其他解决方案是手动构建单元格中的HTML，但它要做得更多。

用法：str = GetHtml("Sheet1","D4:E6")

Public Function GetHtml(ByVal sheetName As String, ByVal rangeName As String) As String 
Dim fso As FileSystemObject 
Dim fileName As String 
Dim txtStream As TextStream 
Dim html As String 
Dim line As String 
Dim readLines As Boolean 

Set fso = New FileSystemObject 

Dim rng As range 
fileName = fso.GetSpecialFolder(2) & "\" & Replace(fso.GetTempName, ".tmp", ".html") 
If fso.FileExists(fileName) Then 
    fso.DeleteFile fileName 
End If 

Set rng = Sheets(sheetName).range(rangeName) 

ActiveWorkbook.PublishObjects.Add(SourceType:=xlSourceRange, fileName:=fileName, Sheet:=rng.Worksheet.Name, Source:=rng.Address, HtmlType:=xlHtmlStatic).Publish 
Set txtStream = fso.OpenTextFile(fileName, ForReading, False) 

readLines = False 
html = "" 
Do While Not txtStream.AtEndOfStream 
    line = txtStream.ReadLine 
    If InStr(line, "<!--START OF OUTPUT FROM EXCEL PUBLISH AS WEB PAGE WIZARD") > 0 Then 
     readLines = True 
    End If 
    If readLines Then 
     html = html & vbCrLf & line 
    End If 
    If readLines And InStr(line, "<!--END OF OUTPUT FROM EXCEL PUBLISH AS WEB PAGE WIZARD") > 0 Then 
     readLines = False 
    End If 
Loop 
txtStream.Close 
Set txtStream = Nothing 

If fso.FileExists(fileName) Then 
    fso.DeleteFile fileName 
End If 
Set fso = Nothing 

GetHtml = html 

End Function

答

你说你想“复制我目前使用Excel文件中要粘贴从我的Excel工作表中的一些细胞”。我认为你从Excel复制并粘贴到电子邮件的正文中。

Sub Mail_Selection_Range_Outlook_Body() 
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm 
'Don't forget to copy the function RangetoHTML in the module. 
'Working in Excel 2000-2016 
    Dim rng As Range 
    Dim OutApp As Object 
    Dim OutMail As Object 

    Set rng = Nothing 
    On Error Resume Next 
    'Only the visible cells in the selection 
    Set rng = Selection.SpecialCells(xlCellTypeVisible) 
    'You can also use a fixed range if you want 
    'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible) 
    On Error GoTo 0 

    If rng Is Nothing Then 
     MsgBox "The selection is not a range or the sheet is protected" & _ 
       vbNewLine & "please correct and try again.", vbOKOnly 
     Exit Sub 
    End If 

    With Application 
     .EnableEvents = False 
     .ScreenUpdating = False 
    End With 

    Set OutApp = CreateObject("Outlook.Application") 
    Set OutMail = OutApp.CreateItem(0) 

    On Error Resume Next 
    With OutMail 
     .To = "[email protected]" 
     .CC = "" 
     .BCC = "" 
     .Subject = "This is the Subject line" 
     .HTMLBody = RangetoHTML(rng) 
     .Send 'or use .Display 
    End With 
    On Error GoTo 0 

    With Application 
     .EnableEvents = True 
     .ScreenUpdating = True 
    End With 

    Set OutMail = Nothing 
    Set OutApp = Nothing 
End Sub 


Function RangetoHTML(rng As Range) 
' Changed by Ron de Bruin 28-Oct-2006 
' Working in Office 2000-2016 
    Dim fso As Object 
    Dim ts As Object 
    Dim TempFile As String 
    Dim TempWB As Workbook 

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm" 

    'Copy the range and create a new workbook to past the data in 
    rng.Copy 
    Set TempWB = Workbooks.Add(1) 
    With TempWB.Sheets(1) 
     .Cells(1).PasteSpecial Paste:=8 
     .Cells(1).PasteSpecial xlPasteValues, , False, False 
     .Cells(1).PasteSpecial xlPasteFormats, , False, False 
     .Cells(1).Select 
     Application.CutCopyMode = False 
     On Error Resume Next 
     .DrawingObjects.Visible = True 
     .DrawingObjects.Delete 
     On Error GoTo 0 
    End With 

    'Publish the sheet to a htm file 
    With TempWB.PublishObjects.Add(_ 
     SourceType:=xlSourceRange, _ 
     Filename:=TempFile, _ 
     Sheet:=TempWB.Sheets(1).Name, _ 
     Source:=TempWB.Sheets(1).UsedRange.Address, _ 
     HtmlType:=xlHtmlStatic) 
     .Publish (True) 
    End With 

    'Read all data from the htm file into RangetoHTML 
    Set fso = CreateObject("Scripting.FileSystemObject") 
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2) 
    RangetoHTML = ts.readall 
    ts.Close 
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _ 
          "align=left x:publishsource=") 

    'Close TempWB 
    TempWB.Close savechanges:=False 

    'Delete the htm file we used in this function 
    Kill TempFile 

    Set ts = Nothing 
    Set fso = Nothing 
    Set TempWB = Nothing 
End Function

https://www.rondebruin.nl/win/s1/outlook/bmail2.htm

VBA - 从工作表复制单元格到Outlook电子邮件

相关推荐