Macro to resize and crop shape works in Word 2010, but not 2007?

[iptsatzzo]

G'day All,

I have a macro adapted from code obtained from multiple web-sources which works as intended in a Word 2010 doc (*.docx), but not in a Word 2007 doc (*.doc), still in the Word 2010 environment.

The goal of the macro is to paste a picture (shape, or inlineshape), set the width to 18cm while maintaining the original aspect ratio, then "reverse crop" the bottom of the picture by 0.5cm. Working with a "*.doc" format document in Word 2010, the result is a picture with the correct cropping and width, but the aspect ratio has changed, distorting the picture.

Eg:

Original picture size (height/width in cm): 24.26/29.16
Pasted picture size: 13.73/16.49 (57/57% of original)

If pasted to a "*.docx" (Word 2010) format document, the result of running the macro is: 15.28/18.00 (62/62% of original)

If pasted to a "*.doc" (Word 2007) format document, the result of running the macro is: : 13.99/18.00 (57/62% of original)

The full code follows (it's not long :)):


Sub Paste_SizeAndCrop_FEH_DEH()


Dim Rng As Range
Set Rng = Selection.Range
With Rng
.Paste
If .ShapeRange.Count = 1 Then
With .ShapeRange(1)
.LockAspectRatio = msoTrue
.Width = CentimetersToPoints(18)
With .PictureFormat
.CropBottom = CentimetersToPoints(-0.5)
End With
End With
ElseIf .InlineShapes.Count = 1 Then
With .InlineShapes(1)
.LockAspectRatio = msoTrue
.Width = CentimetersToPoints(18)
With .PictureFormat
.CropBottom = CentimetersToPoints(-0.5)
End With
End With
End If
End With
End Sub


I can't replicate the error by manually following the actions of the macro, and am out of ideas.

Any assistance would be appreciated!

Thanks!

[iptsatzzo]

Sorry - System details: Office 2010, Windows 7 Prof/SP 1, i5 8GB RAM, 64-bit

[Dave]

After pasting the picture....


Dim ObjPic As Object
'pictures in newxl version are converted to inlineshapes
'takes time to paste and convert
Application.Wait (Now + TimeValue("0:00:02"))
For Each ObjPic In ActiveDocument.InlineShapes
ObjPic.ConvertToShape
Next ObjPic
HTH. Dave

[iptsatzzo]

Thanks Dave. I had some problems though.

1) "Application.Wait" wasn't recognised - seems to be exclusive to Excel (or at least, not Word).

Some searching found me another means of delaying after pasting:

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'Goes in the "General Declarations" section.

'Eg:

Sleep (1000) 'Is placed in the code - waits for 1 second

This worked OK in place of "Application.Wait", but then:

2) 12921

Debugging then highlights the "ObjPic.ConvertToShape" line of code.

More searching hasn't helped me resolve that one - do you have any ideas?

Thanks!

[Dave]

I hate Word VBA and yes that was XL VBA.... my apologies. I've had past problems with pasting pictures in different MS versions of Word and the converttoshape thing was the solution. My understanding of your needs is that the code works for 2010 but does not resize the pic correctly for 07 office version. I've spent a few hours messing with your code on both office 07 and 2010 and for several different pictures (same pic compared on both versions) and I can't seem to replicate your problem. I really don't understand why sometimes the pic is pasted as a shaperange and sometimes as an inlineshape. I'll repost your code with a bit of extra stuff for testing purposes if any one has time? To test, paste the code in the document code section. Copy a picture to the clipboard and then run the macro. HTH. Dave

Sub Paste_SizeAndCrop_FEH_DEH()
Dim Rng As Range
Set Rng = Selection.Range
With Rng
.Paste
If .ShapeRange.Count = 1 Then
With .ShapeRange(1)
.LockAspectRatio = msoTrue
.Width = CentimetersToPoints(18)
With .PictureFormat
.CropBottom = CentimetersToPoints(-0.5)
End With
MsgBox "Shaperange " & .Height & "/" & .Width
End With
ElseIf .InlineShapes.Count = 1 Then
With .InlineShapes(1)
.LockAspectRatio = msoTrue
.Width = CentimetersToPoints(18)
With .PictureFormat
.CropBottom = CentimetersToPoints(-0.5)
End With
MsgBox "InlineShape " & .Height & "/" & .Width
End With
End If
End With
End Sub

[iptsatzzo]

G'day Dave,

Sorry for taking so long to reply each time - work, time-zones, etc.

I am not sure if the picture is pasted sometimes as a Shape and sometimes as an InlineShape - I borrowed that code, and kept both for redundancy. For the sake of testing, I have just split the code into two subs, and tested them separately - ie, one only dealing with Shapes and the other only with InlineShapes. Ie:


Sub Paste_SizeAndCrop_FEH_DShape()Dim Rng As Range
Set Rng = Selection.Range
With Rng
.Paste


With .ShapeRange(1)
.LockAspectRatio = msoTrue
.Width = CentimetersToPoints(18)
With .PictureFormat
.CropBottom = CentimetersToPoints(-0.5)
End With
MsgBox "Shaperange " & .Height & "/" & .Width
End With
End With
End Sub

and:


Sub Paste_SizeAndCrop_FEH_DEHInline()
Dim Rng As Range
Set Rng = Selection.Range
With Rng
.Paste


With .InlineShapes(1)
.LockAspectRatio = msoTrue
.Width = CentimetersToPoints(18)
With .PictureFormat
.CropBottom = CentimetersToPoints(-0.5)
End With
MsgBox "InlineShape " & .Height & "/" & .Width
End With
End With
End Sub



Only the "InlineShape" version works, the other throws a "Run-time error '5': Invalid procedure call or argument", (debug highlights "With .ShapeRange(1)") so I suppose I am pasting InlineShapes. However, the "InlineShape" sub still does not work properly in the *.doc environment - the picture aspect ratio changes to be slightly stretched in the horizontal direction.

If I save the *.doc as a *docx, the code works, but I want to avoid doing that, as most of my colleagues work with the *.doc format, and I don't wish to inadvertently introduce formatting issues by the conversions from one form to the other and then back.

:think: