添加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