Word - Resize image to specified target cells' dimensions

[FaizanRoshan]

I have inserts the selected image file into a merged range of cells. The images are automatically re-sized to fit into the cell (aspect ratio maintained). Everything works well, but I ran into a problem.
There are about many cells, I found out that the merged cells to contain the images vary in width and height throughout the cells, even on the same cells.
I do not want to go through every one and figure out the width and height for each cell and type in the corresponding values for every time, (it might take me one day).
What would be helpful is if there were a way to write the code so that the image is resized to the size of the cell (it is actually a merged set of cells), that it is being placed into.
Essentially I need to maintain the aspect ratio of the image file, and fill the target cell(s) without exceeding their boundaries.


Sub FitPics()
Application.ScreenUpdating = False
Dim Tbl As Table, iShp As InlineShape
With ActiveDocument
For Each Tbl In .Tables
For Each iShp In Tbl.Range.InlineShapes
With iShp
.LockAspectRatio = msoTrue
If .Height > .Range.Cells(1).Height Then
.Height = .Range.Cells(1).Height
End If
If .Height < .Range.Cells(1).Height Then
.Height = .Range.Cells(1).Height

End If
If .Width > .Range.Cells(1).Width Then
.Width = .Range.Cells(1).Width
End If
If .Width < .Range.Cells(1).Width Then
.Width = .Range.Cells(1).Width
End If
End With

Next
Next
End With
Application.ScreenUpdating = True
End Sub

Any ideas on how to fix my dilemma?

[gmayor]

If you set the cells to 'fixed width' before inserting the images, the images will shrink to the width of the cells. The aspect ratio will be maintained and the row height will be that of the tallest image in the row. Select the table > Layout Tab > AutoFit > Fixed Width.

This would be mnore practical then trying to fix it after the merge. As you are merging graphics you may find http://www.gmayor.com/mail_merge_graphics.htm and http://www.gmayor.com/mail_merge_graphics_addin.htm useful.

[FaizanRoshan]

Hi, thank you for help, i want to done it in this way, below is code that do same thing in excel, i like same code for word.



Private Sub CommandButton4_Click()
Dim PicLocation As String
Dim MyRange As String

ActiveSheet.Unprotect
Range("A9").Select
MyRange = Selection.Address
PicLocation = Application.GetSaveAsFilename("C:\", "Image Files (*.jpg),*.jpg", , "Specify Image Location")

If PicLocation <> "False" Then
ActiveSheet.Pictures.Insert(PicLocation).Select
Else
Exit Sub
End If

With Selection.ShapeRange
.LockAspectRatio = msoTrue
If .Width > .Height Then
.Width = Range(MyRange).Width
If .Height > Range(MyRange).Height Then .Height = Range(MyRange).Height
Else
.Height = Range(MyRange).Height
If .Width > Range(MyRange).Width Then .Width = Range(MyRange).Width
End If
End With

With Selection
.Placement = xlMoveAndSize
.PrintObject = True
End With

Range("H16").Select
ActiveSheet.Protect
End Sub