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

[Fuatckmk]

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?

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

 

[Asri]

Deneyiniz.

 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

 

[Fuatckmk]

.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.

 .Attachments.Add (dosyayolu huzcresi)

Asri hocam teşekkürler,

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

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

 

[Asri]

Asri hocam teşekkürler,

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

Mesajımdaki kodu güncelledim. Tekrar deneyiniz.

 

[Fuatckmk]

Mesajımdaki kodu güncelledim. Tekrar deneyiniz.

Denedim fakat tekrar hata aldım dosya ekteki gibidir

 

[Asri]

Denedim fakat tekrar hata aldım dosya ekteki gibidir

Mesajdaki kod güncellenedi.

 

[Fuatckmk]

Mesajdaki kod güncellenedi.

desteğiniz için teşekkür ederim, tekrar hata verdi

 

[Asri]

Dosyalarınızı C:\deneme gibi bir yerde tutun ve buradan yüklemeyi deneyin. Masaüstünü kullanmayın.

 

[Fuatckmk]

Dosyalarınızı C:\deneme gibi bir yerde tutun ve buradan yüklemeyi deneyin. Masaüstünü kullanmayın.

dediğiniz gibi C:\\ klasörüne koyup oradan denedim aşağıdaki hatayı verdi.

 

[Asri]

dediğiniz gibi C:\\ klasörüne koyup oradan denedim aşağıdaki hatayı verdi.

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.

 

[Fuatckmk]

Asri hocam elinize sağlık şuanda çalışıyor çok teşekkürler, Allah razı olsun

 

[Asri]

Asri hocam elinize sağlık şuanda çalışıyor çok teşekkürler, Allah razı olsun

Sizden de.

 

[Fuatckmk]

Sizden de.

Hocam tekrar rahatsız ediyorum ama mail imzamı eklemek istiyorum hangi kodu nasıl kullanmalıyım biraz araştırdım fakat hep hata aldım yapamadım

 

[Asri]

Önce .display yapın.
Sonra diğer kodlar calissin

 

[Asri]

.htmlbody= hücre & .htmlbody

Body kısmı bu şekilde olmali

 

[Fuatckmk]

.htmlbody= hücre & .htmlbody

Body kısmı bu şekilde olmali

Bu şekilde yaptım fakat çıkmadı

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

 

[Asri]

.display i .to dan önce ekleyip deneyin

 

[Fuatckmk]

.display i .to dan önce ekleyip deneyin

Ne kadar teşekkür etsem azdır elleriniz dert görmesin

 

[Fuatckmk]

konu çözülmüştür: