Insert a new row at the top of each table using VBA

Dear Experts:

I would like to run a macro that performs the following actions:

Insert a new row into all tables of the current document
Insert a graphic into the second cell of this newly added 'header' row
The graphic is located in: C:\MyPictures\MyGraphic.png

Help is much appreciated.

Thank you very much in advance.

Regards, Andreas
Andreas HermleTeam leaderAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Rgonzo1971Commented:
Hi,

pls try

Sub Macro()

For Each tbl In ActiveDocument.Tables
    tbl.Rows(1).Select
    Selection.InsertRowsAbove 1
    tbl.Cell(1, 1).Select
    Selection.MoveRight Unit:=wdCell, Count:=1
    Selection.InlineShapes.AddPicture FileName:= _
        "C:\MyPictures\MyGraphic.png", LinkToFile:=False, _
        SaveWithDocument:=True
Next
End Sub

Open in new window

Regards
0
GrahamSkanRetiredCommented:
Hi Andreas, I think this will do it
Sub AddRow()
    Dim tbl As Table
   
    For Each tbl In ActiveDocument.Tables
        tbl.Rows.Add tbl.Rows.First
        tbl.Cell(1, 2).Range.InlineShapes.AddPicture "C:\MyPictures\MyGraphic.png", False, True
    Next
End Sub
0
GrahamSkanRetiredCommented:
Oops, should have refreshed before posting.
0
PMI ACP® Project Management

Prepare for the PMI Agile Certified Practitioner (PMI-ACP)® exam, which formally recognizes your knowledge of agile principles and your skill with agile techniques.

Andreas HermleTeam leaderAuthor Commented:
ok, great both codes work just fine. Thank you very much for it, great job.

Graham's code is a more 'elegant' since it does not use selection.

There is one more thing I would like to get added to this code.

The inserted graphic should get its aspect ratio locked and then resized to 4 cm

Help is much appreciated. Thank you very much in advance.

Regards, Andreas
0
Andreas HermleTeam leaderAuthor Commented:
Okay, I got the resizing done on Rgonzo codes, but I can't get it done on Graham's code.


Sub MacroInsertPictureResize()

Dim sFileName As String
Dim ilImage As InlineShape

sFileName = "C:\MyPictures\MyGraphic.jpg"
For Each tbl In ActiveDocument.Tables
    tbl.Rows(1).Select
    Selection.InsertRowsAbove 1
    tbl.Cell(1, 1).Select
    Selection.MoveRight Unit:=wdCell, Count:=1
    Set ilImage = Selection.InlineShapes.AddPicture(sFileName, False, True)
    With ilImage
    .LockAspectRatio = msoTrue
    .Width = CentimetersToPoints(4)
    End With
Next
End Sub
0
GrahamSkanRetiredCommented:
The code is very similar to what you did with Rgonzo's version:
Sub AddRow()
    Dim tbl As Table
    Dim ilsh As InlineShape
    
    For Each tbl In ActiveDocument.Tables
        tbl.Rows.Add tbl.Rows.First
        'Set ilsh = tbl.Cell(1, 2).Range.InlineShapes.AddPicture("C:\Users\Public\Pictures\Sample Pictures\Chrysanthemum.jpg", False, True)
        Set ilsh = tbl.Cell(1, 2).Range.InlineShapes.AddPicture("C:\MyPictures\MyGraphic.png", False, True)
        ilsh.LockAspectRatio = True
        ilsh.Width = CentimetersToPoints(4)
    Next
End Sub

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Andreas HermleTeam leaderAuthor Commented:
Since both codes work I think it is fair to award points to both of you.

Thank you very, very much for your swift and professional support. I really appreciate it.

Regards, Andreas
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Word

From novice to tech pro — start learning today.