VBA to choose pic, and insert into specified merged cell

[DCGNM]

Hi All

I need help with a code that i want to apply to my Button that does as such.

Choose a pic from desktop, and insert it into specified Cell(Merged). The pic should then be centered in the cell, and enlarged/shrank to fit, while maintaining it's aspect ratio.

Appreciate any help that you guys can render.

 

[Yongle]

try:

Sub ChangeImage()
    Dim Pic     As Object
    Dim rng     As Range: Set rng = Range("[COLOR=#ff0000]A1[/COLOR]").MergeArea
   
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .Title = "Select an image file"
        .Filters.Clear
        .Filters.Add "JPG", "*.JPG"
        .Filters.Add "All Pictures", "*.*"

        If .Show = -1 Then
            Set Pic = ActiveSheet.Pictures.Insert(.SelectedItems(1))
            With rng
                Pic.Top = .Top
                Pic.Height = .Height
                Pic.Left = .Left + 0.5 * (.Width - Pic.Width)
            End With
        End If
    End With
End Sub

 

[DCGNM]

Hi Yongle

Thank you so much. It worked perfectly. Sorry to trouble you. But if i want to add other picture formats like PNG, GIF. how do i add to the code?
also, if i want the picture to paste in 2 different mergearea, instead of the one(might need to paste the same picture in another sheet with the same size merged cell), how do i add to the code?

Thanks once again.

 

[Yongle]

But if i want to add other picture formats like PNG, GIF. how do i add to the code?

        .Filters.Add "JPG", "*.JPG"
        .Filters.Add "Graphics Interchange Format", "*.GIF"
        .Filters.Add "Portable Network Graphics", "*.PNG"
        .Filters.Add "All Pictures", "*.*"

 

[DCGNM]

Hi Yongle

Thanks again. Sorry, there was another question in the earlier reply.
What if i want to paste the picture in 2 different merged cells? would i need to set another rng2 =? and how would i add it in the code for it to insert the picture into 2 areas, both across different sheets.

 

[Yongle]

if i want the picture to paste in 2 different mergearea, instead of the one(might need to paste the same picture in another sheet with the same size merged cell), how do i add to the code?

[I] [COLOR=#a9a9a9]........previous code..[/COLOR]
     [COLOR=#d3d3d3]End With[/COLOR][/I]
[I]'insert Pic in other sheet[/I]
     Set rng = Sheets("[COLOR=#006400]Sheet2[/COLOR]").Range("[COLOR=#006400]C2[/COLOR]").MergeArea
     With rng
        Pic.Copy
        .Parent.Paste
        Set Pic = .Parent.Shapes(.Parent.Shapes.Count)
        Pic.Top = .Top
        Pic.Left = .Left + 0.5 * (.Width - Pic.Width)
    End With
[I][COLOR=#808080]End Sub[/COLOR][/I]

 

[DCGNM]

Thank you Yongle. That works perfect now. I don't know how you guys remember all these. Try as i do, i can never master the logic

 

[Yongle]

I don't know how you guys remember all these

- my memory is a very fat well-thumbed notebook

thanks for the feedback

 

[DCGNM]

Hi Yongle

Sorry to refresh this topic. But i am experiencing cases whereby the picture's width is wide, and height short, the code tries to automatically autofit the height to the merged cells height, thereby blowing up the picture in terms of width, overflowing horizontally out of the merged cells(not keeping the width within the merged cells).

 

[Yongle]

after

                Pic.Height = .Height

insert

                If Pic.Width > .Width Then Pic.Width = .Width