VBAで自動メール作成したいのとアクティブセルの行のある列の値を元に色々なセルの値を変数に代入したいです。

イメージ説明イメージ説明### 実現したいこと
よろしくお願い致します。
・自動でOutlookメールを作成したい
・1シート目のアクティブセルの行のある列の値を2シート目のある列の中から探したい。
・2シート目のある列に同じ値がある場合は、その行のある列の値を取得して、2シート目内のあるセルの文章の中のある値に代入したい
・1シート目のアクティブセルの行の複数の列の値を、2シート目のあるセルの文章の中のある値に代入したい
・メール作成画面、下書き作成画面を立ち上げたい

前提

Outlookでメールを自動で作成し、宛先や件名などをエクセルシートに書かれた値を入れこみたいです。
具体的な値を参照する方法は、エクセルの1枚目のシート「Sheet1」上である複数行に及ぶセルをクリックして選択している状態にします。
その選択されたアクティブセルそれぞれと同じ行のK列目のセルに入っている値と同じ値が、エクセル2枚目のシート「Sheet2」のM列のどこかの行にある場合に、「Sheet2」でその行のM列とN列とO列の値をそれぞれ、既に定義してある変数「Companyname」「Username」「mailaddress」に代入します。
「Sheet2」の「B6」セルにはメールの本文に書きたい文章が入っていて、 文章の中の{メーカー} {品目} {型番} {個数} {単位} {見積納期}という単語は、「Sheet1」上で選択されている複数行のセルの各行のF列、G列、H列、I列、J列、L列の値を入れたいです。作成したメールの表示、下書き保存まで行いたいです。

エラーは出ませんがOutlookの「プロファイルの選択」というダイアログボックスが出現して、OKを押すとボックスは消えてそのまま何も起こりません。いつも普通にOutlookを立ち上げるときはOKを押すとメールボックスが立ち上がるのですが。

VBA

'変数設定の指定 Option Explicit Sub SendMail_HTML() 'シート設定 Dim ws1 As Worksheet Set ws1 = Worksheets("Sheet1") Dim ws2 As Worksheet Set ws2 = Worksheets("Sheet2") 'Outlookアプリケーションを起動 Dim outlookObj As Outlook.Application Set outlookObj = New Outlook.Application 'Outlookメールを作成 Dim mymail As Outlook.MailItem '変数設定 Dim cmax As Long Dim i As Long Dim Companyname As String Dim username As String Dim mailaddress As String Dim txt As TextStream Dim honbun As String Dim subject As String Dim mailbody As String Dim strstyle As String Dim maxrow As Integer Dim maker As String Dim item As String Dim model As String Dim number As String Dim unit As String Dim duedate As String 'FileSystemObjectの設定 Dim fs As Scripting.FileSystemObject Set fs = New Scripting.FileSystemObject '各シートの記載情報を取得 cmax = ws1.Cells(Rows.Count, 1).End(xlUp).Row '最終行を取得 If cmax = 1 Then Exit Sub 'データがなければ終了 'メール作成 For i = 2 To cmax '2行目から最終行まで処理を繰り返す maker = ws1.Cells(i, 6).Value '各列の値を取得 item = ws1.Cells(i, 7).Value model = ws1.Cells(i, 8).Value number = ws1.Cells(i, 9).Value unit = ws1.Cells(i, 10).Value duedate = ws1.Cells(i, 12).Value 'Sheet2で条件に一致する行を取得 Dim foundRow As Range Set foundRow = ws2.Range("M:M").Find(What:=maker, LookAt:=xlWhole) If Not foundRow Is Nothing Then '条件に一致する行がある場合 Set mymail = outlookObj.CreateItem(olMailItem) 'プログラム12|メール情報と本文を取得 Companyname = ws2.Cells(foundRow.Row, 13).Value username = ws2.Cells(foundRow.Row, 14).Value mailaddress = ws2.Cells(foundRow.Row, 15).Value mymail.BodyFormat = 2 'HTMLに変更 mymail.To = mailaddress mymail.CC = ws2.Range("B3").Value 'cc宛先 mymail.BCC = ws2.Range("B4").Value 'bcc宛先 mymail.subject = ws2.Range("B5").Value '件名 honbun = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(ws2.Range("B6").Value, "{会社}", Companyname), "{名前}", username), "{メーカー}", maker), "{品目}", item), "{型番}", model), "{個数}", number), "{単位}", unit), "{納期}", duedate), vbLf, "<br>") strstyle = "<font face=""游ゴシック (本文のフォント - 日本語)"" color=""&H000000"">" & honbun & "</font>" mailbody = strstyle 'メール送信 mymail.Display 'メール表示(ここでは誤送信を防ぐために表示だけにして、メール送信はしない) mymail.Save '下書き保存 mymail.send 'メール送信 'オブジェクト解放 Set mymail = Nothing End If Next Set outlookObj = Nothing 'プログラム終了 End Sub

試したこと

ChatGPTで質問をして
下記のコードを追記したのですがprofileName:=の部分で「コンパイルエラー:名前付き引数が見つかりません」と出て何を入力すれば良いか分からず止まっています。
またこのコードを不特定多数の人間が使う予定なので私の個別の引数を入力しなければならないとすると困ります。
'Outlookのプロファイルを指定
Dim outlookNamespace As Outlook.Namespace
Set outlookNamespace = outlookObj.GetNamespace("MAPI")
outlookNamespace.Logon profileName:="プロファイル名", Password:="", ShowDialog:=False, NewSession:=False

補足情報(FW/ツールのバージョンなど)

ここにより詳細な情報を記載してください。

コメントを投稿

0 コメント