Solved

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

Posted on 2013-11-14
7
1,340 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 50

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 50

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: 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.

 

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 50

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: ZipGrep

ZipGrep is a utility that can list and search zip (.war, .ear, .jar, etc) archives for text patterns, without the need to extract the archive's contents.

One of a set of tools we're offering as a way to say 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

It is often necessary in this forum and others to illustrate Word fields as text with the field delimiters replaced with the curly brackets that the delimiters resemble when field codes are being displayed on the document. This means that the text c…
Microsoft Word is a program we have all encountered at some point, but very few of us have dug deep into its full scope of features, let alone customized it to suit our needs. Luckily making the ribbon (aka toolbar, first introduced in Word 2007) wo…
This video shows the viewer how to set up and create Footnotes in their document. Click on the References tab: Select "Insert Footnote": Type in desired text:
Learn how to create and modify your own paragraph styles in Microsoft Word. This can be helpful when wanting to make consistently referenced styles throughout a document or template.

820 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