Soru Klasördeki Dosya İsimlerinin Listboxta Gösterilip Çoklu Seçim İle Mail Gönderilmesi..

[inspirasyon]

Merhabalar Excel'den mail gönderme ile ilgili bir çok konuya baktım ama istediğim gibi bir kod maalesef bulamadım. İstediğim şu; Masaüstünde "Numune Sonuçları" adında bir klasörüm var, içinde laboratuvar sonuçlarının yer aldığı pdf uzantılı dosyalar bulunmakta. Benim bu sonuçları listboxta listeleyip, çoklu seçim yaparak ilgili kişinin mail adresine göndermem gerekiyor. Aynı klasörün içinde birde "Mail Gönderildi" adında bir klasörüm daha var, listboxtan seçtiğim pdf dosyalarını mail gönderdikten sonra dosyanın ismini (DosyaAdı.mailok) diye değiştirip "Mail Gönderildi" klasörüne kopyalanması.. şimdiden çok teşekkür ederim..

 

[EmrExcel16]

Deneyiniz..

Option Explicit
Private Sub UserForm_Initialize()
    Dim Yol, DosyaYolu, Satir
    Yol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator & "Numune Sonuclari"
    DosyaYolu = Dir(CreateObject("Scripting.FileSystemObject").GetFolder(Yol) & Application.PathSeparator & "*.pdf*", vbDirectory)
    Satir = 2
    ListBox1.Clear
    Range("A2:B1000").ClearContents
    Do While DosyaYolu <> ""
        Cells(Satir, 1) = Yol & Application.PathSeparator & DosyaYolu
        Cells(Satir, 2) = DosyaYolu
        ListBox1.AddItem DosyaYolu
        Satir = Satir + 1
        DosyaYolu = Dir
     Loop
End Sub
Private Sub CommandButton1_Click()
    Dim i, Ekle, Drm, OutApp, NewMail, Dosya, YeniDosya, MailDrm, Yol
    Range("C2:C1000").ClearContents
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) = True Then
            Set Ekle = Range("B2:B1000").Find(ListBox1.List(i), , xlValues, xlWhole)
            If Not Ekle Is Nothing Then
                Cells(Ekle.Row, 3) = "Ok"
                Drm = True
            End If
        End If
    Next
    If Drm Then
        Set OutApp = New Outlook.Application
        Set NewMail = CreateItem(olMailItem)
        With NewMail
            .Display
            .To = TextBox1.Value
            .CC = ""
            .Subject = "Konu"              ' Bu kısıma konuyu giriniz.
            .HTMLBody = "iyi calismalar.." & vbCrLf & vbCrLf & .HTMLBody    ' Bu kısıma acıklama giriniz.
            For i = 2 To Cells(Rows.Count, 1).End(3).Row
                If Cells(i, 3) = "Ok" Then
                    Dosya = Cells(i, 1)
                    .Attachments.Add (Dosya)
                End If
            Next            
           '.Send       'Mail gondermek icin tirnagi kaldir
            MailDrm = True
        End With
    End If
    If MailDrm Then
        For i = 2 To Cells(Rows.Count, 1).End(3).Row
            If Cells(i, 3) = "Ok" Then
                Dosya = Cells(i, 1)
                Yol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator & "Numune Sonuclari" & Application.PathSeparator & "Mail Gonderildi"
                YeniDosya = Yol & Application.PathSeparator & CreateObject("Scripting.FileSystemObject").GetBaseName(Dosya) & " Mail ok" & ".pdf"
                CreateObject("Scripting.FileSystemObject").MoveFile Dosya, YeniDosya
            End If
        Next
    End If
End Sub

 

[inspirasyon]

Çok teşekkür ederim, süper olmuş tam istediğim gibi, ellerinize sağlık. Çok önemli değil ama outlook taki imzayı kullanmak için nasıl bir ekleme yapabiliriz?

 

[EmrExcel16]

Çok teşekkür ederim, süper olmuş tam istediğim gibi, ellerinize sağlık. Çok önemli değil ama outlook taki imzayı kullanmak için nasıl bir ekleme yapabiliriz?

Rica ederim , isteğiniz doğrultusunda #2 nolu mesajdaki kodu güncelledim , denersiniz..