Still celebrating National IT Professionals Day with 3 months of free Premium Membership. Use Code ITDAY17

x
?
Solved

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

Posted on 2013-11-14
7
Medium Priority
?
1,601 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 53

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 53

Accepted Solution

by:
Rgonzo1971 earned 2000 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
How to Use the Help Bell

Need to boost the visibility of your question for solutions? Use the Experts Exchange Help Bell to confirm priority levels and contact subject-matter experts for question attention.  Check out this how-to article for more information.

 

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 53

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

Introduction Authors who set out to write any sort of lengthy piece for online submission—be it a long question or comment on a technical form, an article, or a substantial blog entry—often find it useful to work up a draft in an editor other t…
Nice table. Huge mess. Maybe this was something you created way back before you figured out tabs or a document you received from someone else. Either way, using the spacebar to separate the columns resulted in a mess. Trying to convert text to t…
This video teaches the viewer how to align pictures around text while keeping the text properly aligned in the document.
This video walks the viewer through the process of creating an MLA formatted document, as well as a bibliography with citations.

670 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