ExcelVBA.Net sitesine katkıda bulunabilirsiniz

[cevdetmeric1]

Merhaba arkadaşlar,
Listbox üzerinde birden fazla seçim yaparak ilgili satırlardaki kişilere, mail sayfasındaki formatta mail göndermek için nasıl bir yol izlemeliyim? Örnek dosya ektedir.
Konu ile yardımlarınız için şimdiden teşekkür ediyorum.

[Yken]

Tools / References Microsoft Outlook XX Object Library eklenmeli
Tools / References Microsoft Word XX Object Library eklenmeli
'.Send satırı pasif durumda. İsterseniz tırnağı kaldırıp aktif edip direkt gönder yapılabilir.

Kod: Tümünü seç

Private Sub UserForm_Initialize()
Dim sh1 As Worksheet
Dim lr As Long

Set sh1 = ThisWorkbook.Sheets("List")
lr = sh1.Range("A" & Rows.Count).End(xlUp).Row

With Me.ListBox1
    .ColumnCount = 5
    .ColumnHeads = True
    .RowSource = "List!A2:E" & lr
End With
End Sub

Kod: Tümünü seç

Private Sub CommandButton1_Click()
Dim sh2 As Worksheet, i As Integer
Dim appOutLook As Outlook.Application
Dim MailOutLook As Outlook.MailItem
Dim Alicilar As String
Dim doc As Word.Document

Set sh2 = ThisWorkbook.Sheets("Mail")
Alicilar = ""

For i = 0 To Me.ListBox1.ListCount - 1
    If Me.ListBox1.Selected(i) = True Then
        Alicilar = Alicilar & "; " & Me.ListBox1.Column(4, i)
    End If
Next i

Alicilar = Mid(Alicilar, 3)

Set appOutLook = CreateObject("Outlook.Application")
Set MailOutLook = appOutLook.CreateItem(olMailItem)

With MailOutLook
    .Display
    .BodyFormat = olFormatRichText
    .To = Alicilar
    '.cc = ""
    '.bcc = ""
    .Subject = sh2.Range("b1")
    .HTMLBody = ""
    '.Send
    Set doc = .GetInspector.WordEditor
    sh2.Range("b2:c7").Copy
    doc.Range(0, 0).Paste
    Application.CutCopyMode = False
End With

Set doc = Nothing
Set MailOutLook = Nothing
Set appOutLook = Nothing

End Sub

[cevdetmeric1]

Merhaba,
Güzel olmuş ancak mail gönderirken hepsine tek bir mail gönderiyor. Her satırın cihazı ve yetkilisi farklı olduğu için her seçim için ayrı ayrı mail göndermesi gerekiyor.

[Yken]

Kod: Tümünü seç

'Tools / Reference ile Microsoft Outlook 12.0 Object Library
'Tools / Reference ile Microsoft Word 12.0 Object Library

Private Sub UserForm_Initialize()
Dim sh1 As Worksheet
Dim lr As Long

Set sh1 = ThisWorkbook.Sheets("List")
lr = sh1.Range("A" & Rows.Count).End(xlUp).Row

With Me.ListBox1
    .ColumnCount = 5
    .ColumnHeads = True
    .RowSource = "List!A2:E" & lr
End With
End Sub
'
Private Sub CommandButton1_Click()
Dim sh2 As Worksheet, i As Integer
Dim appOutLook As Outlook.Application
Dim MailOutLook As Outlook.MailItem
Dim Alicilar As String, too As String
Dim doc As Word.Document

Set sh2 = ThisWorkbook.Sheets("Mail")
Alicilar = ""

For i = 0 To Me.ListBox1.ListCount - 1
    If Me.ListBox1.Selected(i) = True Then
        Alicilar = Alicilar & "; " & Me.ListBox1.Column(4, i)
    End If
Next i
   
If Alicilar = "" Then
    MsgBox "Lütfen seçim yapınız!", vbExclamation
    Exit Sub
End If

On Error Resume Next
    Set appOutLook = GetObject(, "Outlook.Application")
On Error GoTo 0

If appOutLook Is Nothing Then
    Set appOutLook = CreateObject("Outlook.Application")
End If

For i = 0 To Me.ListBox1.ListCount - 1
    If Me.ListBox1.Selected(i) = True Then
    too = Me.ListBox1.Column(4, i)

    With sh2
        .Range("B2") = "Sayın " & Me.ListBox1.Column(3, i)
        .Range("C5") = Me.ListBox1.Column(0, i)
        .Range("C6") = Me.ListBox1.Column(1, i)
        .Range("C7") = Me.ListBox1.Column(2, i)
    End With

    Set MailOutLook = appOutLook.CreateItem(olMailItem)
   
    With MailOutLook
        .Display
        .BodyFormat = olFormatRichText
        .To = too
        '.cc = ""
        '.bcc = ""
        .Subject = sh2.Range("b1")
        .HTMLBody = ""
        '.Send
        Set doc = .GetInspector.WordEditor
        sh2.Range("b2:c7").Copy
        doc.Range(0, 0).Paste
        Application.CutCopyMode = False
    End With
       
    End If
Next i
   
Set doc = Nothing
Set MailOutLook = Nothing
Set appOutLook = Nothing

End Sub


[cevdetmeric1]

Çok teşekkür ederim. Çok güzel olmuş.