Listeden Adres Secip Mail Gonderme

Bugun sitemizi takip eden bir arkadasimizin sorusu uzerine kisa bir calisma yaptik ve listboxlardan mail adresi secerek; dosya eklenebilecek sekilde mail gonderme islemi yapabilecek bir kodlama yapmaya calistik.

Soru su sekildeydi; “merhabalar hocam excelde makrolarda kullanıcı 10 tane mail listesi giricek ve her maili alt alta sıralıcak ve sectiğimiz bir dosyayı gene sectigimiz maile atıcak”

Sorudan Anladigimiz kadariyla bir cozume ulasmaya calistik cunku arkadasimiz uye degil bu yuzden iletisim detaylari mevcut degil.

Oncelikle yukaridaki resimde gordugunuz gibi iki adet listboximiz var ve birbirleri arasinda veri gecisleri ile gercek listemiz bulunan listbox1`den mail gondermek  istedigimiz mail adreslerini ikinci listbox`a aktariyoruz.

dosya ekleyecekmisin sorusuna evet cevabini verirseniz devam ediyor yoksa bir islem yapmiyor fakat istek uzerine oldugundan simdilik bu sekilde, kendinize gore yahut isteklere gore sekillenebilir.

Dosya eklemeniz icin bir pencere aciliyor ve dosyayi seciyorsunuz, daha sonra mail envelope yontemi ile outlook mail gonderme penceresi aciliyor ve mail alani olarak mail adli sayfayi alirken istediginiz dosyayi ek olarak ekliyor ve listbox2 de listelediginiz mail adreslerine gonderiyor.

Ilk listbox`in istedigimiz mail adresleri ile dolmasi icin sayfaniz aktifligine bir kod ekliyoruz;

Private Sub Worksheet_Activate()

    Dim myCell As Range
    Dim rngItems As Range
    Set rngItems = Sheets("Mail_Addresses").Range("ItemList")

    Me.ListBox1.Clear
    Me.ListBox2.Clear

    With Me.ListBox1

        .LinkedCell = ""
        .ListFillRange = ""

        For Each myCell In rngItems.Cells
            If Trim(myCell) <> "" Then
                .AddItem myCell.Value
            End If
        Next myCell

    End With

    Me.ListBox1.MultiSelect = fmMultiSelectMulti
    Me.ListBox2.MultiSelect = fmMultiSelectMulti

End Sub

Sonra sirasiyla butonlarimiza ekledigimiz kodlar;

Hepsi saga;

Private Sub BTN_moveAllRight_Click()

    Dim ictr As Long
    Dim Secimler As String

    For ictr = 0 To Me.ListBox1.ListCount - 1
        Me.ListBox2.AddItem Me.ListBox1.List(ictr)
        Secimler = Secimler & Me.ListBox1.List(ictr) & ";"
        Sheets("Datas").Range("A1") = Secimler
    Next ictr

    Me.ListBox1.Clear
End Sub

Hepsi Sola;

Private Sub BTN_moveAllLeft_Click()

    Dim ictr As Long
    Dim Secimler As String

    For ictr = 0 To Me.ListBox2.ListCount - 1
        Me.ListBox1.AddItem Me.ListBox2.List(ictr)
    Next ictr
    Secimler = ""
    Sheets("Datas").Range("A1") = Secimler
    Me.ListBox2.Clear
End Sub

Secilen Saga;

Private Sub BTN_MoveSelectedRight_Click()
    Dim ictr As Long
    Dim Secimler As String
    Dim adresler As Range
    Secimler = Sheets("Datas").Range("A1").Value
    For ictr = 0 To Me.ListBox1.ListCount - 1
        If Me.ListBox1.selected(ictr) = True Then
            Me.ListBox2.AddItem Me.ListBox1.List(ictr)
            Secimler = Secimler & Me.ListBox1.List(ictr) & ";"
            Sheets("Datas").Range("A1").Value = Secimler
        End If
    Next ictr

    For ictr = Me.ListBox1.ListCount - 1 To 0 Step -1
        If Me.ListBox1.selected(ictr) = True Then
            Me.ListBox1.RemoveItem ictr
        End If
    Next ictr

End Sub

Secilen Sola;

Private Sub BTN_MoveSelectedLeft_Click()

    Dim ictr As Long
    Dim Secimler As String
    For ictr = 0 To Me.ListBox2.ListCount - 1
        If Me.ListBox2.selected(ictr) = True Then
            Me.ListBox1.AddItem Me.ListBox2.List(ictr)
        End If
    Next ictr

    For ictr = Me.ListBox2.ListCount - 1 To 0 Step -1
        If Me.ListBox2.selected(ictr) = True Then
            Secimler = Me.ListBox2.List(ictr) & ";"
            Me.ListBox2.RemoveItem ictr
            Sheets("Datas").Range("A1") = WorksheetFunction.Substitute(Sheets("Datas").Range("A1").Value, Secimler, "")
            End If
    Next ictr

End Sub

daha sonra ise mailleri aticak olan buton icin gerekli kodlarimiz var, sanirim en can alici bolumu;

Option Explicit

Sub Mail_Gonder()
Dim Cevap, fileToOpen, adresler As String
Dim ictr As Long
Dim eklenti1, eklenti0 As Integer

Cevap = MsgBox("Dosya Ekleyecek misiniz?", vbYesNo)
If Cevap = vbYes Then
'Call the add attachments dialogue
'Add question to ask for another attachment
fileToOpen = Application _
    .GetOpenFilename()
   If fileToOpen > "" Then

 Sheets("Mail").Activate
  ActiveWorkbook.EnvelopeVisible = True

    With ActiveSheet.MailEnvelope

  'Eskiden eklenmis akleri silmek icin
        eklenti1 = .Item.Attachments.Count
            If eklenti1 <> 0 Then
            For eklenti0 = 1 To .Item.Attachments.Count
            .Item.Attachments(1).Delete
            Next
             End If
      .Introduction = ""
      .Item.To = Sheets("Datas").Range("A1")
      .Item.cc = ""
      .Item.Subject = "deneme"
      .Item.Attachments.Add fileToOpen
      .Item.Send
   End With

End If
If Cevap = vbNo Then Exit Sub
End If
Sheets("Selection").Activate
Sheets("Datas").Range("A1") = ""
End Sub

Ornek dosyayida ekleyecegim ama konu daha cok gelistirmeye acik ve duruma ozgu olarak eklenmistir, ama yinede islevsel olabilcegini dusunuyorum, ornek dosyayi inceleyiniz lutfen.

Listeden Adres Secip Mail Gonderme

Yazar: mmustafaaslan

2004 yilindan itibaren ozel bir sirketin finans departmaninda calismaktadir. Kendini excel, visual basic kullaniminda gelistirmis olan yazarimiz; Meslegi geregi SAP konusunda ileri derecede bilgilidir.

“Listeden Adres Secip Mail Gonderme” için 4 yorum

  1. slm hacam mail listesinden seçtim kişi boş bir sayfa oluşturuyor.
    dosyamı ftp yükledim bakmanız mümkünmü acaba

  2. Kod mükemmel ancak ben son aşamada mail gönder butonuna basınca outlook açılmıyor? yardımcı olabilir misiniz?

  3. Şimdi mail gönder çalışıyor ancak bir dosya eklemeden ve gönder butonuna ben outlooktan basmak suretiyle çalışan bir kod var mıdır acaba?

Bir Cevap Yazın

E-posta hesabınız yayımlanmayacak. Gerekli alanlar * ile işaretlenmişlerdir


1 + 6 =