Soru klasörden fotograf çağırma ve mail gönderme

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Column = 8 Then
    Filt = "Resim Files (*.jpg*),*.png*"
    FilterIndex = 10
    Title = "Dosya Seçin"
    dosyaadi = Application.GetOpenFilename(FileFilter:=Filt, _
    FilterIndex:=FilterIndex, Title:=Title, MultiSelect:=True)
    If Not IsArray(dosyaadi) Then
        MsgBox ".Dosya seçmediniz", vbInformation + vbMsgBoxRtlReading, "Www.ExcelDestek.Com"
        Exit Sub
    End If
Dosya = dosyaadi(1)
ActiveCell = Dosya

On Error Resume Next
Set pic = ActiveSheet.Pictures.Insert(Dosya)
On Error GoTo 0
If Not pic Is Nothing Then
Set Rng = ActiveCell
With pic
.Height = Rng.Height
.Width = Rng.Width
.Left = Rng.Left
.Top = Rng.Top
    h = 75 * (Val(900) + 1500) / 2000
  .Height = h
    w = 75 * (Val(300) + 1500) / 2000
.Width = w
End With
End If
End If
End Sub

Sub ExcelDepo()
son = Cells(Rows.Count, "I").End(xlUp).Row
ilk = 2
For i = 2 To son + Cells(son, "I").Value
'If Not i = son + Cells(son, "I").Value Then
If Not Cells(i, 3) = Cells(i + 1, 3) And Not "" = Cells(i + 1, 3) Then
Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
  With OutMail
            .To = Cells(ilk, 3).Value
            .CC = ""
            .BCC = ""
            .Subject = "konu nedir"
            .Body = "mesajınız"
'            .HtmlBody = ""
sonx = i
For j = ilk To sonx
.Attachments.Add Cells(j, "h").Value
Next j
        .display
   
'            .Send
            End With
        On Error GoTo 0
                Set OutMail = Nothing
        Set OutApp = Nothing
ilk = i + 1
End If

If i = son + Cells(son, "I").Value Then
Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
  With OutMail
            .To = Cells(ilk, 3).Value
            .CC = ""
            .BCC = ""
            .Subject = "konu nedir"
            .Body = "mesajınız"
'            .HtmlBody = ""
'sonx = i

For j = 4 To 7
.Attachments.Add Cells(j, "h").Value
Next j
        .display
   
'            .Send
            End With
        On Error GoTo 0
                Set OutMail = Nothing
        Set OutApp = Nothing
       
End If
Next i
End Sub