Как скопировать Excel встроенное изображение в заголовок слова в таблице в конкретной ячейке?

Question

Я вызываю процедуру из моей основной процедуры, чтобы создать заголовок в слове, который содержит 2 строки текста, затем изображение, затем 1 строку текста.Я пытаюсь сделать это с таблицей, которая имеет 1 столбец и 4 строки.В 3-м ряду хочу картинку.Изображение сохраняется на листе в файле 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

вставит ее в таблицу заголовков, как показано ниже

Также вместо ссылки ActiveDocument непосредственно в Excel VBA (вызывает проблемы в некоторых случаях выполнения), на него можно ссылаться через приложение Word.

Полный измененный код:

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

Answer 2

Для тех, кто в будущем хочет сделать нечто подобное, но без Таблицы

'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

Answer 3

Попробуйте:

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