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