Çözüldü mail yollarken eklenti nasıl ekliyebilirim

[Discreum]

Sub listele()
Dim X As Long
Dim ws As Worksheet
Set ws = Sheets("MailListesi")
X = ws.Range("A10000").End(xlUp).Row

lstMail.ColumnCount = 3
On Error Resume Next
lstMail.ColumnWidths = "155,250,50"
If X = 1 Then
lstMail.RowSource = "MailListesi!A2:C2"
Else
lstMail.RowSource = "MailListesi!A2:C" & X
End If

Set ws = Nothing




End Sub

Private Sub btn_ekle_Click()
Dim hata As Label
Dim dy As String

Application.FileDialog(msoFileDialogOpen).Show
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
On Error GoTo hata
dy = Application.FileDialog(msoFileDialogOpen).SelectedItems(1)
On Error GoTo hata

txtYol.Value = Trim(dy)

Exit Sub
hata:
MsgBox " Lütfen Dosya Seçiniz", , "Gökdeniz Site Yönetimi"
End Sub

Private Sub btnGonder_Click()
If txtKonu.Value = "" Then
MsgBox " Lütfen Konu Satırını Boş Bırakmayın", , "Gökdeniz Site Yönetimi"
Exit Sub
End If
If lstMail.ListCount = 0 Then
MsgBox "Mail Gönderilecek Kimse Bulunamadı", , "Gökdeniz Site Yönetimi"
Exit Sub
End If


lblDurum.Visible = True
lblMail.Visible = True
Dim X As Integer
Dim Y As Integer
Dim m As String
Dim k As String
Dim a As String
X = lstMail.ListCount
DoEvents

For Y = 2 To X + 1
Dim outlook As outlook.Application
Dim mail As outlook.MailItem
Set outlook = New outlook.Application
Set mail = outlook.CreateItem(olMailItem)
m = Trim(Sheets("MailListesi").Range("B" & Y).Value)
k = txtKonu.Value
a = txtAciklama.Text
mail.To = m
mail.Subject = k
mail.Body = a
On Error Resume Next
mail.Attachments.Add (txtYol.Value)

lblMail.Caption = m
DoEvents
mail.Send
Sheets("MailListesi").Range("C" & Y).Value = "X"
Me.listele
UserForm_Initialize
Application.Wait (Now + TimeValue("00:00:03"))

lstMail.ListIndex = Y
Next


lblDurum.Visible = False
lblMail.Visible = False

MsgBox " Mail Gönderme işlemi tamamlandı...", , "Gökdeniz Site Yönetimi"


End Sub

Private Sub Image1_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal DragState As MSForms.fmDragState, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)

End Sub



Private Sub CommandButton1_Click()
Dim MROW As Long
If Me.TextBox1 <> "" And Me.TextBox2 <> "" Then
MROW = Sayfa13.Range("A1000000").End(xlUp).Row + 1
Sayfa13.Range("A" & MROW) = Me.TextBox1
Sayfa13.Range("B" & MROW) = Me.TextBox2
Me.TextBox1 = ""
Me.TextBox2 = ""
Me.TextBox1.SetFocus
Else
MsgBox "Zorunlu Alanları Doldurunuz"
End If
listele
End Sub

Private Sub CommandButton2_Click()

If Me.TextBox1.Value = "" Then
MsgBox "Lütfen güncellemek için bir kayıt seçin", vbCritical
Exit Sub
End If

Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("MailListesi")

Dim Selected_Row As Long
Selected_Row = Application.WorksheetFunction.Match(Me.lstMail.List(Me.lstMail.ListIndex, 0), sh.Range("A:A"), 0)


'======================= Validation =========================

If Me.TextBox1.Value = "" Then
MsgBox "Lütfen Adı Giriniz", vbCritical
Exit Sub
End If

If Me.TextBox2.Value = "" Then
MsgBox "Lütfen E-mail adresini Giriniz", vbCritical
Exit Sub
End If


'===================================================

sh.Range("A" & Selected_Row).Value = Me.TextBox1.Value
sh.Range("B" & Selected_Row).Value = Me.TextBox2.Value


Me.TextBox1.Value = ""
Me.TextBox2.Value = ""



listele
End Sub

Private Sub CommandButton3_Click()
If Me.TextBox1.Value = "" Then
MsgBox "Lütfen silmek için bir kayıt seçin", vbCritical
Exit Sub
End If
If Me.lstMail.ListIndex < 0 Then
MsgBox "Lütfen güncellemek için bir kayıt seçin", vbCritical
Exit Sub
End If

Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("MailListesi")

Dim Selected_Row As Long
Selected_Row = Application.WorksheetFunction.Match(Me.lstMail.List(Me.lstMail.ListIndex, 0), sh.Range("A:A"), 0)

sh.Range("A" & Selected_Row).EntireRow.Delete



listele
End Sub

Private Sub CommandButton4_Click()
If Me.TextBox3.Value = "" Then
MsgBox "Mail Alanını Doldurunuz", vbCritical
Exit Sub
End If
If Me.TextBox5.Value = "" Then
MsgBox "Konu Başlığını Doldurunuz", vbCritical
Exit Sub
End If
If Me.TextBox6.Value = "" Then
MsgBox "Konu Açıklamasını Doldurunuz", vbCritical
Exit Sub
End If

Dim outlook As outlook.Application
Dim mail As outlook.MailItem
Set outlook = New outlook.Application
Set mail = outlook.CreateItem(olMailItem)

mail.To = TextBox3.Text
mail.Subject = TextBox5.Text
mail.Body = TextBox6.Text
mail.Send
On Error Resume Next
mail.Attachments.Add (TextBox4.Value)
MsgBox "Mail İletildi"
End Sub

Private Sub CommandButton5_Click()
Unload Me
End Sub

Private Sub CommandButton6_Click()
Dim hataa As Label
Dim dyy As String

Application.FileDialog(msoFileDialogOpen).Show
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
On Error GoTo hataa
dyy = Application.FileDialog(msoFileDialogOpen).SelectedItems(1)
On Error GoTo hataa

TextBox4.Value = Trim(dyy)

Exit Sub
hataa:
MsgBox " Lütfen Dosya Seçiniz", , "Gökdeniz Site Yönetimi"
End Sub

Private Sub Frame8_Click()

End Sub

Private Sub ListBox1_Click()

End Sub

Private Sub lstMail_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
On Error Resume Next
If Me.lstMail.List(Me.lstMail.ListIndex, 0) <> "" Then
Me.TextBox1.Value = Me.lstMail.List(Me.lstMail.ListIndex, 0)
Me.TextBox2.Value = Me.lstMail.List(Me.lstMail.ListIndex, 1)
End If

End Sub
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
On Error Resume Next
If Me.ListBox1.List(Me.ListBox1.ListIndex, 0) <> "" Then
Me.TextBox3.Value = Me.ListBox1.List(Me.ListBox1.ListIndex, 1)
End If
listele
End Sub

Private Sub UserForm_Activate()
Sheets("MailListesi").Range("C2:C10000").Value = ""


listele
End Sub

Private Sub UserForm_Click()

End Sub

Private Sub UserForm_Initialize()
lblAdet = Sheets("MailListesi").Range("R1").Value
lblGonderilen = Sheets("MailListesi").Range("R2").Value
lblKalan = Sheets("MailListesi").Range("R3").Value


Dim Z As Long
Dim sw As Worksheet
Set sw = Sheets("MailListesi")
Z = sw.Range("A10000").End(xlUp).Row
ListBox1.ColumnHeads = True
ListBox1.ColumnCount = 2
On Error Resume Next
ListBox1.ColumnWidths = "125,150"
If Z = 1 Then
ListBox1.RowSource = "MailListesi!A2:B2"
Else
ListBox1.RowSource = "MailListesi!A2:B" & Z
End If

Set ws = Nothing


listele
End Sub

buradan aldığım bir VBA birazda kendim katarak hem toplu hem tekli mail yapmak istedim her şey sorunsuz çalışıyor sadece tekli mail platformunda ek olarak seçtiğim dosya mail olarak gitmiyor toplu mailde herhangi bir sorun yok bir kaç kod satırı denedim ama işe yaramadı

 

[Discreum]

konuyu çözdüm ilgilenen olduysa eğer teşekkür ederim.

 

[ZaLim]

Sayın @Discreum çözümü belirtebilirseniz, gelen kullanıcılar içinde bilgi paylasimi olur diye düşünüyorum.
Teşekkür ederim

 

[Discreum]

Sayın @Discreum çözümü belirtebilirseniz, gelen kullanıcılar içinde bilgi paylasimi olur diye düşünüyorum.
Teşekkür ederim

HTML:

İçeriği görebilmek için Giriş yap ya da Üye ol.

kodlar aynı sadece yerlerinde şaşırma yaptığım için sorun oluşmuş alttaki kod ile sorun kalmadı

HTML:

İçeriği görebilmek için Giriş yap ya da Üye ol.