(.left property) and (LockAspectRatio) don't work

exceere · #1 06-12-2014, 11:11 AM

Hi,

In need help …

I have macro to insert picture into a sheet:

Code:

Sub Gen_InsertPicture()
Dim sPicture As String, pic As Picture
FilterPics = "All Pictures, *.gif;*.jpg;*.jpeg;*.jpe;*.bmp;*.png;*.tif"
sPicture = Application.GetOpenFilename(FilterPics, , "select picture")
If sPicture = "False" Then Exit Sub
Set pic = ActiveSheet.Pictures.Insert(sPicture)
With pic
.ShapeRange.LockAspectRatio = msoTrue
'.Height = Selection.Offset(Selection.Rows.Count, 0).Top - Selection.Top
.Width = Selection.Offset(0, Selection.Columns.Count).Left - Selection.Left
.Top = Selection.Top
.Left = Selection.Offset(0, Selection.Columns.Count).Left - .Width
.Placement = xlMoveAndSize
End With
Set pic = Nothing
If ActiveSheet.CodeName = "Sheet9" Then
    With Range("DrwgArea").Interior
        .Pattern = xlNone
    End With
End If
End Sub

why LockAspectRatio Not work perfectly in R-L and L-R sheets?

the file is Attached

whatsup · #2 06-12-2014, 12:34 PM

Hi

It hasn't got anything to do with L-R/R-L feature. The picture in its size of origin probably just doesn't fit on the sheet, therefore the ratioaspects get lost.

Enable the columns beyond AB and most probably it will do (otherwise you may enable a couple of rows as well). The other option is, to insert the picture on another sheet, arrange the seize there according to your selection, and copy it to the space desired.

macropod · #3 06-12-2014, 10:45 PM

Try:

Code:

Sub Gen_InsertPicture()
Application.ScreenUpdating = False
Dim sPicture As String, pic As Picture
FilterPics = "All Pictures, *.gif;*.jpg;*.jpeg;*.jpe;*.bmp;*.png;*.tif"
sPicture = Application.GetOpenFilename(FilterPics, , "select picture")
If sPicture = "False" Then Exit Sub
Set pic = ActiveSheet.Pictures.Insert(sPicture)
With pic.ShapeRange
  .ScaleWidth 0.01, True, msoScaleFromTopLeft
  .ScaleHeight 0.01, True, msoScaleFromTopLeft
  .LockAspectRatio = msoTrue
  .Height = Selection.Offset(Selection.Rows.Count, 0).Top - Selection.Top
  If .Width > Selection.Offset(0, Selection.Columns.Count).Left - Selection.Left Then
    .Width = Selection.Offset(0, Selection.Columns.Count).Left - Selection.Left
  End If
  .Top = Selection.Top
  .Left = Selection.Offset(0, Selection.Columns.Count).Left - .Width
End With
pic.Placement = xlMoveAndSize
Set pic = Nothing
If ActiveSheet.CodeName = "Sheet9" Then
    With Range("DrwgArea").Interior
        .Pattern = xlNone
    End With
End If
Application.ScreenUpdating = True
End Sub

Note that the original scaling gets restored by setting it to 1% of the original size (you may be able to start of with something much larger - I don't know what your picture sizes are) before adjusting it to the cell size. Also, after adjusting the height, the width only gets re-adjusted if it's still greater than the cell width.

exceere · #4 06-13-2014, 05:03 AM

macropod, you're a genius

IT WORKS PERFECTLY. JUST BY YOUR ADJUSTMENT

THANKS AGAIN...

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Converting a left to right doc to a right to left	seli	Word	3	04-23-2012 11:39 PM
Link Watermark to custom property	kerend	Word	0	04-08-2012 05:03 AM
Left arrow won't work on Word	LaBecs	Word	2	09-26-2011 09:27 AM
Access to the property of the current table	b0x4it	Word VBA	2	05-26-2011 06:25 AM
set icon for user property	nav1982	Outlook	0	11-11-2009 05:40 AM