Go1rish
New Member
- Joined
- Mar 25, 2014
- Messages
- 5
Hello. I have built a code that will replace an image in 3 separate sheets in my workbook; however- sometimes the images are "portrait", sometimes, they are "landscape." I want to max out the size of the image when the pictures are replaced. (By the way - each sheet has the image placed at a separate size.)
Working Form -- max width: 125, maximum height: 160 (Largest size possible is 125 x 160)
Set-up Sheet --- max width: 253, maximum height: 310 (Largest size possible is 253 x 310)
Quote Sheet --- max width: 360, maximum height: 465 (Largest size possible is 360 x 465)
The code (as below) works brilliantly when the image formats are always in he aspect ratio of 8.5" x 11" and in "portrait" orientation.
How man I modify this code so no matter what the orientation or size, the image will always be maxed out without going beyond these parameters?
P.S. - Thank you to whoever shared "Swap Pic." I love it.
Working Form -- max width: 125, maximum height: 160 (Largest size possible is 125 x 160)
Set-up Sheet --- max width: 253, maximum height: 310 (Largest size possible is 253 x 310)
Quote Sheet --- max width: 360, maximum height: 465 (Largest size possible is 360 x 465)
The code (as below) works brilliantly when the image formats are always in he aspect ratio of 8.5" x 11" and in "portrait" orientation.
How man I modify this code so no matter what the orientation or size, the image will always be maxed out without going beyond these parameters?
VBA Code:
Sub SwapPic()
Dim PicFileName As String
With Application.FileDialog(msoFileDialogFilePicker)
.Show
On Error Resume Next
PicFileName = .SelectedItems(1)
On Error GoTo 0
End With
If PicFileName = "" Then Exit Sub
With ActiveSheet.Shapes(Application.Caller)
.TopLeftCell.Select
.Delete
End With
With ActiveSheet.Pictures.Insert(PicFileName)
.Name = "UserPic"
.OnAction = "SwapPic"
End With
With ActiveSheet.Shapes.Range(Array("UserPic")).Select
Selection.ShapeRange.Width = 125
End With
'Delete Pic on Set-up Sheet
With Sheets("Set-up Sheet").Select
ActiveSheet.Shapes.Range(Array("UserPic")).Select
Selection.Delete
End With
'Delete Pic on Quote Sheet
With Sheets("Quote Sheet").Select
ActiveSheet.Shapes.Range(Array("UserPic")).Select
Selection.Delete
End With
'Copy Working Form Pic
With Sheets("Working Form").Select
ActiveSheet.Shapes.Range(Array("UserPic")).Select
Selection.Copy
End With
'Paste to Set-up Sheet and Adjust Size
With Sheets("Set-up Sheet").Select
Range("A183:A203").Select
ActiveSheet.Paste
ActiveSheet.Shapes.Range(Array("UserPic")).Select
Selection.ShapeRange.Width = 240
End With
'Paste to Quote Sheet and adjust size
With Sheets("Quote Sheet").Select
Range("B8:D25").Select
ActiveSheet.Paste
ActiveSheet.Shapes.Range(Array("UserPic")).Select
Selection.ShapeRange.Width = 360
End With
'back to Working Form
With Sheets("Working Form").Select
Range("I3:N3").Select
End With
End Sub
P.S. - Thank you to whoever shared "Swap Pic." I love it.
Last edited by a moderator: