办公自动化之-通过Excel自动发送电子邮件

办公自动化之-通过Excel自动发送电子邮件

工作中经常碰到一边要在Excel中记录日常事项，一边又得重复的把这些事项通过邮件通知给合作客户，其他部门，供应商等。而且邮件所需格式与Excel记录格式又不一致，这样就得每天反复手工输入拷贝相关内容。烦，烦，烦!无聊，无聊，无聊！

怎么办呢，其实Excel是可以有特技的！Duang,Duang,Duang, 特技一键搞定你的烦恼。

让我们以常用的出货通知为例来感受非同一般的EXCEL邮件一键发送特技吧！

创建一个名字为“出货清单”Excel表单，先制作一个出货记录表格。

您可按需要自行制作，做成一行一条目。

在正常内容最后加一行用于选择是否需要自动发送邮件。

再增加一个名字为"清单"的Excel表单。用于列举各项常用重复内容。

例子中列举出货地址清单，联系人联系方式清单，还有料号清单。

对各个清单定义范围。这里以PNlist 命名来定义举一例，各位可按需定义。

料号清单范围定义=清单!$G$2:OFFSET(清单!$G$1,COUNTA(清单!$G:$G)-1,0)

COUNTA(清单!$G:$G)是用于计算G列有多少行有内容，即有多少个P/N清单。例子计算结果为4

OFFSET($G$1,4-1，0）计算结果即为$G$4.

所以PNlist 就被成功定义为=清单!$G$2:$G$4

定义地址清单：Addresslist =清单!$A$2:offset($A$1,counta($A:$A)-1,1)

定义联系人清单：Namelist=清单!$D$2:OFFSET(清单!$D$1,COUNTA(清单!$D:$D)-1,1)

通过定义的清单来校验数据， 从而保证误输入。通过下来选择也可提高效率。

新建一个名为“模板”的Excel表单，定义要通过邮件发送的内容的模板。

后续会通过宏来拷贝模板，填充内容，调用outlook发送。

注意。 模板请放在第一行以下，因为第一行会用与拷贝发送内容过来做转制。

按如下图片步骤录制一个名为"shipment"的宏。

宏的录制是录制单条操作的内容，操作内容根据自己需要按步骤录制。

多条循环操作需稍微加几句代码。

下一步骤会介绍。

如下代码供参考：

Sub shipment()' shipment arrangement

'如下为录制内容

Sheets("出货记录").Select

Range("B3:I3").Select

Application.CutCopyMode = False

Selection.Copy

Sheets("邮件模板").Select

Range("A1").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,

SkipBlanks _

:=False, Transpose:=False

Range("G3:H12").Select

Application.CutCopyMode = False

Selection.Copy

Range("A3").Select

Selection.Insert Shift:=xlDown

Range("B3").Select

Application.CutCopyMode = False

ActiveCell.FormulaR1C1 = "=R[-2]C[-1]"

Range("B4").Select

ActiveCell.FormulaR1C1 = "=R[-3]C"

Range("B5").Select

ActiveCell.FormulaR1C1 = "=R[-4]C"

Range("B6").Select

ActiveCell.FormulaR1C1 = "=R[-5]C"

Range("B7").Select

ActiveCell.FormulaR1C1 = "=R[-6]C"

Range("B8").Select

ActiveCell.FormulaR1C1 = "=R[-7]C"

Range("B9").Select

ActiveCell.FormulaR1C1 = "=R[-8]C"

Range("B10").Select

ActiveCell.FormulaR1C1 = "=R[-9]C"

Range("B3:B10").Select

Selection.Copy

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,

SkipBlanks _

:=False, Transpose:=False

Range("A1:H1").Select

Application.CutCopyMode = False

Selection.ClearContents

Sheets("出货记录").Select

Range("J3").Select

ActiveCell.FormulaR1C1 = "Closed"

Range("A3:J3").Select

Range("J3").Activate

With Selection.Interior

.Pattern = xlSolid

.PatternColorIndex = xlAutomatic

.ThemeColor = xlThemeColorDark1

.TintAndShade = -0.149998474074526

.PatternTintAndShade = 0

End With

'如上为录制内容

End Sub

打开录制的宏添加循环代码。

按图片步骤及语句在录制范围前后添加循环代码。

Dim i As Integer

Dim j As Integer

Dim g As Integer

Application.ScreenUpdating = False

Sheets("出货记录").Select

i = 1

j = Application.WorksheetFunction.CountA(Range("A:A")) + 1

g = 0

'变量i 用于循环，变量j用于判断有多少行需要循环，变量g 用于邮件发送时定义有多少行需要发送

For i = 1 To j

If Range("j" & i).Value = "Y" Then

'如下为录制内容

-------------

'如上为录制内容

g = g + 1

Else

End If

Next i

录制范围部分代码需按图片更新成变量。

再添加邮件发送代码，其中有定义一个名为的 RangetoHTML（）的函数。

' 以下语段用于发送邮件

Sheets("出货记录").Select

If g = "0" Then

MsgBox "No new shippment set to Y "

Else

g = 10 * g + 2

Dim OutApp As Object

Dim OutMail As Object

Dim MailBody As Range

Sheets("邮件模板").Select

Set MailBody = Range("A3:B" & g)

Set OutApp = CreateObject("Outlook.Application")

Set OutMail = OutApp.CreateItem(olMailItem)

On Error Resume Next

With OutMail

.to = "Mama@aimama.com"

.CC = ""

.BCC = ""

.Subject = "Shipment Arrangement"

.BodyFormat = Outlook.OlBodyFormat.olFormatHTML

.HTMLBody = RangetoHTML(MailBody)

.Display

End With

On Error GoTo 0

End If

Sheets("出货记录").Select

Application.ScreenUpdating = True

RangetoHTML（）的函数 代码申明

将如下代码拷贝粘帖到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

代码完成。 只需创建一个按钮方便调用此宏即可。

增加条目后把对应行内邮件通知列改成"Y",然后点“发送邮件”按钮即可弹出邮件并出货通知表单内更改状态。