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

wolfret

Member
Üye
#1
merhaaba,

excel içerisine, klasörlerdeki fotografları alıcam ve sonrada bu excel içerisinde bulunan mail adreslerine . gönderim yapmak istiyorum.....
 

metehan8001

Moderator
Yönetici
Moderatör
#4
Ekleyeceğiniz resim sayısı bir den fazlamı ? Yani göndereceğiniz resim sayısı ?
Ayrıca resimler ekli dosya olarak mı gidecek yoksa mail gövdesinde mi olacak.
 

metehan8001

Moderator
Yönetici
Moderatör
#10
Mail ile dosya olarak gideceğin den, gerek duymadım. H hücresinde hangi birine resim sigdirabileceksiniz. Hücreye resim eklenir, sığdırılır ama küçük olur anlaşılmaz. Yinede kodları revize ederiz.
 

metehan8001

Moderator
Yönetici
Moderatör
#13
yani H hücresine çagırdığım resimler , mesela 900*600 çözünürlüğünde gelsin şeklinde olabilir mi. :cautious:
Dosyanızın son hali ektedir. Mail göndermede bazı hatalar vardı, düzeltildi. Her satıra ayrı ayrı resim ekleyip ilgili kişiye gönderme testi de outlooktan yaptım, sonuç başarılı. Resimler excelde istemiş olduğunuz ölçüde ekleniyor.
 

Ekli dosyalar

metehan8001

Moderator
Yönetici
Moderatör
#15
şuan dosya bozuk açılamıyor hatası veriyor..
Dosya bende normal açılıyor ben yinede Üst mesajda düzeltme yaparak dosyayı değiştirdim.

Sayfanın kod editörüne aşağıdaki kodu ekleyin.
Kod:
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
Module kod editörüne;

Kod:
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
 
Son düzenleme:
Üst