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

電子メールの送信コマンドボタンの名前と仮定すると、次にユーザーフォームモジュールに次のコードを配置cmdSendEmailされます。

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 

電子メールが正しく生成されている場合は、ライン.Displayを削除/コメントして画面に表示せずに電子メールを送信するためにライン.Sendのコメントを解除します。