VBA - JPG ve PNG resim çağırma.

[emrekahya]

Merhabalar,

Aşağıdaki gibi kodlama yapım mevcut. Bu kodlama jpg türevleri için geçerli. Dosya png formatında olduğu zaman sorun yaratıyor. Bunu nasıl düzeltebilirim.

Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, [B1]) Is Nothing Then Exit Sub
On Error GoTo çıkış
ActiveSheet.DrawingObjects.Delete
Dim ResimYolu As Variant
Dim Resim As Object
ResimYolu = ActiveWorkbook.Path & "\" & Range("B1") & ".jpg"
Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)
With Range("D1")
Resim.Top = .Top
Resim.Left = .Left
Resim.Height = .Height
Resim.Width = .Width

End With
çıkış:
End Sub

 

[Muzaffer Ali]

Merhaba.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim ResimYolu As String
    Dim Resim As Object
    
    If Not Intersect(Target, [B1]) Is Nothing Then
        ActiveSheet.DrawingObjects.Delete
        ResimYolu = ActiveWorkbook.Path & "\" & Range("B1")

        If Dir(ResimYolu & ".png") <> "" Then
            ResimYolu = ResimYolu & ".png"
        ElseIf Dir(ResimYolu & ".jpg") <> "" Then
            ResimYolu = ResimYolu & ".jpg"
        Else
            MsgBox ResimYolu & vbLf & "Bu dosya bulunamıyor."
            Exit Sub
        End If
        
        Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)
        
        With Range("D1")
            Resim.Top = .Top
            Resim.Left = .Left
            Resim.Height = .Height
            Resim.Width = .Width
        End With
    End If
End Sub

 

[emrekahya]

Merhaba; Bold olarak yaptığım yerden hata almaktayım.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ResimYolu As String
Dim Resim As Object

If Not Intersect(Target, [B1]) Is Nothing Then
ActiveSheet.DrawingObjects.Delete
ResimYolu = ActiveWorkbook.Path & "\" & Range("B1")

If Dir(ResimYolu & ".png") <> "" Then
ResimYolu = ResimYolu & ".png"
ElseIf Dir(ResimYolu & ".jpg") <> "" Then
ResimYolu = ResimYolu & ".jpg"
End If

Set Resim = ActiveSheet.Pictures.Insert(ResimYolu)

With Range("D1")
Resim.Top = .Top
Resim.Left = .Left
Resim.Height = .Height
Resim.Width = .Width
End With
End If
End Sub