• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Mail Ek Uzantısını Excelden Çekme Kodu

Durum
Üzgünüz bu konu cevaplar için kapatılmıştır...
F

Fuatckmk

Altın Üye
Katılım
21 Aralık 2017
Mesajlar
84
Excel Vers. ve Dili
Excel 365 - Türkçe
Arkadaşlar merhaba,

Otomatik mail ile gönderilecek eki, Exceldeki E kolonundan çekmesini istiyorum.

Kodlarım aşağıdaki gibi. Konu, içerik, mail adresi değişkenlik gösteriyor.(Dosya yolu da herkesin farklı olacak) bu bağlamda nasıl bir kod yazmalıyım. Yardımcı olabilir misiniz?

Kod: 
Sub MAIL_GONDER()
    Dim Outlook_App As Object
    Dim Outlook_Mail As Object
    Dim S1 As Worksheet, X As Long
    
    Set Outlook_App = CreateObject("Outlook.Application")
    Set S1 = Sheets("Sayfa1")
    
    For X = 2 To S1.Cells(S1.Rows.Count, 1).End(3).Row
        If S1.Cells(X, 4) = "" Then
            Set Outlook_Mail = Outlook_App.CreateItem(0)
            With Outlook_Mail
                .To = S1.Cells(X, 3)
                .CC = ""
                .Subject = S1.Cells(X, 2)
                .body = S1.Cells(X, 1)
                .BodyFormat = 2
                .Save
                .send
                S1.Cells(X, 4) = "Gönderildi."
            End With
        End If
    Next
    
    Set S1 = Nothing
    Set Outlook_Mail = Nothing
    Set Outlook_App = Nothing

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Deneyiniz.

Kod: 
 Option Explicit


Sub MAIL_GONDER()
    Dim Outlook_App As Object
    Dim Outlook_Mail As Object
    Dim S1 As Worksheet, X As Long
    Dim dosya As String
    
    Set Outlook_App = CreateObject("Outlook.Application")
    Set S1 = Sheets("Sayfa1")
    
    For X = 2 To S1.Cells(S1.Rows.Count, 1).End(3).Row
        If S1.Cells(X, 4) = "" Then
            Set Outlook_Mail = Outlook_App.CreateItem(0)
            With Outlook_Mail
                .To = S1.Cells(X, 3)
                .CC = ""
                .Subject = S1.Cells(X, 2)
                .body = S1.Cells(X, 1)
                .BodyFormat = 2
                '.display
                dosya = S1.Cells(X, 5).Value
                .Attachments.Add dosya
           
                .Save
                .send
                S1.Cells(X, 4) = "Gönderildi."
            End With
        End If
    Next
    
    Set S1 = Nothing
    Set Outlook_Mail = Nothing
    Set Outlook_App = Nothing

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Son düzenleme:
asri' Alıntı:
.save den önce bu satırı ekleyip dosya yolu hücresini belirtin.
Yanlız kodlar sanki her bir kişi için bilgiyi aşağıya doğru alıyor gibi.
Bunun yerine, her bir kişiye ait bilgiyi her bir satırda sağa doğru alırsa sorun yaşamazsınız.

Kod: 
 .Attachments.Add (dosyayolu huzcresi)
Genişletmek için tıkla ...

Asri hocam teşekkürler,

kodu aşağıdaki gibi yaptım hata verdi, dediğinizi tam anlayamadım ne yapmam gerekiyor?

Kod: 
Sub MAIL_GONDER()
    Dim Outlook_App As Object
    Dim Outlook_Mail As Object
    Dim S1 As Worksheet, X As Long
    
    Set Outlook_App = CreateObject("Outlook.Application")
    Set S1 = Sheets("Sayfa1")
    
    For X = 2 To S1.Cells(S1.Rows.Count, 1).End(3).Row
        If S1.Cells(X, 4) = "" Then
            Set Outlook_Mail = Outlook_App.CreateItem(0)
            With Outlook_Mail
                .To = S1.Cells(X, 3)
                .CC = ""
                .Subject = S1.Cells(X, 2)
                .body = S1.Cells(X, 1)
                .BodyFormat = 2
                .Attachments.Add (X,5)
                .Save
                .send
                S1.Cells(X, 4) = "Gönderildi."
            End With
        End If
    Next
    
    Set S1 = Nothing
    Set Outlook_Mail = Nothing
    Set Outlook_App = Nothing

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

tablom örnek aşağıdaki gibi alt alta gönderecek kişileri ve uzantıları resimdeki gibi düzenleyeceğim

dneHWk.png
 
Dosyalarınızı C:\deneme gibi bir yerde tutun ve buradan yüklemeyi deneyin. Masaüstünü kullanmayın.
 
Fuatckmk' Alıntı:
dediğiniz gibi C:\\ klasörüne koyup oradan denedim aşağıdaki hatayı verdi.
Genişletmek için tıkla ...

C:\\ değil tam olarak yazın.

C:\deneme klasörü için ekdosya.pdf diye bir dosya ekleyin.
Aşağıdaki şekilde olmalı.

C:\deneme\ekdosya.pdf

Daha sonra bu yolu programda ilgili kolona yazın.

Sonra programı kapatıp tekrar açın ve deneyin.
 
Asri hocam elinize sağlık şuanda çalışıyor çok teşekkürler, Allah razı olsun
 
Önce .display yapın.
Sonra diğer kodlar calissin
 
.htmlbody= hücre & .htmlbody

Body kısmı bu şekilde olmali
 
asri' Alıntı:
.htmlbody= hücre & .htmlbody

Body kısmı bu şekilde olmali
Genişletmek için tıkla ...

Bu şekilde yaptım fakat çıkmadı

Kod: 
Option Explicit


Sub MAIL_GONDER()
    Dim Outlook_App As Object
    Dim Outlook_Mail As Object

    Dim S1 As Worksheet, X As Long
    Dim dosya As String
    Set Outlook_App = CreateObject("Outlook.Application")
    Set S1 = Sheets("Sayfa1")
    
    For X = 2 To S1.Cells(S1.Rows.Count, 1).End(3).Row
        If S1.Cells(X, 4) = "" Then
            Set Outlook_Mail = Outlook_App.CreateItem(0)
            With Outlook_Mail
                .To = S1.Cells(X, 3)
                .CC = S1.Cells(X, 6)
                .Subject = S1.Cells(X, 2)
                .HTMLBody = S1.Cells(X, 1) & .HTMLBody
                .display
                dosya = S1.Cells(X, 5).Value
                .Attachments.Add dosya
                .Save
                .send
                S1.Cells(X, 4) = "Gönderildi."
            End With
        End If
    Next
    
    Set S1 = Nothing
    Set Outlook_Mail = Nothing
    Set Outlook_App = Nothing

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    
End Sub
 
.display i .to dan önce ekleyip deneyin
 
konu çözülmüştür:
 
Son düzenleme:
Durum
Üzgünüz bu konu cevaplar için kapatılmıştır...
Geri
Üst