質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

89.06%

VBA 実行時エラー'438' の解決

解決済

回答 2

投稿

  • 評価
  • クリップ 0
  • VIEW 770

r_o_234

score 15

前提・実現したいこと

エクセルの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

  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

回答 2

checkベストアンサー

+1

添付ファイルというのはOutlookに対してするのではなく、メールに対して添付するものですよね?
今の実装はOutlookに対して行っています。

Set ObjMail = CreateObject("Outlook.Application")
~省略~
Call ObjMail.Attachments.Add(attachmentPath)

作成するメールに対して添付すればOK

Set ObjMail = CreateObject("Outlook.Application")
~省略~
'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
            .To = wsList.Cells(i, 4).Value 'メール宛先
            .Subject = wsMail.Range("B1").Value 'メール件名
            .BodyFormat = olFormatPlain     'メールの形式
            .Body = wsMail.Range("B2").Value  'メール本文
            .Attachments.Add attachmentPath ' ★ここに追加
            .Display 'Outlookの下書きをDisplayする
        End With
    Next i

End With


余談ですが折角With使っているのにその中でObjMailを書いていたので修正してます。
あと動作確認はしていませんのであしからず。

修正版全コード

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
                .To = wsList.Cells(i, 4).Value 'メール宛先
                .Subject = wsMail.Range("B1").Value 'メール件名
                .BodyFormat = olFormatPlain     'メールの形式
                .Body = wsMail.Range("B2").Value  'メール本文
                .Attachments.Add attachmentPath ' ★この行追加
                .Display 'Outlookの下書きをDisplayする
            End With
        Next i

    End With
End Sub

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2020/04/13 13:26

    ttyp03さん
    返信ありがとうございます。

    ここは修正しておりませんが、
    元々のVBA自体にエラーがあって、重複する記述の箇所があるため、
    それが原因で"424"エラーを吐いてるのかと思いました。

    Set ObjMail = CreateObject("Outlook.Application")
    Set objOutlook = New Outlook.Application
    Set ObjMail = objOutlook.CreateItem(olMailItem)

    この3行が同じ重複した処理を述べている事が原因かなと思います。
    (…が、これを削除してobjMail,objOutlookの変数を1個に合わせてもエラー吐いた記憶があります。)

    もし何かおかしいところをお気づきになれば、アドバイスをお願いします。

    キャンセル

  • 2020/04/13 13:57

    上2行と下1行は同じ処理ではないですね。
    混乱しているようなので、全体的に修正したコードを回答しました。
    こちらは動作確認もできていますので、お試しください。

    キャンセル

  • 2020/04/13 14:31

    ttyp03さん

    解決しました。
    ttyp03さんのVBAを新しく手入力で書き上げた所、正常に動作しました。
    これで、一括送信メーラーのα版ということで動作確認しました。
    (あとは添付ファイルを複数指定可能に変更すれば完成です)
    修正版全コードの方も試してみます。
    ご協力本当にありがとうございました!助かりました!

    キャンセル

+1

Option Explicit

'# 「ツール」→「参照設定」から
'#「Microsoft Outlook XX.X Object Library」を参照設定すること
Sub ovba()
    Dim objOutlook As Outlook.Application
    Dim attachmentPath As Variant
    Dim i As Long
    Dim wsList As Worksheet
    Dim wsMail As Worksheet

    Set objOutlook = New Outlook.Application
    Set wsList = ThisWorkbook.Sheets("送信先")
    Set wsMail = ThisWorkbook.Sheets("メール内容")

    '--- 添付ファイルのパスの取得 ---'
    attachmentPath = Excel.Application.GetOpenFilename( _
                     "Microsoft Excelブック,*.xls?", , "添付ファイルの選択")
    'ダイアログでキャンセルボタンが押された場合は処理を終了します
    If attachmentPath = False Then Exit Sub

    '送信先の件数分繰り返す
    For i = 2 To wsList.Cells(wsList.Rows.Count, 1).End(xlUp).Row
        With objOutlook.CreateItem(olMailItem)      'メールの作成
            .BodyFormat = olFormatPlain             'メールの形式
            .To = wsList.Cells(i, 4).Value          'メール宛先
            .Subject = wsMail.Range("B1").Value     'メール件名
            .Body = wsMail.Range("B2").Value        'メール本文
            .Attachments.Add (attachmentPath)       '添付ファイル
            .Display                                'Outlookの下書きをDisplayする
            '.Send                                   '送信の命令は不要?
        End With
    Next
End Sub

変数の登場数が多すぎてごっちゃになってるのでは?
変数っていうくらいだから、次々変わらないものは直接書くか定数で。
あと、不要な空白行も読みにくくないですか?
適当に添削してみました。
あと、やっぱり、操作対象が何かちゃんと意識して、
何に対して命令するのか、
何に対して何の設定を設定するのか、
意識して書きましょう。

参考になれば。。。。

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2020/04/13 12:13

    ピリオドが、抜けてますが?
    よく見てください。

    キャンセル

  • 2020/04/13 13:11

    mattuwanさん
     指摘ありがとうございます。
     Excel.Application.GetOpenFilenameにピリオドを入れ直しで修正した所、1つ進み今度は

     実行時エラー'440'
     オブジェクトはこのメソッドをサポートしていません。
     というエラーに代わりました。
     デバッグするとポインタが24行目の.To wsList.Cells(i, 4).Value'メール宛先
     で止まります。

     .To→objOutlook.Toと修正すれば良いのでしょうか。
     おわかりになればお願いします。

    キャンセル

  • 2020/04/13 14:33

    mattuwanさん

    解決しました。下のttyp03さんのVBAを新しく手入力で書き上げた所、正常に動作しました。
    mattuwanさんもご協力本当にありがとうございます。変数・空白行・意識等勉強になりました!

    キャンセル

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 89.06%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

同じタグがついた質問を見る