Apply Rotating and Scaling to all graphics (located in tables) using VBA

Dear Experts:

below macro ...
... rotates and scales the selected inline graphic.

I would like to apply this macro to all the graphics in the current document: All the graphics are located in table cells (inline with text)

The requirements in detail:

The macro is ...
... to loop thru all the graphics in all the tables of the current document
... rotate the graphics by 90 degrees
... scale the graphic by Factor 1.5
... convert them back to inline shapes
... only apply above changes to graphics with a width less than 1 cm.

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

Regards, Andreas





Sub Rotate_Scale_Selected_Inline_Graphic()
Dim ils As Word.InlineShape
Dim shp As Word.Shape

Set ils = Selection.InlineShapes(1)
Set shp = ils.ConvertToShape
shp.IncrementRotation 90
shp.ScaleWidth 1.5, msoFalse, msoScaleFromTopLeft
Set ils = shp.ConvertToInlineShape
End Sub

Open in new window

Andreas HermleTeam leaderAsked:
Who is Participating?
 
Rgonzo1971Connect With a Mentor Commented:
Hi,

try maybe this

Sub Macro1()

For Each IlShp In ActiveDocument.InlineShapes
    If IlShp.Width < CentimetersToPoints(1) Then
        Set shp = IlShp.ConvertToShape
        shp.LockAspectRatio = msoTrue
        shp.IncrementRotation 90
        shp.Width = shp.Width * 1.5
        Set IlShp = shp.ConvertToInlineShape
    End If
Next

End Sub

Open in new window

Regards
0
 
Rgonzo1971Commented:
Hi,

pls try

Sub Macro()

For Each tbl In ActiveDocument.Tables
    tbl.Select
    For Each IlShp In Selection.InlineShapes
        If IlShp.Width < CentimetersToPoints(1) Then
            Set shp = IlShp.ConvertToShape
            shp.IncrementRotation 90
            shp.ScaleWidth 1.5, msoFalse, msoScaleFromTopLeft
            Set IlShp = shp.ConvertToInlineShape
        End If
    Next
Next
End Sub

Open in new window

Or if Inlinshapes are only in tables

Sub Macro1()

For Each IlShp In ActiveDocument.InlineShapes
    If IlShp.Width < CentimetersToPoints(1) Then
        Set shp = IlShp.ConvertToShape
        shp.IncrementRotation 90
        shp.ScaleWidth 1.5, msoFalse, msoScaleFromTopLeft
        Set IlShp = shp.ConvertToInlineShape
    End If
Next

End Sub

Open in new window

Regards
0
 
Andreas HermleTeam leaderAuthor Commented:
Hi Rgonzo,

The rotation works just fine, but the scaling produces not the correct results. I made a quick research on the internet on this problem and I learned that the Scaling via VBA is very, very tricky and buggy, respectively.

I got more information on this problem at my working place. I will get back to you tomorrow with more information.

Regards, Andreas
0
2018 Annual Membership Survey

Here at Experts Exchange, we strive to give members the best experience. Help us improve the site by taking this survey today! (Bonus: Be entered to win a great tech prize for participating!)

 
Andreas HermleTeam leaderAuthor Commented:
Hi Rgonzo,

thank you very much for your professional help. I am afraid to tell you that the graphics still get blown out of proportion. Must be a bug !


Here is a sample code from Jay Friedman, Word MVP which I came across on the Internet.

'>Here's some code from one of my macros to handle proportional
'>resizing.
'
'>    ' change these numbers to the maximum width and height
'>    ' (in inches) to make the inserted pictures
'>       Const PicWidth = 1.9
'>       Const PicHeight = 2.25
'
'>       Dim Photo As InlineShape
'
'>        Set Photo = .InlineShapes.AddPicture(FileName:=FName, _
'>            LinkToFile:=False, SaveWithDocument:=True, _
'>            Range:=PicRg)
'>        With Photo
'>            RatioW = CSng(InchesToPoints(PicWidth)) / .Width
'>            RatioH = CSng(InchesToPoints(PicHeight)) / .Height
'
'>            ' choose the smaller ratio
'>            If RatioW < RatioH Then
'>                RatioUse = RatioW
'>            Else
'>                RatioUse = RatioH
'>            End If
'
'>            ' size the picture to fit the cell
'>            .Height = .Height * RatioUse
'>            .Width = .Width * RatioUse
'>        End With

There is another code I came across which perfectly matches my requirements on this subject.

http://yuriy-okhmat.blogspot.de/2011/07/how-to-resize-all-images-in-word.html

Sub AllPict_UniformHeight()
'How to resize all images in Word document?
'Here’s a simple VBA macro that will resize certain images (< 0.7 cm) in a Word document to 6 cm height preserving the aspect ratio.
'http://yuriy-okhmat.blogspot.de/2011/07/how-to-resize-all-images-in-word.html
    Dim targetWidth As Integer
    Dim targetHeight As Integer
    Dim oShp As Shape
    Dim oILShp As InlineShape
 
 On Error Resume Next
    targetHeight = 6
 
    For Each oShp In ActiveDocument.Shapes
    If oShp.Width < CentimetersToPoints(0.7) Then
        With oShp
            .Width = AspectHt1(.Width, .Height, _
            CentimetersToPoints(targetHeight))
            .Height = CentimetersToPoints(targetHeight)
        End With
    End If
     Next
    For Each oILShp In ActiveDocument.InlineShapes
    If oILShp.Width < CentimetersToPoints(0.7) Then
        With oILShp
            .Width = AspectHt1(.Width, .Height, CentimetersToPoints(targetHeight))
            .Height = CentimetersToPoints(targetHeight)
        End With
       End If
    Next
End Sub
 
Private Function AspectHt1(ByVal origWd As Long, ByVal origHt As Long, ByVal newWd As Long) As Long
    If origWd <> 0 Then
        AspectHt1 = (CSng(origWd) / CSng(origHt)) * newWd '
    Else
        AspectHt1 = 0
    End If
End Function
'Posted by FLUID at 7/17/2011
0
 
Rgonzo1971Commented:
Hi,

1. the codes you sent adapt the image to be contained in a predetermined height or rectangle

2. when you said factor whas it facto up or factor down

Regards
0
 
Andreas HermleTeam leaderAuthor Commented:
Hi Rgonzo,

ok, you are right, but still the code snippet on line 8:

 'shp.Width = shp.Width * 1.5' leads to the distortion of the graphics.

It is a bug. I will award you the full points for your code since everything else works just fine.

Regards, Andreas
0
 
Andreas HermleTeam leaderAuthor Commented:
Hi Rgonzo,

thank you very much for your professional help. I will comment out line '8' and then everything is just fine.

Regards, Andreas
0
All Courses

From novice to tech pro — start learning today.