Question

我试图在VBA中创建一个循环，以便在我单击命令按钮以以下格式起草带有每个选择的电子邮件时，可以从userform1的listbox2中进行多个选择。但是，我想不出如何在电子邮件正文中获得多个选择。我试图将其分成一个“ midbody”并再次添加代码，但它只是将相同的条目添加了两次。如何使此循环起作用？

Private Sub CommandButton3_Click()

    Dim objOutlook As Object
    Dim objMail As Object
    Dim midBody As String
    Dim wksheet As String
    Dim i As Integer



    Set objOutlook = CreateObject("Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)

    For i = 0 To ListBox2.ListCount - 1

        If ListBox2.Selected(i) = True Then
            wksheet = ListBox2.List(i)
            Sheets(wksheet).Activate

        End If


        If wksheet = "" Then
            MsgBox "Nothing is Selected"


           objMail.To = "myemail@me.com"

           'objMail.CC =

           objMail.Subject = ""


           Else

           midBody = activesheet.Range("C" & Rows.Count).End(xlUp).Value & vbNewLine & _
                        activesheet.Range("D" & Rows.Count).End(xlUp).Value & " through " & activesheet.Range("E" & Rows.Count).End(xlUp).Value & " phase" & vbNewLine & _
                        "Phase ECD: " & activesheet.Range("F" & Rows.Count).End(xlUp).Value & vbNewLine & _
                        "Baseline Finish: " & activesheet.Range("G" & Rows.Count).End(xlUp).Value & vbNewLine & _
                        "Previous Finish: " & activesheet.Range("H" & Rows.Count).End(xlUp).Value & vbNewLine & _
                        "Current Finish: " & activesheet.Range("I" & Rows.Count).End(xlUp).Value & vbNewLine & _
                        "Weekly Schedule Variance: " & activesheet.Range("J" & Rows.Count).End(xlUp).Value & vbNewLine & _
                        "CUM VAR to Baseline: " & activesheet.Range("K" & Rows.Count).End(xlUp).Value & vbNewLine & _
                        "Slip Reason: " & vbNewLine & _
                        "Critical Path: " & vbNewLine & vbNewLine

           objMail.body = midBody & Sheets.Range("C" & Rows.Count).End(xlUp).Value & vbNewLine & _
                        Sheets.Range("D" & Rows.Count).End(xlUp).Value & " through " & Sheets.Range("E" & Rows.Count).End(xlUp).Value & " phase" & vbNewLine & _
                        "Phase ECD: " & Sheets.Range("F" & Rows.Count).End(xlUp).Value & vbNewLine & _
                        "Baseline Finish: " & Sheets.Range("G" & Rows.Count).End(xlUp).Value & vbNewLine & _
                        "Previous Finish: " & Sheets.Range("H" & Rows.Count).End(xlUp).Value & vbNewLine & _
                        "Current Finish: " & Sheets.Range("I" & Rows.Count).End(xlUp).Value & vbNewLine & _
                        "Weekly Schedule Variance: " & Sheets.Range("J" & Rows.Count).End(xlUp).Value & vbNewLine & _
                        "CUM VAR to Baseline: " & Sheets.Range("K" & Rows.Count).End(xlUp).Value & vbNewLine & _
                        "Slip Reason: " & vbNewLine & _
                        "Critical Path: " & vbNewLine & vbNewLine

        End If
        i = i + 1

    Next i


        objMail.Save

        'Close the object
        Set objMail = Nothing

    MsgBox "Done", vbInformation
End Sub

Answer 1

我对您的代码进行了一些更改。将Next中的For移至了代码的后面部分，以包括循环处理。删除了多余的midBody。试试这个：

Private Sub CommandButton3_Click()
    Dim ws As Worksheet
    Dim i As Integer
    Dim Agent As String
    Dim EmailID As String
    Dim wksheet As String
    Dim objOutlook As Object
    Dim objMail As Object


    With Me.ListBox2
    For i = 0 To .ListCount - 1
        If .Selected(i) Then
            wksheet = .List(i)
            Exit For
        End If

    End With
     If wksheet = "" Then
        MsgBox "Nothing is Selected", vbExclamation
        Exit Sub
     End If
    'r = Application.Match(wksheet, mySheet.Columns(1), 0)'choose one as per your data structure
    r = Application.Match(Agent, mySheet.Columns(1), 0)   'choose one as per your data structure


    Set ws = ThisWorkbook.ActiveSheet
    'EmailID = mySheet.Range("D" & r).Value 'Uncomment it if this is required

    Set objOutlook = CreateObject("Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)

    With objMail
        .To = "myemail@me.com"    ' Or  EmailID
      ' .CC =
        .subject = ""

        .Body = ActiveSheet.Range("C" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 ActiveSheet.Range("D" & Rows.Count).End(xlUp).Value & " through " & ActiveSheet.Range("E" & Rows.Count).End(xlUp).Value & " phase" & vbNewLine & _
                 "Phase ECD: " & ActiveSheet.Range("F" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 "Baseline Finish: " & ActiveSheet.Range("G" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 "Previous Finish: " & ActiveSheet.Range("H" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 "Current Finish: " & ActiveSheet.Range("I" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 "Weekly Schedule Variance: " & ActiveSheet.Range("J" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 "CUM VAR to Baseline: " & ActiveSheet.Range("K" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 "Slip Reason: " & vbNewLine & _
                 "Critical Path: " & vbNewLine & vbNewLine

       '.Display
       '.Send
        .Save
    End With
    Next i
    Set objMail = Nothing
    Set objOutlook = Nothing

    MsgBox "Done", vbInformation

  End Sub

编辑：另一种适用于我的代码。我尚未创建listbox，但模拟了它的工作。该程序正确循环并多次发送电子邮件。请按照您的k代码删除listbox变量。它仅用于检查ptogram的正确循环。如果您以listbox的结构形式提供示例数据，从中选择接收者的emailid，工作表的示例数据等，则可以根据需要调整程序的早期版本。

Private Sub Command3_Click()
Dim subject As String, Body As String
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim ws As Worksheet
Dim k As Integer

  On Error Resume Next
   Set ws = ThisWorkbook.ActiveSheet
  Set OutApp = GetObject(, "Outlook.Application")
  If OutApp Is Nothing Then
    Set OutApp = CreateObject("Outlook.Application")
  End If
  On Error GoTo 0
  k = 4 ' remove it only for checking correct loop
  For intCurrentRow = 0 To k - 1  'List2.ListCount change k to List2.ListCount
     Set OutMail = OutApp.CreateItem(olMailItem)

     With OutMail
        ' List2.Selected(intCurrentRow) = True ' This is to be commented out after trials for looping

        .To = "abc@gmail.com"
        .subject = "Test 2nd time Email"
        .Body = ActiveSheet.Range("C" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 ActiveSheet.Range("D" & Rows.Count).End(xlUp).Value & " through " & ActiveSheet.Range("E" & Rows.Count).End(xlUp).Value & " phase" & vbNewLine & _
                 "Phase ECD: " & ActiveSheet.Range("F" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 "Baseline Finish: " & ActiveSheet.Range("G" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 "Previous Finish: " & ActiveSheet.Range("H" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 "Current Finish: " & ActiveSheet.Range("I" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 "Weekly Schedule Variance: " & ActiveSheet.Range("J" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 "CUM VAR to Baseline: " & ActiveSheet.Range("K" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 "Slip Reason: " & vbNewLine & _
                 "Critical Path: " & vbNewLine & vbNewLine

        .Send
     End With
  Next intCurrentRow

Set OutMail = Nothing
Set OutApp = Nothing

End Sub

Outlook快照显示它正在正确循环，这是您的主要问题。 EDIT2： 我以示例为基础模拟的较早版本的程序正在正确运行，并发送多封邮件。我不了解您的数据设置，因此无法模拟循环这是您的主要问题。请按原样尝试该程序，保留一份副本，然后针对您的数据特定情况进行适当的调整。

    Private Sub CommandButton3_Click()
    Dim ws As Worksheet
    Dim i As Integer
    Dim Agent As String
    Dim EmailID As String
    Dim wksheet As String
    Dim objOutlook As Object
    Dim objMail As Object


   ' With Me.ListBox2
    For i = 1 To 3
    'For i = 0 To .ListCount - 1
     '   If .Selected(i) Then
      '      wksheet = .List(i)
       '     Exit For
       ' End If

    'End With
     If wksheet = "hello" Then
        MsgBox "Nothing is Selected", vbExclamation
        Exit Sub
     End If
    'r = Application.Match(wksheet, mySheet.Columns(1), 0)'choose one as per your data structure
   ' r = Application.Match(Agent, mySheet.Columns(1), 0)   'choose one as per your data structure


    Set ws = ThisWorkbook.ActiveSheet
    'EmailID = mySheet.Range("D" & r).Value 'Uncomment it if this is required

    Set objOutlook = CreateObject("Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)

    With objMail
        .To = "abc@gmail.com"    ' Or  EmailID
      ' .CC =
        .subject = "original test"

        .Body = ActiveSheet.Range("C" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 ActiveSheet.Range("D" & Rows.Count).End(xlUp).Value & " through " & ActiveSheet.Range("E" & Rows.Count).End(xlUp).Value & " phase" & vbNewLine & _
                 "Phase ECD: " & ActiveSheet.Range("F" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 "Baseline Finish: " & ActiveSheet.Range("G" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 "Previous Finish: " & ActiveSheet.Range("H" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 "Current Finish: " & ActiveSheet.Range("I" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 "Weekly Schedule Variance: " & ActiveSheet.Range("J" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 "CUM VAR to Baseline: " & ActiveSheet.Range("K" & Rows.Count).End(xlUp).Value & vbNewLine & _
                 "Slip Reason: " & vbNewLine & _
                 "Critical Path: " & vbNewLine & vbNewLine

       '.Display
       .Send
        '.Save
    End With
    Next i
    Set objMail = Nothing
    Set objOutlook = Nothing

    MsgBox "Done", vbInformation

  End Sub

Excel VBA将数据循环到电子邮件正文中

1 个答案: