emailing listbox content - multiple entries

问题:

I have a form that contains a listbox. The listbox populates through input data on the form.

I then want to email all the contents of the listbox to individuals.

The following code does work - It does however only send the first line in the listbox. I am looping through the code so thought that it would send all of the listbox

 Private Sub Command25_Click()
Dim subject As String, Body As String
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem

  On Error Resume Next
  Set OutApp = GetObject(, "Outlook.Application")
  If OutApp Is Nothing Then
    Set OutApp = CreateObject("Outlook.Application")
  End If
  On Error GoTo 0

  Set OutMail = OutApp.CreateItem(olMailItem)

  With OutMail

  For intCurrentRow = 0 To List22.ListCount - 1
List22.Selected(intCurrentRow) = True
Next intCurrentRow




        .To = Me.Text8
        .subject = "Test Email"
        .Body = vbNewLine & vbNewLine & Me.List22.Column(1) & ", " & Me.List22.Column(2) & ", " & Me.List22.Column(3) & ", " & Me.List22.Column(4) & ", " & Me.List22.Column(5)
        .Send
      End With

      Set OutMail = Nothing
      Set OutApp = Nothing

    End Sub

回答1:

You only loop the select statement. Not sending the e-mail. Try this

Private Sub Command25_Click()
Dim subject As String, Body As String
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem

  On Error Resume Next
  Set OutApp = GetObject(, "Outlook.Application")
  If OutApp Is Nothing Then
    Set OutApp = CreateObject("Outlook.Application")
  End If
  On Error GoTo 0

  For intCurrentRow = 0 To List22.ListCount - 1    
     Set OutMail = OutApp.CreateItem(olMailItem)

     With OutMail
         List22.Selected(intCurrentRow) = True

        .To = Me.Text8
        .subject = "Test Email"
        .Body = vbNewLine & vbNewLine & Me.List22.Column(1) & ", " & Me.List22.Column(2) & ", " & Me.List22.Column(3) & ", " & Me.List22.Column(4) & ", " & Me.List22.Column(5)
        .Send
     End With
  Next intCurrentRow

Set OutMail = Nothing
Set OutApp = Nothing

End Sub