Vba Insert Picture Not Work in. PNG format

[muhammad susanto]

hi all..

i have macro code to insert picture..actually, this macro work properly in only jpg format..
how to modified this macro can work in both .jpg and .png format.
here this code

Sub Button1_Click()
Dim pic As Picture, rng As Range
For Each pic In ActiveSheet.Pictures
    Set rng = Range(pic.TopLeftCell.Address, pic.BottomRightCell.Address)
    If Not Intersect(rng, Range("B6:F6")) Is Nothing Then
        pic.Delete
    End If
Next pic
End Sub

Sub Button2_Click()
On Error GoTo NOT_SHAPE
    Dim PicWtoHRatio As Single
    Dim CellWtoHRatio As Single
    Dim cel As Range
    Selection.Copy
    Set cel = Application.InputBox("Click on destination tab and cell", "", , , , , , 8)
    With cel
        .Parent.Activate
        .Activate
        .Parent.Paste
    End With
   
    With Selection
        PicWtoHRatio = .Width / .Height
    End With
    With cel
        CellWtoHRatio = .Width / .RowHeight
    End With
    Select Case PicWtoHRatio / CellWtoHRatio
        Case Is > 1
            With Selection
            .Width = cel.Width
            .Height = .Width / PicWtoHRatio
            End With
        Case Else
            With Selection
            .Height = cel.RowHeight
            .Width = .Height * PicWtoHRatio
            End With
    End Select
    With Selection
        .Top = cel.Top
        .Left = cel.Left
    End With
Exit Sub
NOT_SHAPE:
MsgBox "Select a picture before running this macro."
End Sub

any help me out . thanks in advance..

.sst

 

[muhammad susanto]

maybe thus

Sub Button1_Click()
Dim pic As Picture, rng As Range
For Each pic In ActiveSheet.Pictures
    Set rng = Range(pic.TopLeftCell.Address, pic.BottomRightCell.Address)
    If Not Intersect(rng, Range("B6:F6")) Is Nothing Then
       
    End If
Next pic
End Sub

 

[MARK858]

I don't understand your last post, the code does nothing

 

[muhammad susanto]

I don't understand your last post, the code does nothing

here new code

Sub Button1_Click()
Dim pic As Picture, rng As Range
For Each pic In ActiveSheet.Pictures
    Set rng = Range(pic.TopLeftCell.Address, pic.BottomRightCell.Address)
    If Not Intersect(rng, Range("B6:F6")) Is Nothing Then
           End If
Next pic
End Sub

Sub Button2_Click()
On Error GoTo NOT_SHAPE
    Dim PicWtoHRatio As Single
    Dim CellWtoHRatio As Single
    Dim cel As Range
    Selection.Copy
    Set cel = Application.InputBox("Click on destination tab and cell", "", , , , , , 8)
    With cel
        .Parent.Activate
        .Activate
        .Parent.Paste
    End With
   
    With Selection
        PicWtoHRatio = .Width / .Height
    End With
    With cel
        CellWtoHRatio = .Width / .RowHeight
    End With
    Select Case PicWtoHRatio / CellWtoHRatio
        Case Is > 1
            With Selection
            .Width = cel.Width
            .Height = .Width / PicWtoHRatio
            End With
        Case Else
            With Selection
            .Height = cel.RowHeight
            .Width = .Height * PicWtoHRatio
            End With
    End Select
    With Selection
        .Top = cel.Top
        .Left = cel.Left
    End With
Exit Sub
NOT_SHAPE:
MsgBox "Select a picture before running this macro."
End Sub

i'm delete line code "pic.delete", but still not working.

 

[MARK858]

The pic.delete is not an issue, your picture being outside of the range is.

As I have already asked.. state what you want the code to do in words.

 

[muhammad susanto]

i just want that code can work to insert picture in 2 format e.g .jpg & .png .

 

[MARK858]

Not enough detail for me to write code.

 

[muhammad susanto]

ok, my target picture placing in cell Range ("B6:F6"). in that range contains merge cell like this:
in cell B6 - as single cell
in cell C6-D6 - as merged cell
in cell E6-F6 - as merged cell
picture inserted in cell above, and must resize (autofit)
if picture in .jpg format the macro code running well..but if the picture in .png the macro can't find .png
i want to picture in .jpg or .png can be inserted as well.
i hope this make clear.

 

[MARK858]

Your Button2_Click macro inserted a Png into the cells and resized it fine for me (although the size and width will be restricted by the size of the first cell in the range in proportion).

 

[muhammad susanto]

Hi Mark, thank you... I think this my problem, I, m using Excel 2016 ,, there are many problem when using Macro/Vba... I'm often occuring this issue. I don't know why, this not my first happen to me.

 

[muhammad susanto]

hi all...
how to rename extension file (.jpg) to .png format using Vba..
i found code below but not work, how to fix it..

Option Explicit
Sub test()
Dim strSourceFile As String
    Dim strSourceDirectory As String
    Dim counter As Long
   
    strSourceDirectory = "C:\Test\ok"
       
    strSourceFile = Dir(strSourceDirectory & "*.jpg")
   
    Do While strSourceFile <> ""
        Name strSourceDirectory & strSourceFile As strSourceDirectory & Replace$(strSourceFile, [B]".jpg", ".png[/B]")
        counter = counter + 1
        strSourceFile = Dir()
    Loop
   
    MsgBox counter & " files renamed.", , "Rename Files Complete"
    End Sub

my images in folder c:/Test\ok..
or the other code with the same function

any help, greatly appreciated.

.sst

related with my problem above, i think to find a way..
may be someone to figure out about rename image .jpg to .png format
maybe above code modified or someone have other code