Solved

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

Posted on 2013-11-14
7
1,416 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 4
  • 3
7 Comments
 
LVL 51

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 51

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
Free Tool: Path Explorer

An intuitive utility to help find the CSS path to UI elements on a webpage. These paths are used frequently in a variety of front-end development and QA automation tasks.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

 

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 51

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

Free Tool: Site Down Detector

Helpful to verify reports of your own downtime, or to double check a downed website you are trying to access.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Suggested Solutions

A few years ago I was very much a beginner at VBA, and that very much remains the case today.  I'll do my best to explain things as I go in the hope that other beginners can follow.  If you just want to check out a tool that creates a Select Case fu…
You need to know the location of the Office templates folder, so that when you create new templates, they are saved to that location, and thus are available for selection when creating new documents.  The steps to find the Templates folder path are …
This video walks the viewer through the process of creating a watermark for their document, customizing it, and saving it for viewing/printing needs.
This video walks the viewer through the process of creating an MLA formatted document, as well as a bibliography with citations.
Suggested Courses

738 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