添加excel表格到oultlook群发邮件系统

2022-07-18 07:44:20 第一文档网 [ 字体：小中大 ] [

阅读： ] [

说明：文章内容仅供预览，部分内容可能不全。下载后的文档，内容与下面显示的完全一致。下载之前请确认下面内容是否您想要的，是否完整无缺。下载word有问题请添加QQ：admin处理，感谢您的支持与谅解。

【#第一文档网# 导语】以下是®第一文档网的小编为您整理的《添加excel表格到oultlook群发邮件系统》，欢迎阅读！
邮件系统,群发,表格,oultlook,添加

添加excel表格到oultlook群发邮件系统

Sub rr()

Dim olApp As Outlook.Application Dim olMail As Outlook.MailItem Dim i%, j%, k% Dim rag As Range a = 2

Set olApp = New Outlook.Application

Set rag = Range(Cells(1, 1), Cells(1, 6)) '要复制的标题范围，把不显示的都放到复制范围之外，比如现在要复制的时候A:D列，不需要复制的邮件地址在E列，如果你要增加列，只需要修改cells(1,4)中的4为需要的列表 For i = 2 To [a65536].End(xlUp).Row

If Cells(i + 1, 6) <> Cells(i, 6) Then '这个地方的4是判断D列存放的领导的名字，如果这一列也不需要显示的话，可以和邮件地址列一起放到最后两列去

Set rag = Union(rag, Range(Cells(a, 1), Cells(i, 6))) '这个地方的cells(i,4)的4也是需要修改到你要复制的列范围例如你要复制到H列，那就修改为cells(i,"h")，记着领导名列，和邮件地址列放到I,J列,上边的IF遇见是判断领导名字的，也要相应的修改为cells(i,"i") Set olMail = olApp.CreateItem(olMailItem) Dim strHTMLBody As String

strHTMLBody = RangetoHTML(rag) With olMail

.Subject = "绩效评价表"

.HTMLBody = strHTMLBody

.To = Cells(i, 7)

.Send End With a = i + 1

Set rag = Range(Cells(1, 1), Cells(1, 6)) End If Next

Set rag = Nothing Set olMail = Nothing End Sub

Public Function RangetoHTML(Rng As Range) 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"

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

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

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=") TempWB.Close savechanges:=False Kill TempFile Set ts = Nothing Set fso = Nothing

Set TempWB = Nothing End Function

本文来源：https://www.dywdw.cn/eef9033b453610661ed9f4f4.html