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

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

excel vba ms-word

如何将excel嵌入图像复制到特定单元格中表格的word标题？,excel,vba,ms-word,Excel,Vba,Ms Word,我从我的主过程中调用这个过程来在word中生成标题，它包含两行文本，然后是图像，然后是一行文本。我试图用一列四行的表来实现这一点。在第三排我想要一张照片。图片存储在excel文件的工作表中，该文件包含word中报表的所有数据。粘贴不起作用。无法确定如何在单元格中获取图像发现图片可以从文件中添加，但我不想将图片保存在单独的文件中，因为如果我移动excel文件，我也必须移动图片文件 'Procedure, to create header Sub MakeHeader() Dim StrArr(1

我从我的主过程中调用这个过程来在word中生成标题，它包含两行文本，然后是图像，然后是一行文本。我试图用一列四行的表来实现这一点。在第三排我想要一张照片。图片存储在excel文件的工作表中，该文件包含word中报表的所有数据。粘贴不起作用。无法确定如何在单元格中获取图像

发现图片可以从文件中添加，但我不想将图片保存在单独的文件中，因为如果我移动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

代码中的主要问题在行中

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 referring 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

尝试：

对于将来想做类似事情但没有桌子的人

'Procedure, to create header
Sub MakeHeader(WApp As Object)
Dim StrArr(1 To 3) As String
Dim ImageObj As Excel.Shape
Dim Doc As Word.Document
Dim i As Long
Dim Count As Long
    'load text from excel file
    StrArr(1) = ActiveSheet.Range("A26").Value
    StrArr(2) = ActiveSheet.Range("A27").Value
    StrArr(3) = ActiveSheet.Range("A28").Value
    'create object to hold picture
    Set ImageObj = ActiveSheet.Shapes(4)
    Set Doc = WApp.ActiveDocument
    With Doc.Sections(1).Headers(1).Range
        'centers text
        .ParagraphFormat.Alignment = 1
        'choosing font
        .Font.Name = "Verdana"
        .Font.Size = 9
        'writes text
        .InsertAfter StrArr(1)
        .Paragraphs.Add
        .InsertAfter StrArr(2)
        .Paragraphs.Add
        'creates space for image
        For i = 1 To 8
            .InsertAfter vbNullString
            .Paragraphs.Add
        Next
        .InsertAfter StrArr(3)
        'change font size for paragraphs 1 and 2
        .Paragraphs(1).Range.Font.Size = 10
        .Paragraphs(2).Range.Font.Size = 10
        'copies image form excel file
        With ImageObj
            .Copy
        End With
        'collapses selection, 0 = wdCollapseEnd
        .Collapse Direction:=0
        'paste image, 3 = wdPasteMetafilePicture
        .PasteSpecial DataType:=3
        'centers image
        .ShapeRange.Align msoAlignCenters, True
        'lowers it from top of page
        .ShapeRange.Top = 35
    End With
    'counts words in header
    Count = Doc.Sections(1).Headers(1).Range.Words.Count
    'underlines last two words, count considers ".", "@" and etc. as words
    With Doc.Sections(1).Headers(1).Range
        .Words(Count - 1).Font.Underline = 1
        .Words(Count - 2).Font.Underline = 1
        .Words(Count - 3).Font.Underline = 1
        .Words(Count - 4).Font.Underline = 1
        .Words(Count - 5).Font.Underline = 1
        .Words(Count - 6).Font.Underline = 1
        .Words(Count - 7).Font.Underline = 1
        'don't need to underline comma ","
        .Words(Count - 9).Font.Underline = 1
        .Words(Count - 10).Font.Underline = 1
        .Words(Count - 11).Font.Underline = 1
        .Words(Count - 12).Font.Underline = 1
        .Words(Count - 13).Font.Underline = 1
        .Words(Count - 14).Font.Underline = 1
        .Words(Count - 15).Font.Underline = 1
    End With
End Sub

经过尝试，代码在

RangeObj.Tables（1）.Cell（3,1）.Range.Paste上运行良好。很明显，我添加了Set Wd=CreateObject（“Word.Application”）
等。最好将ActiveDocument
称为Wd.ActiveDocument.Sections（1）.Headers（1）.Range
。在某些运行中，它会引发错误。谢谢您的建议。是的，它正在工作，但没有达到预期效果。它不会将图片放在表（1）单元格（3,1）中，而是放在文档正文中。如果使用RangeObj.Tables（1）.单元格（3,1）.Range.Paste，它将按预期工作并粘贴到标题的表第三行中。没有成功尝试过几次。对于将来想做类似事情但没有表格的人：
'Procedure, to create header
Sub MakeHeader(WApp As Object)
Dim StrArr(1 To 3) As String
Dim ImageObj As Excel.Shape
Dim Doc As Word.Document
Dim i As Long
Dim Count As Long
    'load text from excel file
    StrArr(1) = ActiveSheet.Range("A26").Value
    StrArr(2) = ActiveSheet.Range("A27").Value
    StrArr(3) = ActiveSheet.Range("A28").Value
    'create object to hold picture
    Set ImageObj = ActiveSheet.Shapes(4)
    Set Doc = WApp.ActiveDocument
    With Doc.Sections(1).Headers(1).Range
        'centers text
        .ParagraphFormat.Alignment = 1
        'choosing font
        .Font.Name = "Verdana"
        .Font.Size = 9
        'writes text
        .InsertAfter StrArr(1)
        .Paragraphs.Add
        .InsertAfter StrArr(2)
        .Paragraphs.Add
        'creates space for image
        For i = 1 To 8
            .InsertAfter vbNullString
            .Paragraphs.Add
        Next
        .InsertAfter StrArr(3)
        'change font size for paragraphs 1 and 2
        .Paragraphs(1).Range.Font.Size = 10
        .Paragraphs(2).Range.Font.Size = 10
        'copies image form excel file
        With ImageObj
            .Copy
        End With
        'collapses selection, 0 = wdCollapseEnd
        .Collapse Direction:=0
        'paste image, 3 = wdPasteMetafilePicture
        .PasteSpecial DataType:=3
        'centers image
        .ShapeRange.Align msoAlignCenters, True
        'lowers it from top of page
        .ShapeRange.Top = 35
    End With
    'counts words in header
    Count = Doc.Sections(1).Headers(1).Range.Words.Count
    'underlines last two words, count considers ".", "@" and etc. as words
    With Doc.Sections(1).Headers(1).Range
        .Words(Count - 1).Font.Underline = 1
        .Words(Count - 2).Font.Underline = 1
        .Words(Count - 3).Font.Underline = 1
        .Words(Count - 4).Font.Underline = 1
        .Words(Count - 5).Font.Underline = 1
        .Words(Count - 6).Font.Underline = 1
        .Words(Count - 7).Font.Underline = 1
        'don't need to underline comma ","
        .Words(Count - 9).Font.Underline = 1
        .Words(Count - 10).Font.Underline = 1
        .Words(Count - 11).Font.Underline = 1
        .Words(Count - 12).Font.Underline = 1
        .Words(Count - 13).Font.Underline = 1
        .Words(Count - 14).Font.Underline = 1
        .Words(Count - 15).Font.Underline = 1
    End With
End Sub