将 Word 文档中的图像复制到 Excel 单元格中

Question

I want to copy a picture from a word document into a cell in Excel, but every time I try to paste the picture I get an "\".

Can someone help me please?

Is there a simple way to do this operation in VBA?

I use selection to search between two chapters (The selection works perfectly but the copy does not.)

My code is as follows:

Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
Set wrdDoc = wrdApp.Documents.Open("C:\test.docx")
Dim r1 As Long


wrdApp.Selection.WholeStory
wrdApp.Selection.Find.ClearFormatting
With wrdApp.Selection.Find
     .Text = "ABCD"
     .Forward = True
     .Wrap = wdFindContinue
     .Format = False
     .MatchCase = False
     .MatchWholeWord = True
     .MatchWildcards = False
     .MatchSoundsLike = False
     .MatchAllWordForms = False
     .Execute
End With
r1 = wrdApp.Selection.Range.End

wrdApp.Selection.Find.Text = "BCDE"
If wrdApp.Selection.Find.Execute Then
    wrdApp.Selection.Collapse wdCollapseStart
Else
    wrdApp.Selection.WholeStory
    wrdApp.Selection.Collapse wdCollapseEnd
End If
     
wrdDoc.Range(r1, wrdApp.Selection.Start).Select

With wrdApp.Selection
    MySheet.Range("B3").Value = .InlineShapes(1)
End With

Answer 1

There are several problems with your code.

1. The variable MySheet isn't declared and doesn't point to anything. As a result your code doesn't compile.

2. Although your question mentions using copy and paste your code doesn't copy or paste anything.

3. The .Value of a cell cannot be a picture.

4. When using VBA, whether in Excel, PowerPoint or Word, it is best to avoid using the Selection object and use Range instead.

    Dim wrdApp As Word.Application Dim wrdDoc As Word.Document Set wrdApp = CreateObject("Word.Application") wrdApp.Visible = True Set wrdDoc = wrdApp.Documents.Open("C:\test.docx") Dim r1 As Word.Range Set r1 = ActiveDocument.Range With wrdDoc.Range With.Find.ClearFormatting.Replacement.ClearFormatting.Text = "ABCD".Format = False.Forward = True.Wrap = wdFindStop.MatchWildcards = False End With If.Find.Execute Then r1.Start =.End.Find.Text = "BCDE" If.Find.Execute Then r1.End =.Start End With r1.InlineShapes(1).Range.Copy ThisWorkbook.Sheets(1).Range("B3").PasteSpecial wrdDoc.Close False wrdApp.Quit