Solved

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

Posted on 2013-11-14
7
1,214 Views
Last Modified: 2013-11-21
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

0
Comment
Question by:AndreasHermle
  • 4
  • 3
7 Comments
 
LVL 48

Expert Comment

by:Rgonzo1971
ID: 39647372
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
 

Author Comment

by:AndreasHermle
ID: 39654474
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
 
LVL 48

Accepted Solution

by:
Rgonzo1971 earned 500 total points
ID: 39658573
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
A Knowledge Base That Stays Up-to-Date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

 

Author Comment

by:AndreasHermle
ID: 39662220
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
 
LVL 48

Expert Comment

by:Rgonzo1971
ID: 39662292
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
 

Author Comment

by:AndreasHermle
ID: 39666866
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
 

Author Closing Comment

by:AndreasHermle
ID: 39666874
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

Featured Post

IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

If you work with Word a lot, you probably use styles. If you use styles a lot, you've probably balled your fist more often than not when working with the ribbon. In Word 2007/2010, one of the things that I find missing when using styles is a quic…
Preface: When I started this series, I used the term CommandBars because that is the Office Object class that it discusses. Unfortunately, when Microsoft introduced Office 2007, they replaced the standard Commandbar menus with "The Ribbon" and rem…
Learn how to make your own table of contents in Microsoft Word using paragraph styles and the automatic table of contents tool. We'll be using the paragraph styles in Word’s Home toolbar to help you create a table of contents. Type out your initial …
Office 365 is currently available in five editions. Three of them are for business use: Office 365 Business Essentials, Office 365 Business, and Office 365 Business Premium. Two of them are for home/personal use: Office 365 Home and Office 365 Perso…

743 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

17 Experts available now in Live!

Get 1:1 Help Now