Discreum
Yeni Üye
- Katılım
- 21 Mar 2021
- Mesajlar
- 152
- Aldığı beğeni
- 37
- Excel V
- Office 2019 TR
Konu Sahibi
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ı

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ı
