如何在Outlook邮件正文后、签名前插入Excel表格？VBA代码求助

Got it, let's adjust your VBA code so the Excel table gets inserted right after for [region]. and before Regards,. The issue with your original code was that you were pasting the table at the very end of the email body (after the signature) by setting the selection start to Len(.body). Here's the corrected version with key changes explained:

Modified Code #

' Add this constant at the top for Word editor character movement (Late Binding)
Const wdCharacter As Integer = 1

Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim sh As Worksheet
Dim DateString As String
Dim FolderName As String
Dim myOutlook As Object
Dim myMailItem As Object
Dim mySubject As String
Dim myPath As String
Dim i As Integer
Dim weeknumber As String
Dim region As String
Dim Signature As String
Dim vInspector As Object
Dim wEditor As Object

With Application
 .ScreenUpdating = False
 .EnableEvents = False
 .Calculation = xlCalculationManual
End With

Set outlApp = CreateObject("Outlook.Application")
weeknumber = "Week " & WorksheetFunction.WeekNum(Now, vbMonday)

For i = 2 To 3
    region = Sheets("Sheet1").Cells(i, 5).Value
    mySubject = "Overdue Milestones | " & weeknumber & " | " & region
    
    Set Sourcewb = ActiveWorkbook
    DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
    FolderName = "C:\Users\mxr0520\Desktop\Ignite Reports\Milestones\" & weeknumber
    
    If i < 3 Then
        MkDir FolderName
    End If
    
    Set sh = Sheets(region)
    If sh.Visible = -1 Then
        sh.Copy
        Set Destwb = ActiveWorkbook
        
        With Destwb
            If Val(Application.Version) < 12 Then
                FileExtStr = ".xls": FileFormatNum = -4143
            Else
                If Sourcewb.Name = .Name Then
                    MsgBox "Your answer is NO in the security dialog"
                    GoTo GoToNextSheet
                Else
                    FileExtStr = ".xlsx": FileFormatNum = 51
                End If
            End If
        End With
        
        If Destwb.Sheets(1).ProtectContents = False Then
            With Destwb.Sheets(1).UsedRange
                 .Cells.Copy
                 .Cells.PasteSpecial xlPasteValues
                 .Cells(1).Select
            End With
            Application.CutCopyMode = False
        End If
        
        Set OutLookApp = CreateObject("Outlook.application")
        Set OutlookMailitem = OutLookApp.CreateItem(0)
        
        ' First display the email to capture the signature
        With OutlookMailitem
            .Display
        End With
        Signature = OutlookMailitem.HTMLBody
        
        ' Save the workbook and get its path
        With Destwb
            .SaveAs FolderName & "\" & Destwb.Sheets(1).Name & FileExtStr, FileFormat:=FileFormatNum
            myPath = .FullName
            .Close False
        End With
        
        ' Build the email body with placeholder position for the table
        With OutlookMailitem
            .Subject = mySubject
            .To = Sheets("Sheet1").Cells(i, 6)
            .CC = Sheets("Sheet1").Cells(i, 7)
            .HTMLBody = "Dear All," & "<br>" _
            & "<br>" _
            & "Attached please find the list of milestones that are <b>overdue</b> and <b>due in 14 days</b> for " & region & "." & "<br>" & "<br>" _
            & "Regards," & "<br>" _
            & "Marek" _
            & Signature
            
            .Attachments.Add myPath
            
            ' Copy the Excel range to paste
            Worksheets("Summary").Range("A1:E14").Copy
            
            ' Get the email's Word editor to control insertion position
            Set vInspector = OutlookMailitem.GetInspector
            Set wEditor = vInspector.WordEditor
            
            ' Find the text "for [region]." to locate where to insert the table
            With wEditor.Application.Selection.Find
                .Text = "for " & region & "."
                .Forward = True
                .Wrap = wdFindStop
                .Execute
            End With
            
            ' Move cursor right after the found text, add a new line, then paste
            If wEditor.Application.Selection.Find.Found Then
                wEditor.Application.Selection.MoveRight Unit:=wdCharacter, Count:=1
                wEditor.Application.Selection.TypeParagraph ' Add a blank line
                wEditor.Application.Selection.Paste ' Paste the table here
            End If
            
            .Display
        End With
        
        Set OutlookMailitem = Nothing
    End If
GoToNextSheet:
Next i

' Restore Excel settings
With Application
 .ScreenUpdating = True
 .EnableEvents = True
 .Calculation = xlCalculationAutomatic
End With

Key Changes Explained #

1. Added Constant for Word Editor: Const wdCharacter As Integer = 1 is needed for moving the cursor since we're using late binding with Outlook/Word.
2. Improved Signature Capture: We first display the email to get the signature, then build the body correctly without disrupting its placement.
3. Precision Positioning with Find: Instead of pasting at the end of the body, we use Word's Find method to locate the exact text for [region]., then move the cursor right after it.
4. Cleaned Up Path Handling: Directly use .FullName from the saved workbook to avoid relying on ActiveWorkbook which can be unreliable if focus shifts.
5. Restored Excel Settings: Added code at the end to turn screen updating, events, and calculation back on (your original code missed this important step!).

This will ensure your table is inserted exactly between the region line and the "Regards" section, before your signature.

内容的提问来源于stack exchange，提问作者Marek Re