如何将excel嵌入式图像复制到特定单元格表中的单词标题？

Question

我正在从主过程调用过程以在单词中制作标题，该标题包含2行文本，然后是image，然后是1行文本。我正在尝试使用具有1列和4行的表来做到这一点。在第三行中，我要图片。图片存储在Excel文件中的工作表中，该文件包含所有报告数据。粘贴无效。无法弄清楚如何在单元格中获取图像。

发现可以从文件中添加图片，但是我不想将图片保存在单独的文件中，因为如果移动excel文件，我也必须移动图片文件。

'Procedure, to create header
Sub MakeHeader()
Dim StrArr(1 To 2) As String
Dim RangeObj As Word.Range
    'load text from excel table
    StrArr(1) = ActiveSheet.Range("A26").Value
    StrArr(2) = ActiveSheet.Range("A27").Value

    'to create table
    Set RangeObj = ActiveDocument.Sections(1).Headers(1).Range
    RangeObj.Tables.Add Range:=RangeObj, NumRows:=4, NumColumns:=1

   'populate table
    '//
    RangeObj.Tables(1).Cell(1, 1).Range.Text = StrArr(1)
    RangeObj.Tables(1).Cell(2, 1).Range.Text = StrArr(2)
    'copy picture that is embedded in excel sheet
    'Shapes(4), because there are more then one object in sheet
    ActiveSheet.Shapes(4).CopyPicture xlScreen, xlBitmap
    RangeObj.Tables(1).Cell(3, 1).Application.Selection.Paste
    '//

    'center
    ActiveDocument.Sections(1).Headers(1).Range.ParagraphFormat.Alignment = 1
End Sub

Answer 1

代码中的主要问题在

行中

RangeObj.Tables(1).Cell(3, 1).Application.Selection.Paste

在将图片粘贴到文档本身时，它被引用到应用程序对象选择中（通常不在标题表中，而在主文档中）。因此，将行更改为

RangeObj.Tables(1).Cell(3, 1).Range.Paste

将其粘贴到标题表中，如下所示

也可以通过Word应用程序来引用，而不是直接在excel VBA中引用ActiveDocument（在某些情况下会导致运行问题）。

完整的修改代码：

Sub MakeHeader()
Dim StrArr(1 To 2) As String
Dim RangeObj As Word.Range
'Next line Added for test
Dim wd As Word.Application
    'load text from excel table
    StrArr(1) = ActiveSheet.Range("A26").Value
    StrArr(2) = ActiveSheet.Range("A27").Value

    'to create table
    'Next Three line Added for test
    Set wd = CreateObject("Word.Application")
    wd.Visible = True
    wd.Documents.Add

    'Wd i.e. referance to Word application added to ActiveDocument
    Set RangeObj = wd.ActiveDocument.Sections(1).Headers(1).Range
    RangeObj.Tables.Add Range:=RangeObj, NumRows:=4, NumColumns:=1

   'populate table
    '//
    RangeObj.Tables(1).Cell(1, 1).Range.Text = StrArr(1)
    RangeObj.Tables(1).Cell(2, 1).Range.Text = StrArr(2)
    'copy picture that is embedded in excel sheet
    'Shapes(4), because there are more then one object in sheet
    'shapes(4) modified to Shapes(1) for test. Change to Your requirement
    ActiveSheet.Shapes(1).CopyPicture xlScreen, xlBitmap

    'This line was causing Problem as Range.Application was reffering to Word application
    ' And picture is getting pasted in the document not in header Table
    RangeObj.Tables(1).Cell(3, 1).Range.Paste

    '//

    'center
    'Wd i.e. referance to Word application added to ActiveDocument
    wd.ActiveDocument.Sections(1).Headers(1).Range.ParagraphFormat.Alignment = 1
End Sub

Answer 2

尝试：

Sub MakeWordHeader()
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim wdRng As Word.Range, wdTbl As Word.Table
Dim xlSht As Excel.Worksheet: Set xlSht = ActiveSheet
With wdApp
  .Visible = True
  Set wdDoc = .Documents.Add
  With wdDoc
    Set wdRng = .Sections(1).Headers(1).Range
    Set wdTbl = .Tables.Add(Range:=wdRng, NumRows:=4, NumColumns:=1)
    With wdTbl
      .Cell(1, 1).Range.Text = xlSht.Range("A26").Text
      .Cell(2, 1).Range.Text = xlSht.Range("A27").Text
      xlSht.Shapes(4).CopyPicture xlScreen, xlBitmap
      .Cell(3, 1).Range.Paste
    End With
    wdRng.ParagraphFormat.Alignment = wdAlignParagraphCenter
  End With
End With
End Sub

Answer 3

对于将来想要做类似事情但又没有Table的人

Texture