I have been using the following code for placing a picture over a cell range in Excel. The code works beautifully for pictures obtained in the horizontal format but when a picture is selected that has a vertical format, the picture is placed far far outside the intended location. It usually ends up so far to the right of the intended location you have to zoom out to 25% to find it. I have tried several variations with handling the original orientation of the picture but to no avail. Any ideas out there about what could be causing this?
Sub Insert_Picture_Page1() Application.ScreenUpdating = False 'Insert and Size Photo Dim getPicture As Variant Dim myPictureCells As Range Dim DeadPicture As Shape 'Allow user to select the photo to insert getPicture = Application.GetOpenFilename _ ("Pictures (*.gif; *.jpg; *.bmp; *.tif; *.png),*.gif; *.jpg; *.bmp; *.tif *.png", , "Select Picture to Import") If VarType(getPicture) = vbBoolean Then MsgBox "Operation Cancelled" Else 'Unlock the Cell for the Action ActiveSheet.Unprotect 'Deletes the Previous Picture For Each DeadPicture In ActiveSheet.Shapes If DeadPicture.Name = "Page1Picture" Then DeadPicture.Delete End If Next DeadPicture 'Sets the insertion point Set myPictureCells = Range("U17:AP17") 'Name the picure so it can be deleted later when replaced (2010 Excel) ActiveSheet.Shapes.AddPicture(getPicture, False, True, -1, -1, -1, -1).Select Selection.Name = "Page1Picture" 'Sizes the picture to fit the box With Selection.ShapeRange .LockAspectRatio = msoTrue .Top = Range("U17:AP17").Top .Left = Range("U17:AP17").Left If Selection.ShapeRange.Width <> 269 Then Selection.ShapeRange.Width = 269 End If If Selection.ShapeRange.Height > 201 Then Selection.ShapeRange.Height = 201 End If 'Center the image and sends behind the button .IncrementLeft (myPictureCells.Width - Selection.ShapeRange.Width + 1) / 2 .IncrementTop (myPictureCells.Height - Selection.ShapeRange.Height) / 2 .ZOrder msoSendToBack End With End If 'Protects the Worksheet Again myPictureCells.Locked = True ActiveSheet.Protect DrawingObjects:=False, Contents:=True End Sub