fill cell table in a word docment with image

[sal21]

I need to insert in the first cell in a word table with an image from:

c:\mydir\myinage.jpg

naturally center image in cell, and not autofit, maintain the originale dimension

how to?

NOTE:
i open the word doc:
...
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Set objWordDoc = objWord.Documents.Open(strSourceFile)
...

all var of word are public dimensioned

[HansV]

Try this:

Code: Select all

Sub Test()
    Dim strSourceFile As String
    Dim strPictureFile As String
    Dim objWord As Object
    Dim objWordDoc As Object
    Dim objTable As Object
    Dim objCell As Object
    Dim blnStart As Boolean
    ' *** Change as needed *****************
    strSourceFile = "C:\mydir\TEMPLATE1.doc"
    strPictureFile = "c:\mydir\myinage.jpg"
    ' **************************************
    On Error Resume Next
    Set objWord = GetObject(Class:="Word.Application")
    If objWord Is Nothing Then
        Set objWord = CreateObject(Class:="Word.Application")
        blnStart = True
    End If
    On Error GoTo ErrHandler
    Set objWordDoc = objWord.Documents.Open(Filename:=strSourceFile, AddToRecentFiles:=False)
    Set objTable = objWordDoc.Tables(2)
    Set objCell = objTable.Cell(1, 1)
    With objCell
        .Range.Paragraphs.Alignment = 1
        .VerticalAlignment = 1
        .Range.InlineShapes.AddPicture Filename:=strPictureFile, _
            LinkToFile:=False, SaveWithDocument:=True
    End With
ExitHandler:
    On Error Resume Next
    objWordDoc.Close SaveChanges:=True
    If blnStart Then
        objWord.Quit SaveChanges:=False
    End If
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

[sal21]

Try this:

Code: Select all

Sub Test()
    Dim strSourceFile As String
    Dim strPictureFile As String
    Dim objWord As Object
    Dim objWordDoc As Object
    Dim objTable As Object
    Dim objCell As Object
    Dim blnStart As Boolean
    ' *** Change as needed *****************
    strSourceFile = "C:\mydir\TEMPLATE1.doc"
    strPictureFile = "c:\mydir\myinage.jpg"
    ' **************************************
    On Error Resume Next
    Set objWord = GetObject(Class:="Word.Application")
    If objWord Is Nothing Then
        Set objWord = CreateObject(Class:="Word.Application")
        blnStart = True
    End If
    On Error GoTo ErrHandler
    Set objWordDoc = objWord.Documents.Open(Filename:=strSourceFile, AddToRecentFiles:=False)
    Set objTable = objWordDoc.Tables(2)
    Set objCell = objTable.Cell(1, 1)
    With objCell
        .Range.Paragraphs.Alignment = 1
        .VerticalAlignment = 1
        .Range.InlineShapes.AddPicture Filename:=strPictureFile, _
            LinkToFile:=False, SaveWithDocument:=True
    End With
ExitHandler:
    On Error Resume Next
    objWordDoc.Close SaveChanges:=True
    If blnStart Then
        objWord.Quit SaveChanges:=False
    End If
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

Before you post, googling:

objWord.ActiveDocument.Tables(2).Cell(1, 1).Range.InlineShapes.AddPicture PATHIMG

i need to add some code to center image, or not?

[HansV]

See my reply.

[sal21]

See my reply.

Sorry!

The code work perfect!
Tks.

[sal21]

See my reply.

now based the doc attached.

Possible to replicate the two table on each page, based a for next...

Example:

for Z=0 to 7
'copy the block of tabel from the page 1to page Z
next 7

To the end of code i need 7 pages with the same block of table on page 1

I hope understand me.

[HansV]

I cannot do that with the document that you attached, but the following code works for me with the modified version that I attached.

Code: Select all

Sub Test2()
    Dim strSourceFile As String
    Dim objWord As Object
    Dim objWordDoc As Object
    Dim blnStart As Boolean
    Dim objTable As Object
    Dim objTarget As Object
    Dim Z As Long
    ' *** Change as needed *****************
    strSourceFile = "C:\mydir\TEMPLATE.doc"
    ' **************************************
    On Error Resume Next
    Set objWord = GetObject(Class:="Word.Application")
    If objWord Is Nothing Then
        Set objWord = CreateObject(Class:="Word.Application")
        blnStart = True
    End If
    On Error GoTo ErrHandler
    Set objWordDoc = objWord.Documents.Open(Filename:=strSourceFile, AddToRecentFiles:=False)
    Set objTable = objWordDoc.Tables(1)
    For Z = 2 To 7
        Set objTarget = objWordDoc.Content
        objTarget.Collapse Direction:=0
        objTarget.InsertBreak
        Set objTarget = objWordDoc.Content
        objTarget.Collapse Direction:=0
        objTable.Range.Copy
        objTarget.Paste
    Next Z
ExitHandler:
    On Error Resume Next
    objWordDoc.Close SaveChanges:=True
    If blnStart Then
        objWord.Quit SaveChanges:=False
    End If
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

TEMPLATE.doc

[HansV]

By the way, please see this post

[sal21]

I cannot do that with the document that you attached, but the following code works for me with the modified version that I attached.

Code: Select all

Sub Test2()
    Dim strSourceFile As String
    Dim objWord As Object
    Dim objWordDoc As Object
    Dim blnStart As Boolean
    Dim objTable As Object
    Dim objTarget As Object
    Dim Z As Long
    ' *** Change as needed *****************
    strSourceFile = "C:\mydir\TEMPLATE.doc"
    ' **************************************
    On Error Resume Next
    Set objWord = GetObject(Class:="Word.Application")
    If objWord Is Nothing Then
        Set objWord = CreateObject(Class:="Word.Application")
        blnStart = True
    End If
    On Error GoTo ErrHandler
    Set objWordDoc = objWord.Documents.Open(Filename:=strSourceFile, AddToRecentFiles:=False)
    Set objTable = objWordDoc.Tables(1)
    For Z = 2 To 7
        Set objTarget = objWordDoc.Content
        objTarget.Collapse Direction:=0
        objTarget.InsertBreak
        Set objTarget = objWordDoc.Content
        objTarget.Collapse Direction:=0
        objTable.Range.Copy
        objTarget.Paste
    Next Z
ExitHandler:
    On Error Resume Next
    objWordDoc.Close SaveChanges:=True
    If blnStart Then
        objWord.Quit SaveChanges:=False
    End If
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

TEMPLATE.doc

Sorry, but to simplify my operation on word doc, i have maked all in one table.

I need to chenge your code?

Attached new file

[HansV]

Have you tried the code from my previous reply?

[sal21]

Have you tried the code from my previous reply?

ops...

see the doc after your code.

all work, buthe last row of table (DATA AGG.) go out the table!

[HansV]

Try this version of the document, with the code that I posted earlier.

TEMPLATE.DOC

[sal21]

Try this version of the document, with the code that I posted earlier.


TEMPLATE.DOC

tks.
work