前提・実現したいこと
エクセルのVBAとOutlookを連携させて一括送信メーラーを作っています。
一括送信メーラーにファイル添付機能を追加するため、
以前作ったVBAと統合した所、以下のエラーメッセージが発生しました。
発生している問題・エラーメッセージ
実行時エラー'438'オブジェクトは、このプロパティまたはメソッドをサポートしていません。
該当のソースコード
Sub ovba()
'ファイルの選択ダイアログを表示して
'ファイルのパスを取得します
Dim fType, prompt As String
Dim fPath As Variant
Dim ws As Worksheet
Dim ObjMail As Object
Dim objOutlook As Outlook.Application
Dim i As Long
Dim rowMax As Long
Dim wsList As Worksheet
Set ObjMail = CreateObject("Outlook.Application")
Set objOutlook = New Outlook.Application
Set wsList = ThisWorkbook.Sheets("送信先")
Set wsMail = ThisWorkbook.Sheets("メール内容")
'選択できるファイルの種類はすべてのファイル
fType = ""
'ダイアログのタイトルを指定
prompt = "Excelファイルを選択して下さい"
'ファイル参照ダイアログの表示
fPath = Application.GetOpenFilename(fType, , prompt)
If fPath = False Then
'ダイアログでキャンセルボタンが押された場合は処理を終了します
End
End If
'B2セルにファイル名をセット
wsMail.Cells(10, 3).Value = fPath
'--- 添付ファイルのパス ---'
Dim attachmentPath As String
attachmentPath = fPath
'--- 添付ファイルを設定 ---'
Call ObjMail.Attachments.Add(attachmentPath)
With wsList
'送信先の件数
rowMax = .Cells(Rows.Count, 1).End(xlUp).Row
'送信先の件数分繰り返す
For i = 2 To rowMax
Set ObjMail = objOutlook.CreateItem(olMailItem)
With ObjMail
ObjMail.To = wsList.Cells(i, 4).Value 'メール宛先
ObjMail.Subject = wsMail.Range("B1").Value 'メール件名
ObjMail.BodyFormat = olFormatPlain 'メールの形式
ObjMail.Body = wsMail.Range("B2").Value 'メール本文
ObjMail.Display 'Outlookの下書きをDisplayする
End With
Next i
End With
End Sub
試したこと
438エラー自体はよく遭遇します。
今回、デバッガが49行目の Call ObjMail.Attachments.Add(attachmentPath)
で止まるので、
添付ファイルのアップロード処理を記述したfpath近辺のVBAがおかしいと思い試行錯誤しております。
また、前半のDim objOutlookとDim ObjMailの変数宣言でも同一の処理を入力してしまっていると思い、
今手入力で新しくVBAを作り直してデバッグしています。
もしこの438エラーの原因等がおわかりになれば教えてください。
よろしくお願いします。
補足情報(FW/ツールのバージョンなど)
Windows10
Excel 2019
Outlook 2019