如何通过在ListBox中选择名称来发送电子邮件

Question

我有一个日程查找程序vba UserForm。我希望能够向我在列表框中选择的任何人发送电子邮件模板。在列表框中选择一个名称后，我可以点击发送按钮，然后准备好发送给该人的模板。

屏幕截图：

这是我的代码：

'Dim mySheet As Worksheet
'Dim myUser As Range

Private Sub cmbRestDay_Change()

Dim mySheet As Worksheet    'declaring mySheet as the Worksheet...
Dim x, dict
Dim i As Long
Dim cnt As Long
Set mySheet = Sheets("Dashboard")
ListBox1.Clear
x = mySheet.Range("A1").CurrentRegion.Value
Set dict = CreateObject("Scripting.Dictionary")
If Application.CountIf(mySheet.Columns(2), cmbRestDay.Value) > 0 Then
    For i = 2 To UBound(x, 1)
        If x(i, 2) = cmbRestDay.Value Then
            dict.Item(x(i, 1)) = ""
        End If
    Next i
    ListBox1.List = dict.keys
Else
    ListBox1.AddItem "Match not found"
End If


End Sub

Private Sub UserForm_Initialize()

cmbRestDay.Clear

With cmbRestDay
    .AddItem ("Mon")
    .AddItem ("Tue")
    .AddItem ("Wed")
    .AddItem ("Thu")
    .AddItem ("Fri")
    .AddItem ("Sat")
    .AddItem ("Sun")
End With

With cmbMyRD
    .AddItem ("Mon")
    .AddItem ("Tue")
    .AddItem ("Wed")
    .AddItem ("Thu")
    .AddItem ("Fri")
    .AddItem ("Sat")
    .AddItem ("Sun")
End With

End Sub

Answer 1

假设发送电子邮件CommandButton的名称为 cmdSendEmail ，则将以下代码放在UserForm模块上。

Dim mySheet As Worksheet    'declaring mySheet as the Worksheet...

Private Sub cmdSendEmail_Click()
Dim Agent As String
Dim EmailID As String
Dim olApp As Object
Dim olMail As Object
Dim Str As String
Dim i As Long, r As Long
With Me.ListBox1
    For i = 0 To .ListCount - 1
        If .Selected(i) Then
            Agent = .List(i)
            Exit For
        End If
    Next i
End With
If Agent = "" Then
    MsgBox "No agent was selected in the ListBox.", vbExclamation, "Agent Not Selected!"
    Exit Sub
End If
r = Application.Match(Agent, mySheet.Columns(1), 0)
EmailID = mySheet.Range("D" & r).Value

Str = "Hi " & Agent & "," & vbNewLine & vbNewLine
Str = Str & "I would like to swap my Mon shedule to your Sunday schedule. & vbnewline & vbnewline"
Str = Str & "More Power" & vbNewLine & vbNewLine
Str = Str & "Thanks," & vbNewLine & "Bill"

Set olApp = CreateObject("Outlook.Application")
Set olMail = olApp.CreateItem(0)

With olMail
    .To = EmailID
    .Subject = "Hi " & Agent
    .Body = Str
    .Display
    '.Send
End With
Set olMail = Nothing
Set olApp = Nothing
End Sub
Private Sub cmbRestDay_Change()
Dim x, dict
Dim i As Long
Dim cnt As Long
Set mySheet = Sheets("Dashboard")
ListBox1.Clear
x = mySheet.Range("A1").CurrentRegion.Value
Set dict = CreateObject("Scripting.Dictionary")
If Application.CountIf(mySheet.Columns(2), cmbRestDay.Value) > 0 Then
    For i = 2 To UBound(x, 1)
        If x(i, 2) = cmbRestDay.Value Then
            dict.Item(x(i, 1)) = ""
        End If
    Next i
    ListBox1.List = dict.keys
Else
    ListBox1.AddItem "Match not found"
End If


End Sub



Private Sub UserForm_Initialize()

cmbRestDay.Clear

With cmbRestDay
    .AddItem ("Mon")
    .AddItem ("Tue")
    .AddItem ("Wed")
    .AddItem ("Thu")
    .AddItem ("Fri")
    .AddItem ("Sat")
    .AddItem ("Sun")
End With

With cmbMyRD
    .AddItem ("Mon")
    .AddItem ("Tue")
    .AddItem ("Wed")
    .AddItem ("Thu")
    .AddItem ("Fri")
    .AddItem ("Sat")
    .AddItem ("Sun")
End With

End Sub

如果电子邮件生成正确，您可以评论/删除该行。显示并取消注释该行。发送电子邮件而不在屏幕上显示。