VBA发送邮件

代码实现了如下功能：

1、将《出货清单》中标识为”Y"的记录复制到《邮件模板》中。

2、发送邮件，并记录发送时间，实现日志功能。

3、未实现自动发送邮件功能，若需实现可参考《VBA操作OutLook批量发送邮件》

代码：

Sub shipment() ' shipment arrangement

Dim i As Integer
Dim j As Integer
Dim g As Integer

Application.ScreenUpdating = False

Sheets("出货清单").Select
j = Application.WorksheetFunction.CountA(Range("A:A")) + 1
g = 0

For i = 2 To j
    If Range("j" & i).Value = "Y" Then
            '读取标识为Y的记录
         Sheets("出货清单").Range("B" & i, "I" & i).Copy
         
         '将信息写入到第1行中
         Sheets("邮件模板").Select
         Range("A1").Select
         Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
         
         '复制第4行并插入
         Range("A4:I4").Select
         Application.CutCopyMode = False
         Selection.Copy
         Range("A4").Select
         Selection.Insert Shift:=xlDown
         
         '在A4:H4中插入取值公式
         Range("A4").FormulaR1C1 = "=R[-3]C[0]"
         Range("B4").FormulaR1C1 = "=R[-3]C[1]"
         Range("C4").FormulaR1C1 = "=R[-3]C[1]"
         Range("D4").FormulaR1C1 = "=R[-3]C[-2]"
         Range("E4").FormulaR1C1 = "=R[-3]C[2]"
         Range("F4").FormulaR1C1 = "=R[-3]C[0]"
         Range("G4").FormulaR1C1 = "=R[-3]C[-6]"
         Range("H4").FormulaR1C1 = "=R[-3]C[0]"
                     
         'A4:H4公式数值化
         Range("A4:I4").Select
         Selection.Copy
         Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
         
         '清除第1行中的数据
          Range("A1:H1").ClearContents
        
         '原记录Y改为操作时间，并添加灰色底色
         Sheets("出货清单").Select
         Range("J" & i).Value = Now()
         Range("A" & i, "J" & i).Select
         With Selection.Interior
             .PatternColorIndex = xlAutomatic
             .ThemeColor = xlThemeColorDark1
             .TintAndShade = -0.149998474074526
         End With
         g = g + 1
    End If
Next i

'   下面是判断是否有记录，若有记录则发送邮件
If g = "0" Then
    Sheets("出货清单").Select
    MsgBox "NO new shippment set to Y"
Else
    g = g + 3
    
Dim OutApp As Object
    Dim OutMail As Object
    Dim MailBody As Range
    
    Sheets("邮件模板").Select
    'I列记录发邮件时间
    Range("I4:I" & g) = Now()
    Set MailBody = Range("A3:H" & g)
    Set OutApp = CreateObject("OutLook.Application")
    Set OutMail = OutApp.CreateItem(olMailTtem)

    On Error Resume Next
    
    Sheets("出货清单").Select
    Application.ScreenUpdating = True
  
   With OutMail
  '  .To = "M**@a**.com"
  '  .CC = ""
  '  .BCC = ""
    .Subject = "通知函"
    .BodyFormat = Outlook.olBodyFormat.olFormatHTML
    .HTMLBody = RangetoHTML(MailBody)
    .Display
  End With

  On Error GoTo 0

End If
End Sub


'=====   发送邮件函数   ====
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"
'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