CODEWITHSUNDEEP
vbaexcelms-word
jspek
jspek

Reputation: 446

How to save/copy an embedded picture from Excel to Word

What I have: An Excel file where in a column (actually it is free formatted but aligned to be within a column) some elements are embedded bmp pictures that show the formula =EMBED("Paint.Picture","") when you click on them. When you look at the Excel sheet, only the icon representing the picture is displayed, not the picture itself.

What I want: The embedded picture (not the icon) copied to a new Word document.

The Code I have thus far:

'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

What happens when I run my code: My code goes through all "shapes" that are within the bounds of the column and copies that objects picture. However, when I paste it into word, it literally made a copy of the link image (icon), and not the underlying embedded image.

What I've found thus far: This code which shows me how to create an embedded object, but not how to copy one.

Upvotes: 5

Views: 2484

Answers (2)

JEBoylston
JEBoylston

Reputation: 11

I am not a coder, but I found that if you "Define Name" for a cell range, you can do all kinds of things with the defined names. For example:

Linking Excel Workbook rows to a Word document 1. Open your Excel work book go to Formulas -> Define NAME 2. Create a "NAME" for each of the cells or groups of cells that you would like to link. For example, I hyper-linked a Question # in a Word document to my Excel document that is used for importing questions into our Learning Management System. Example NAME = Question_22 and refers to cell range =WBT16DS058!$A$90 (=worksheet!cellrange) 3. Save & close Excel workbook. 4. Open the Word document and create your text (Question 022) , highlight and insert a hyperlink. 5. Browse & Select your Excel document, append the end of the address to include #NAME. (i.e. - R312Test.xlsx#Question_22). 6. Select the new link, and your Excel document will open to the cell range.

Because you are defining a NAME for the range of cells, the link will stay active even when the cells are moved around.

I am wondering if you used "Define Name" for your cell range that includes the picture you are trying to embed, you will have luck.

My apologies if you have already defined the cell range's name and tried this.

Upvotes: 0

DanL
DanL

Reputation: 999

Update: Simpler solution

As specified in the comments by jspek, the image can actually be copied by using the Copy method of the OLEObject, e.g.:

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

Old solution

I've found a suboptimal solution that involves both the clipboard and SendKeys - inspired by this link. I'm quite convinced that you can do this more elegantly by exploring ways to extract the OLEObject's properties. Extracting these is beyond the scope of my expertise at this time of writing :-)

It revolves around OLEObject. This code executes the OLE object's host application (which is Paint in this case) of your picture, sends keys to copy the picture and finally, pastes it into 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

Upvotes: 1

Related Questions