分隔粘贴到Outlook邮件的Excel表

vmdwslir  于 2023-05-30  发布在  其他
关注(0)|答案(1)|浏览(107)

我正在运行Excel VBA代码来复制/粘贴/格式化电子邮件以简化报告。
该宏在工作表中的几个单独的范围内运行。对于每个范围,它复制选定区域,将其粘贴到电子邮件中,并将粘贴的表格居中。
这是对我上一个问题的扩展:如何用VBA将粘贴的表格居中
即使使用.Range.InsertParagraphBefore创建新行,我的表在加载时也会嵌套在彼此内部。

上下文尺寸:

Sub Macro7()
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
    Dim rng As Range
    Dim OutApp As Object
    Dim outMail As Object
    Dim Location As String
    Dim Signature As String
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

'Open new mail item
    Dim outlookApp As Object
    Set outlookApp = CreateObject("Outlook.Application")
    Set outMail = outlookApp.CreateItem(0)
    
'Get Word editor
    outMail.Display
    Dim wordDoc As Object
    Set wordDoc = outMail.GetInspector.WordEditor

问题编码:

'Copy contents
    Sheets("Tables").Select
    Range("AB7:AI75").Select
    Range("AB7").Activate
    Selection.Copy

'Paste as image (Centered)
    wordDoc.Range.InsertParagraphBefore 'Create new empty paragraph before signature
    wordDoc.Paragraphs.first.Range.PasteAndFormat Type:=wdChartPicture
    wordDoc.Range.InsertParagraphBefore
    
    With wordDoc.Tables(1).Rows
        .WrapAroundText = 0 'If this is true does not work
        .Alignment = 1
    End With
    
'======== SECOND TABLE ========
'Copy contents (2)
    Sheets("Tables").Select
    Range("P7:Z29").Select
    Range("P7").Activate
    Selection.Copy
   
'Paste as image (Centered)(2)
    wordDoc.Range.InsertParagraphBefore
    wordDoc.Range.InsertParagraphBefore 'Create new empty paragraph before signature
    wordDoc.Paragraphs.first.Range.PasteAndFormat Type:=wdChartPicture
    
    With wordDoc.Tables(1).Rows
        .WrapAroundText = 0 'If this is true does not work
        .Alignment = 1
    End With
    
'======== THIRD TABLE ==========
'Copy contents (3)

    Sheets("Tables").Select
    Range("F7:M30").Select
    Range("F7").Activate
    Selection.Copy
   
'Paste as image (Centered)(3)
    wordDoc.Range.InsertParagraphBefore 'Create new empty paragraph before signature
    wordDoc.Paragraphs.first.Range.PasteAndFormat Type:=wdChartPicture
    
    With wordDoc.Tables(1).Rows
        .WrapAroundText = 0 'If this is true does not work
        .Alignment = 1
    End With

每个粘贴的表都放在前面表的顶行中,一个嵌套在另一个中,我正在寻找一种方法将它们分开。

wtlkbnrh

wtlkbnrh1#

这将一个接一个地(而不是在另一个之前)顺序粘贴表格,其想法是您查找最后一段并使用.previous属性将表格插入到最后一段之前的段落中,该表格已在之前的行上创建。

Sub Macro7()
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
    Dim Rng As Range
    Dim OutApp As Object
    Dim outMail As Object
    Dim Location As String
    Dim Signature As String
    
    
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

'Open new mail item

    Dim outlookApp As Object
    Set outlookApp = CreateObject("Outlook.Application")
    Set outMail = outlookApp.CreateItem(0)
    
'Get Word editor

    outMail.Display
    Dim wordDoc As Object
    Set wordDoc = outMail.GetInspector.WordEditor
'Copy contents

    Sheets("Tables").Select
    Range("AB7:AI75").Select
    Range("AB7").Activate
    
    Selection.Copy

'Paste as image (Centered)
    
    Dim insertPoint As Object
    wordDoc.Paragraphs.first.Range.InsertParagraphBefore 'Create new empty paragraph before signature
    Set insertPoint = wordDoc.Paragraphs.first
    insertPoint.Range.InsertParagraphBefore 'Create another
    insertPoint.Previous.Range.PasteAndFormat Type:=wdChartPicture
    
    With wordDoc.Tables(1).Rows
        .WrapAroundText = 0 'If this is true does not work
        .Alignment = 1
    End With
   
'======== SECOND TABLE ========
'Copy contents (2)

    Sheets("Tables").Select
    Range("P7:Z29").Select
    Range("P7").Activate
    Selection.Copy
   
'Paste as image (Centered)(2)
    
    insertPoint.Range.InsertParagraphBefore 'Create new empty paragraph before signature
    insertPoint.Range.InsertParagraphBefore 'Create another
    insertPoint.Previous.Range.PasteAndFormat Type:=wdChartPicture
    
    
    With wordDoc.Tables(2).Rows
        .WrapAroundText = 0 'If this is true does not work
        .Alignment = 1
    End With
    
    
'======== THIRD TABLE ==========
'Copy contents (3)

    Sheets("Tables").Select
    Range("F7:M30").Select
    Range("F7").Activate
    Selection.Copy
   
'Paste as image (Centered)(3)
    
    insertPoint.Range.InsertParagraphBefore 'Create new empty paragraph before signature
    insertPoint.Range.InsertParagraphBefore 'Create another
    insertPoint.Previous.Range.PasteAndFormat Type:=wdChartPicture
    
    With wordDoc.Tables(3).Rows
        .WrapAroundText = 0 'If this is true does not work
        .Alignment = 1
    End With

End Sub

``

相关问题