Solved: Inserting pitcures into tables

[gljgreenwald]

I am attempting to take images from one open file and put them into tables. I know that the below code will insert text into each cell:


Sub CreateNewTable()
Dim docActive As Document
Dim tblNew As Table
Dim celTable As Cell
Dim intCount As Integer

Set docActive = ActiveDocument
intCount = 1
For i = 1 to 4
Set tblNew = docActive.tables(i)
For Each celTable In tblNew.Range.Cells
celTable.Range.InsertAfter "Cell " & intCount
intCount = intCount + 1
Next celTable
Next i
End Sub


Based on this, I tried the following:


Sub Table_Select()
Dim docActive As Document
Dim tblNew As Table
Dim celTable As Cell
Dim intCount As Integer
Set docActive = ActiveDocument
'Set tblNew = docActive.Tables.Add( _
' Range:=docActive.Range(Start:=0, End:=0), NumRows:=3, _
' NumColumns:=4)
intCount = 1
Let Initial = 0

For i = 1 To 4
Set tblNew = docActive.Tables(i)
Let intCount = 1
For Each celTable In tblNew.Range.Cells
'Copy Image
Documents("Document2").Activate
ActiveDocument.Shapes(intCount + Initial).Select
Selection.Copy
'Clear and Paste Image
Documents(docActive).Activate
celTable.Range.Delete
celTable.Range.Select
celTable.Range.PasteAndFormat (wdPasteDefault)
intCount = intCount + 1
Next celTable
Let Initial = intCount
'tblNew.AutoFormat Format:=wdTableFormatColorful2,
' ApplyBorders:=True, ApplyFont:=True, ApplyColor:=True
Next i
End Sub


However, when I run this code, it sticks all the images in the 1st Cell (Cell(1,1)) of the table. It does not progress through the table.

Does anyone know a way to do this?

Thanks for your time.

[MOS MASTER]

Hi and Welcome to VBAX! :hi:

The problem is that you're using shapes as the object type to paste.
If you would try to do the same action manually. (The copy paste action) you would see the exact same behavior.

Shapes are in the drawing layer of Word and are fare more difficult to position then InlineShapes (Who are threated like a Range object)

So you could solve the problem by changing al shapes to InlineShapes. But that would be a lot of work.

Another possibility is to use the paste special method to paste the shape as inline picture and be done with it.

So change:
celTable.Range.PasteAndFormat (wdPasteDefault)

to:
celTable.Range.PasteSpecial Placement:=wdInLine, DataType:=wdPasteMetafilePicture

Further more your code is not very efficient activating and selecting stuff. You could make a big speed improvement if you'd rewrite the code. (if you need help just howler)

But to get it to work just change the suggested lines and your there.

HTH, :whistle:

[gljgreenwald]

MOS Master,

Thank you very much for your help. That did the trick!

My code now looks like:


Sub Table_Select()
'Call Setup_Conditions
Dim docActive As Document
Dim tblNew As Table
Dim celTable As Cell
Dim intCount As Integer
Set docActive = ActiveDocument

intCount = 1
Let Initial = 0

For i = 1 To 4
Set tblNew = docActive.Tables(i)
Let intCount = 1
For Each celTable In tblNew.Range.Cells
Documents("Document3").Activate
ActiveDocument.Shapes(intCount + Initial).Select
Selection.Copy
Documents(docActive).Activate
celTable.Range.Delete
celTable.Range.PasteSpecial Placement:=wdInLine, DataType:=wdPasteMetafilePicture

intCount = intCount + 1
Next celTable
Let Initial = intCount - 1
Next i
End Sub



As you mentioned, this is not very efficient code. Is there a way that I can take a shape of known index from an open document without actually going to that document, selecting it and then copying it?

Once again, thanks for your help!

[MOS MASTER]

Hi, :yes

You're welcome!

There are many ways to speed this up..buth the following should make a big difference:
Sub Table_Select()
Dim oSource As Word.Document
Dim oTarget As Word.Document
Dim oTable As Word.Table
Dim oCell As Word.Cell
Dim iTable As Integer
Dim iCnt As Integer
iCnt = 1
With Application
.ScreenUpdating = False
Set oSource = .Documents("Doc2.doc") 'Change to doc with pics in it
Set oTarget = .ActiveDocument

For iTable = 1 To 3
With oTarget
Set oTable = .Tables(iTable)
For Each oCell In oTable.Range.Cells
oSource.Shapes(iCnt).Select
Selection.Copy
With oCell.Range
.Delete
.PasteSpecial _
Placement:=wdInLine, _
DataType:=wdPasteMetafilePicture
End With
iCnt = iCnt + 1
Next
End With
Next
.ScreenUpdating = True
End With

Set oCell = Nothing
Set oTable = Nothing
Set oSource = Nothing
Set oTarget = Nothing
End Sub


I'm using a single counter for the shape index but I think this will work in your situation. If not you have to change back.

HTH, :whistle:

[gljgreenwald]

MOS Master,

Sorry for the delay in response. Code works (no surprise to you, I'm sure) and speeds up execution significantly.

Thanks for your help.

[MOS MASTER]

Hi, :yes
Doesn't matter..you're welcome! :beerchug: