400 error, picture insert, resize

Hi Chris

I think this is what you want

Sub PictureInsert()
    
    Dim pic As Picture
    Dim sPic As String
    Dim rPos As Range
    Dim ws As Worksheet
    Dim shp As Shape
    Dim fMod As Double
           
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    Set rPos = ws.Range(Selection.Address)
        
    sPic = Application.Dialogs(xlDialogInsertPicture).Show
    If TypeName(Selection) <> "Picture" Then Exit Sub
    Set pic = Selection
    
    fMod = IIf(rPos.Height / pic.Height < rPos.Width / pic.Width, rPos.Height / pic.Height, rPos.Width / pic.Width)
        
    With pic
        .ShapeRange.LockAspectRatio = msoFalse
        .Width = pic.Width * fMod
        .Height = pic.Height * fMod
        .Left = rPos.Left + (rPos.Width / 2) - (.Width / 2)
        .Top = rPos.Top + (rPos.Height / 2) - (.Height / 2)
    End With
        
End Sub

wow works great, thanks a lot. just one more question

is it possible to delete any picture already in the selected range first before putting the new picture in?

Chris

Glad it helped Chris. I don't think there is a way to directly reference pictures within a range, although you could cycle through each shape within a worksheet, and determine whether any extents of a picture fall within the extents of the range, deleting as appropriate.
Dave

Found a way to do it, and put some error handling incase no range is selected. but now i'm having the problem that if you cancel putting in the new picture the old picture is still deleted. any way around this that the the old picture is deleted only if a new picture is selected?

Chris

ps. posted the revised code below.

Option Explicit
Sub PictureInsert()
    
    Dim Pic As Picture
    Dim sPic As String
    Dim rPos As Range
    Dim ws As Worksheet
    Dim shp As Shape
    Dim fMod As Double
    Dim errhandler As String
    
    On Error GoTo errhandler:
    
    Call PicDelete
    
    Set ws = ThisWorkbook.Worksheets("Sheet1")
        
    Set rPos = ws.Range(Selection.Address)
            
            
    sPic = Application.Dialogs(xlDialogInsertPicture).Show
    If TypeName(Selection) <> "Picture" Then Exit Sub
    Set Pic = Selection
    
        
    fMod = IIf(rPos.Height / Pic.Height < rPos.Width / Pic.Width, rPos.Height / Pic.Height, rPos.Width / Pic.Width)
        
    With Pic
        .ShapeRange.LockAspectRatio = msoFalse
        .Width = Pic.Width * fMod
        .Height = Pic.Height * fMod
        .Left = rPos.Left + (rPos.Width / 2) - (.Width / 2)
        .Top = rPos.Top + (rPos.Height / 2) - (.Height / 2)
    End With
        
    Exit Sub
    
errhandler:
 MsgBox "Please Select a range and try again", vbCritical
 
    
End Sub

Sub PicDelete()
Dim s As String
Dim Pic As Picture
Dim rng As Range
Dim ws As Worksheet

Set ws = ActiveWorkbook.Worksheets("Sheet1")

Set rng = ws.Range(Selection.Address)

For Each Pic In ActiveSheet.Pictures
With Pic
s = .TopLeftCell.Address & ":" & .BottomRightCell.Address
End With
If Not Intersect(rng, ws.Range(s)) Is Nothing Then
Pic.Delete
End If
Next

End Sub

Well, before this thread I didn't know about IIf, Intersect, and the top left / bottom right cell references for shapes, so I'm doing well!

Here's what you want, code tidied up and commented.

Option Explicit

Sub PictureInsert()
    
    Dim picNew As Picture
    Dim picThis As Picture
    Dim rngSel As Range
    Dim rngPic As Range
    Dim wksThis As Worksheet
    Dim fMod As Double
    Dim fw As Double
    Dim fh As Double
    
    'Turn on error handling
    On Error GoTo Error_PictureInsert
    
    'Set reference to active sheet
    Set wksThis = ActiveSheet
    
    'Ensure selection is a range
    If TypeName(Selection) <> "Range" Then
        MsgBox "Select a range", vbCritical
        Exit Sub
    End If
    
    'Set reference to selected range
    Set rngSel = Selection
            
    'Get picture to insert
    If Not Application.Dialogs(xlDialogInsertPicture).Show Then Exit Sub
    
    'Check current selection is a picture
    If TypeName(Selection) <> "Picture" Then Exit Sub
    
    'Set reference to this picture
    Set picNew = Selection
    
    'Determine resizing required
    fh = rngSel.Height / picNew.Height
    fw = rngSel.Width / picNew.Width
    fMod = IIf(fh < fw, fh, fw)
        
    'Resize and placement
    With picNew
        .ShapeRange.LockAspectRatio = msoFalse
        .Width = .Width * fMod
        .Height = .Height * fMod
        .Left = rngSel.Left + (rngSel.Width / 2) - (.Width / 2)
        .Top = rngSel.Top + (rngSel.Height / 2) - (.Height / 2)
    End With
    
    'Look at all shapes in sheet
    For Each picThis In wksThis.Pictures
        Set rngPic = wksThis.Range(picThis.TopLeftCell.Address & ":" & picThis.BottomRightCell.Address)
        If Not Intersect(rngSel, rngPic) Is Nothing Then
            'Picture falls within selected range
            'delete if not the newly inserted picture
            If picThis.Name <> picNew.Name Then picThis.Delete
        End If
    Next picThis
    
    'Return selection to original range
    rngSel.Select

    Exit Sub
    
Error_PictureInsert:
    'Report error
    MsgBox "An error has occured" & vbNewLine & Err.Description, vbCritical
    Resume Exit_PictureInsert
Exit_PictureInsert:

End Sub

cheers
Dave

Wow, that is exactly what i was looking for, well written too. thanks for taking the time to help me out and i'm glad you learned something too.

Take care and thanks again

Chris