Klasörden resim çekme

[semih001]

Selam kolay gelsin. Aşağıdaki kodu yazdım fakat kod çalışmıyor. Yardımcı olabilecek var mı acaba ?

İstediğim şey e3 hücresine bir sayı yazdığımda ( 3000 e kadar) "\\metsanqnap\üretim ve planlama\Semih\Ürün Resimleri" klasöründen o sayının olduğu resimleri çekmesi.

Resimler .jpg ve .png formatlarında. formülü kullanacağım excel sayfasının ismi " Öngörü " , Excelin adı ise " Termin Planlama "



Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [E3]) Is Nothing Then Exit Sub

On Error GoTo Git

Dim ResimYolu As Variant
Dim "\\metsanqnap\üretim ve planlama\Metsanindex\ÜRÜN RESİMLERİ" As Object
Dim S1 As Worksheet

Set S1 = Sheets("Öngörü")

S1.DrawingObjects.Delete

ResimYolu = ActiveWorkbook.Path & "\" & Range("E3") & ".jpg"
Set Resim = S1.Pictures.Insert(ResimYolu)

With S1.Range("BL20:BR30")
Resim.ShapeRange.LockAspectRatio = msoFalse
Resim.Top = .Top
Resim.Left = .Left
Resim.Height = .Height
Resim.Width = .Width
End With
Git:
End Sub

 

[semih001]

Yardımcı olabilecek varsa memnun olurum

 

[Muzaffer Ali]

Merhaba.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim ResimYolu As String
    If Not Intersect(Target, [E3]) Is Nothing Then
        DrawingObjects.Delete
        ResimYolu = ActiveWorkbook.Path & "\" & Range("E3")
        
        If Dir(ResimYolu & ".jpg") <> "" Then
            ResimYolu = ResimYolu & ".jpg"
        ElseIf Dir(ResimYolu & ".png") <> "" Then
            ResimYolu = ResimYolu & ".png"
        Else
            MsgBox "'" & Range("E3") & "' adlı resim bulunamıyor." & vbLf & "Lütfen kontrol edip yeniden deneyiniz."
            Exit Sub
        End If
        
        Set resim = Pictures.Insert(ResimYolu)
        With Range("BL20:BR30")
            resim.ShapeRange.LockAspectRatio = msoFalse
            resim.Top = .Top
            resim.Left = .Left
            resim.Height = .Height
            resim.Width = .Width
        End With
    End If
End Sub

 

[semih001]

Merhaba.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim ResimYolu As String
    If Not Intersect(Target, [E3]) Is Nothing Then
        DrawingObjects.Delete
        ResimYolu = ActiveWorkbook.Path & "\" & Range("E3")
       
        If Dir(ResimYolu & ".jpg") <> "" Then
            ResimYolu = ResimYolu & ".jpg"
        ElseIf Dir(ResimYolu & ".png") <> "" Then
            ResimYolu = ResimYolu & ".png"
        Else
            MsgBox "'" & Range("E3") & "' adlı resim bulunamıyor." & vbLf & "Lütfen kontrol edip yeniden deneyiniz."
            Exit Sub
        End If
       
        Set resim = Pictures.Insert(ResimYolu)
        With Range("BL20:BR30")
            resim.ShapeRange.LockAspectRatio = msoFalse
            resim.Top = .Top
            resim.Left = .Left
            resim.Height = .Height
            resim.Width = .Width
        End With
    End If
End Sub

Kod çalıştı. Çok teşekkür ederim..