如何将嵌入的图片从Excel保存/复制到Word

2023年4月5日 556次阅读

是)我有的：

一个Excel文件在一个列中(实际上它是自由格式化但在一列中对齐)一些元素嵌入bmp图片,当你点击它们时显示公式= EMBED(“Paint.Picture”,“”).查看Excel工作表时,仅显示代表图片的图标,而不是图片本身.

我想要的是：
嵌入的图片(不是图标)复制到新的Word文档.

我到目前为止的守则：

'Image Objects
Dim myObjs As Shapes
Dim myObj As Shape
Set myObjs = ActiveSheet.Shapes

'Traversing objects
Dim row As Integer
Dim myRange As Range
Dim myRange2 As Range
Dim isAddressMatch As Boolean

'Word Document Objects
Dim wordApp As New Word.Application
Dim myWord As Word.Document


'Prepare word for output
Set myWord = wordApp.Documents.Add
wordApp.Visible = True

'Initalize traversing objectts
Set myRange = Sheets("myWorksheet").Range("Q5")
Set myRange2 = Sheets("myWorksheet").Range("E5")
row = 0

'Loop through range values in the desired column
While (myRange2.Offset(row).Value <> "")
    'Loop through all shape objects until address match is found.
    For Each myObj In myObjs

        On Error Resume Next
        isAddressMatch = (myObj.TopLeftCell.Address = myRange.Offset(row).Address)
        If Err.Number <> 0 Then
            isAddressMatch = False
            On Error GoTo 0
        End If

        'When match is found copy the bmp picture from Excel to Word
        If (isAddressMatch) Then
            myObj.Select
            ''''''''This copies the excel default picture,'''''''''''''''
            ''''''''not the picture that is embeded.'''''''''''''''''''''
            myObj.CopyPicture 'What is the correct way to copy myObj

            myWord.Range.Paste
            'Rest of the code not yet implement

        End If
    Next
    row = row + 1
Wend

运行我的代码时会发生什么：
我的代码遍历列中边界内的所有“形状”并复制对象图片.但是,当我将其粘贴到word中时,它实际上是链接图像(图标)的副本,而不是底层的嵌入图像.

到目前为止我发现了什么：
This code,它向我展示了如何创建嵌入对象,而不是如何复制一个.

最佳答案 更新：更简单的解决方案

正如jspek在注释中指出的那样,实际上可以使用OLEObject的Copy方法复制图像,例如：

Dim obj As OLEObject
Set obj = ActiveSheet.OLEObjects(myObj.Name)

'Copy the OLE object representing a picture.
obj.Copy
'Paste the picture in Word.
myWord.Range.Paste

老解决方案

我找到了一个涉及剪贴板和SendKeys的次优解决方案 – 受到this link的启发.我相信你可以通过探索提取OLEObject属性的方法来更优雅地做到这一点.在撰写本文时,提取这些内容超出了我的专业范围:-)

它围绕OLEObject.此代码执行图片的OLE object’s host application(在本例中为Paint),发送密钥以复制图片,最后将其粘贴到Word中.

'Get the OLE object matching the shape name.
Dim obj As OLEObject
Set obj = ActiveSheet.OLEObjects(myObj.Name)

'Activate the OLE host application.
obj.Activate
'Send CTRL+A to select the picture in Paint and CTRL+C to copy it.
Application.SendKeys "^a"
Application.SendKeys "^c"
'Paste the picture in Word.
myWord.Range.Paste
点赞