Pasting Photos to fit inside a specific cell/row area on a worksheet 2

[Walter349]

I've had a look around and not found anything that seems to address this issue.

We have a number of staff using a spreadsheet, designed as a data form( NOT a User form). One of the things they have to do when completing it, is to copy a photo from another propriety database and paste it onto the spreadsheet form, using copy paste.

Due to security considerations, there is no way to address the database directly.

There is a dedicated area on the worksheet for this, B2 - F16, Each row is 0.25" High, each column is 0.68" wide. The office version is MSO 2010.

Heres' the question;

Is there a way using VBA to constrain the pasted photo within the assigned row and column space automatically when the paste action happens?

At the moment they need to fiddle around to drag and stretch it to fit in. This takes additional time and really, really annoys them.

I am assuming it will be an event action of some sort.

'If at first you don't succeed, then your hammer is below specifications'

 

[N1GHTEYES]

Instead of copying and pasting directly, could they copy from the database, then click a button on your workbook, to have the workbook control the pasting and sizing of the picture?

If so:

open your workbook & database
copy the picture from the database to the clipboard
start recording a macro in your workbook
paste the picture into the workbook
adjust the edges to fit
stop recording the macro

Now put the macro behind a button.

Then, when you want to paste a pic in future:
copy the pic from the database to the clipboard, and simply click the macro button on the workbook.

Not elegant, I'll grant you, but I think it ought to work.

Even if it is not perfect, it should give you some insights into how you'd need to modify the macro to do exactly what you want.

Tony

 

[SkipVought]

hi,

Assuming that the pic has just been pasted into the sheet...

With activesheet.shapes(activesheet.shapes.count)
   .top = CellRangeOfInteret.top
   .left = CellRangeOfInteret.left
   .width = CellRangeOfInteret.width
   .height = CellRangeOfInteret.height
End with

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[Walter349]

Thank you both,

I went with Skips solution on this as it seemed cleaner and he has history on solving my lack of knowledge.

This is what I have used, but it puts the photo in cell "B2" only and does not stretch it across the required range.

Now it does not flag any errors and runs. So clearly I am doing something wrong with the ranges. but have tried several variations TNA.

Private Size_Shape()
With activesheet.shapes(activesheet.shapes.count)   

.top = Range("B2").top   
.left = Range("B2").left   
.width = Range("F2").width   
.height = Range("F16").height

End with

'If at first you don't succeed, then your hammer is below specifications'

 

[Walter349]

OKAY, Major brain fade.

Alright, so I hadn't had my first cup of coffee for the day.

Fixed it, Should have been B2:F2 and B2:f16.

Thanks

'If at first you don't succeed, then your hammer is below specifications'

 

[Walter349]

Here is the final code.

Note that it needs the lockaspectratio setting or the photo can over run the range area. It does mean that with some photos, they will be justified to the left, leaving a possible blank area on the right in the range. This is dependant on the dimensions of the original photo.

This will automatically resize to the specified range once the photo is pasted to the top left cell in the range(B2)

Private Sub worksheet_change(ByVal target As Excel.Range)
If target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(target, Range("B2")) Is Nothing Then
        With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
            .LockAspectRatio = False
            .Top = Range("B2").Top
            .Left = Range("B2").Left
            .Width = Range("B2:F2").Width
            .Height = Range("B2:F16").Height
        End With
End If
End Sub

'If at first you don't succeed, then your hammer is below specifications'

 

[SkipVought]

Always look for a consistent approach...

Private Sub worksheet_change(ByVal target As Excel.Range)
    Dim rng as range

    set rng = Range("B2:F16")

    If target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(target, Range("B2")) Is Nothing Then
        With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
            .LockAspectRatio = False
            .Top = rng.Top
            .Left = rng.Left
            .Width = rng.Width
            .Height = rng.Height
        End With
    End If

    set rng = nothing

End Sub

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}