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