macro format değişikliği

[incsoft]

Arkadaşlar aşağıdaki macromla bmp formatındaki resimleri getiriyorum ancak jpg olduğu zaman maalesef gelmiyor. jpg'leri de ayrım yapmaksınız getirmesi için macro'ya nasıl bir eklenti yapmam gerekmektedir?

Teşekkürler...


Dim resim As Object, i As Long, yol As String, dosya As String
yol = Cells(1, "ı")
'Set Alan = Range("a1:a20") 'resim silinecek alan
Set Alan = Range("a1:a3") 'resim silinecek alan
Set Alan = Range("a5:a7") 'resim silinecek alan
Set Alan = Range("a9:a11") 'resim silinecek alan
Set Alan = Range("a13:a15") 'resim silinecek alan
Set Alan = Range("a17:a19") 'resim silinecek alan
For Each resimm In ActiveSheet.Pictures
If Not Intersect(resimm.TopLeftCell, Alan) Is Nothing Then
resimm.Delete
End If
Next
Set Alan = Nothing
For q = 1 To 20 Step 4
If Dir(yol & "\" & Cells(q + 3, "b").Value & ".bmp") <> "" Then 'resim adının alındığı alan
dosya = "\" & Cells(q + 3, "b").Value & ".bmp" 'resim adı
If TypeName(ActiveSheet) = "Worksheet" Then ' Exit Sub
Set P = ActiveSheet.Pictures.Insert(yol & dosya)
With Cells(q, "a") 'resmin konumlanacağı alan
t = .Top
l = .Left
w = .Offset(50, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 50).Top - .Top
End With
With P
.Top = t + 1
.Left = l + 1
.Width = w - 1
.Height = h - 1
End With
Set P = Nothing
End If
End If
Next q

Set Alan = Range("c1:c3") 'resim silinecek alan
Set Alan = Range("c5:c7") 'resim silinecek alan
Set Alan = Range("c9:c11") 'resim silinecek alan
Set Alan = Range("c13:c15") 'resim silinecek alan
Set Alan = Range("c17:c19") 'resim silinecek alan
For Each resimm In ActiveSheet.Pictures
If Not Intersect(resimm.TopLeftCell, Alan) Is Nothing Then
resimm.Delete
End If
Next
Set Alan = Nothing
For q = 1 To 20 Step 4
If Dir(yol & "\" & Cells(q + 3, "d").Value & ".bmp") <> "" Then 'resim adının alındığı alan
dosya = "\" & Cells(q + 3, "d").Value & ".bmp" 'resim adı
If TypeName(ActiveSheet) = "Worksheet" Then ' Exit Sub
Set P = ActiveSheet.Pictures.Insert(yol & dosya)
With Cells(q, "c") 'resmin konumlanacağı alan
t = .Top
l = .Left
w = .Offset(50, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 50).Top - .Top
End With
With P
.Top = t + 1
.Left = l + 1
.Width = w - 1
.Height = h - 1
End With
Set P = Nothing
End If
End If
Next q

Set Alan = Range("e1:e3") 'resim silinecek alan
Set Alan = Range("e5:e7") 'resim silinecek alan
Set Alan = Range("e9:e11") 'resim silinecek alan
Set Alan = Range("e13:e15") 'resim silinecek alan
Set Alan = Range("e17:e19") 'resim silinecek alan
For Each resimm In ActiveSheet.Pictures
If Not Intersect(resimm.TopLeftCell, Alan) Is Nothing Then
resimm.Delete
End If
Next
Set Alan = Nothing
For q = 1 To 20 Step 4
If Dir(yol & "\" & Cells(q + 3, "f").Value & ".bmp") <> "" Then 'resim adının alındığı alan
dosya = "\" & Cells(q + 3, "f").Value & ".bmp" 'resim adı
If TypeName(ActiveSheet) = "Worksheet" Then ' Exit Sub
Set P = ActiveSheet.Pictures.Insert(yol & dosya)
With Cells(q, "e") 'resmin konumlanacağı alan
t = .Top
l = .Left
w = .Offset(50, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 50).Top - .Top
End With
With P
.Top = t + 1
.Left = l + 1
.Width = w - 1
.Height = h - 1
End With
Set P = Nothing
End If
End If
Next q

Application.ScreenUpdating = True
End Sub