excel邮件办公技巧(用Excel发邮件)

#VBA发邮件#

需要分成两个模块。

模块1：标准模块-基本功能模块定义

Function RangetoHTML(rng As Range)

' Changed by Ron de Bruin 28-Oct-2006

' Working in Office 2000-2007

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

模块2：邮件发送

Sub Mail_Sheet_Outlook_Body()

' Don't forget to copy the function RangetoHTML in the module.

' Working in Office 2000-2007

Dim rng As Range

Dim OutApp As Object

Dim OutMail As Object

With Application

.EnableEvents = False

.ScreenUpdating = False

End With

Set rng = Nothing

'Set rng = ActiveSheet.UsedRange

'You can also use a sheet name

'Set rng = Sheets("Sheet1").UsedRange

Dim c As Integer

Sheet6.Select

'以下是范围

c = Sheet1.[B65536].End(xlUp).Row 'a为list表中的非空行

Set rng = Sheet1.Range(Cells(1, 1), Cells(c, 13)) '设定内容范围；

Set OutApp = CreateObject("Outlook.Application")

OutApp.Session.Logon

Set OutMail = OutApp.CreateItem(0)

'如下设定邮箱地址；

iii = iii 1

On Error Resume Next

'设置邮箱

With OutMail

.To = “此处输入邮箱地址；”

.cc = “此处输入邮箱地址；”

.BCC =“此处输入邮箱地址；”

'.Subject = "This is the Subject line"

.Subject = "此处设置标题"

.htmlbody = RangetoHTML(rng)

'.HTMLBody = '"" & _

'"5) Equipment Status:

" & _

'RangetoHTML(rng)

' .attachments.Add fname

.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