Fit my screenshot to a merged cell range

[Chris Hoek]

Hello Excel folks.

I still consider myself pretty new to VBA, so please take this into consideration in your responses.

I have found several threads that were really close to what I was trying to accomplish here, but I've looked for several days now and I haven't found something that does exactly what I need it to do.

I will preface my post with this, I know you can't exactly paste a picture into a cell, I understand this limitation. But here is what I'm working on.

So, I've been working on creating a new per diem request form for work. Part of the form requires the user to go to the GSA website, pull up the per diem rate for their destination, take a screenshot of the rate at their destination being displayed on the GSA website, then paste the screenshot into a designated merged cell in the per diem request form.

Since most of our monitors at work have an aspect ratio of 16:9, I created a merged cell range that has approximately this same aspect ratio. The designated cell range is A28:O28. The height of row 28 was increased to 358 in order to achieve this aspect ratio.

What I would like to happen is for the user to take the screenshot, paste it into their per diem request form, decrease the size of the screenshot until it fits into the designated range,

then click my form control button that says "Fit screenshot to cell",

and for this to put the screenshot in the top left of the designated range
and to resize the screenshot to totally fill the designated range.
Additionally, I want the screenshot to fill the designated range regardless of the aspect ratio of the screenshot, therefore if someone were to crop their screenshot and it was no longer 16:9 aspect ratio, I want it to stretch this image in whatever way necessary to make it fit my designated range.

The code that I am currently using is giving me results that don't exactly meet my needs but it is the best one that I have found so far.

With this current code, wherever the screenshot is currently sitting within the range when the form control button is pressed, the screenshot will go to the top of the designated range and the left of whatever column the screenshot's left side is in, then the screenshot appears to increase in size until either the height limit or width limit is reached, then it stops there. Sometimes it stops within the designated range, sometimes the screenshot is partially hanging out of the designated range.

So, here is my current code:

Public Sub FitPic()
If TypeName(Selection) <> "Picture" Then GoTo NOT_SHAPE
Dim PicWtoHRatio As Single
Dim CellWtoHRatio As Single
With Selection
PicWtoHRatio = .Width / .Height
End With
With Selection.TopLeftCell
If .MergeCells Then
CellWtoHRatio = .MergeArea.Width / .MergeArea.Height
Else
CellWtoHRatio = .Width / .RowHeight
End If
End With
Select Case PicWtoHRatio / CellWtoHRatio
Case Is > 1
With Selection
If .TopLeftCell.MergeCells Then
.Width = .TopLeftCell.MergeArea.Width
Else
.Width = .TopLeftCell.Width
End If
.Height = .Width / PicWtoHRatio
End With
Case Else
With Selection
If .TopLeftCell.MergeCells Then
.Height = .TopLeftCell.MergeArea.Height
Else
.Height = .TopLeftCell.RowHeight
End If
.Width = .Height * PicWtoHRatio
End With
End Select
With Selection
.ShapeRange.LockAspectRatio = msoFalse
.Top = .TopLeftCell.Top
.Left = .TopLeftCell.Left
End With
Exit Sub
NOT_SHAPE:
MsgBox "Select a picture before running this macro."
End Sub


Please help!!!
Thanks in advance!
Chris

 

[tonyyy]

Chris,

You might give the following a try...

Public Sub FitPic2()
If TypeName(Selection) <> "Picture" Then GoTo NOT_SHAPE

With Selection
    .ShapeRange.LockAspectRatio = msoFalse
    .Top = Range("A28").Top
    .Left = Range("A28").Left
    .Width = Range("A28:O28").Width
    .Height = Range("A28:O28").Height
End With

Exit Sub
NOT_SHAPE:
MsgBox "Select a picture before running this macro."
End Sub

Cheers,

tonyyy

 

[Chris Hoek]

Thanks tonyyy. I'll give it a try first thing in the am and let you know how it goes.

Chris,

You might give the following a try...

Public Sub FitPic2()
If TypeName(Selection) <> "Picture" Then GoTo NOT_SHAPE

With Selection
    .ShapeRange.LockAspectRatio = msoFalse
    .Top = Range("A28").Top
    .Left = Range("A28").Left
    .Width = Range("A28:O28").Width
    .Height = Range("A28:O28").Height
End With

Exit Sub
NOT_SHAPE:
MsgBox "Select a picture before running this macro."
End Sub

Cheers,

tonyyy

 

[Chris Hoek]

Tonyyy,
your recommendation worked perfectly. I was really over complicating things.

Works absolutely perfect. Exactly what I was wanting it to do.

Thanks a million. You rock!


Chris

 

[tonyyy]

You're welcome, Chris. Glad it worked out...