エクセルからアウトルックを操作するＶＢＡでこまっております

Question

エクセルのＶＢＡで困っております。
使用環境はウィンドウズ10　pro　64ビット オフィス２０１９プロ＋６４ビットです。
エクセルからアウトルックを操作するＶＢＡが二つあるのですが、一つはアウトルックの【日報受信】という名称のサブフォルダからメールをエクセルに取り込むＶＢＡ、もう一つは先のＶＢＡで取り込んだ【日報受信】のサブフォルダの中のメールを違う名称の【取り出し済】のサブフォルダにメールをすべて移動させるＶＢＡでサブフォルダからサブフォルダにメールをすべて移動させるＶＢＡとなります。
両方とも標準モジュールに格納しております

別々にマクロからＶＢＡを実行すると両方とも正常に動作するのですが、都合上連続でＶＢＡを実行しなくてはならず
二つのＶＢＡをcallで呼び出して実行したときにエラーとなります

二つのＶＢＡをcallで実行するＶＢＡは下記になります

Sub VBA連続実行()
Call 日報受信参照
Call アウトルックVBA
End Sub

こちらがそれぞれのマクロです
Option Explicit
Public Sub 日報受信参照()

' 定義
Dim objOL As Object
Dim sht As Worksheet
Dim rowCnt As Long
Dim objNAMESPC As Object
Dim itms1 As Variant '足した記述Option Explicit宣言に対応させるため

' 「Outlookから取得する」をobjOLと命名
Set objOL = CreateObject("Outlook.Application")

' 読み込むシート（シート名リスト）をshtと命名
Set sht = Worksheets("重複処理後") ' シート名
rowCnt = Cells(Rows.Count, "D").End(xlUp).row

' メールの場所をobjNAMESPCと命名
Set objNAMESPC = objOL.GetNamespace("MAPI")

' Outlookの指定フォルダのメールを最終行の１行下に取得・件数分繰り返す
For Each itms1 In objNAMESPC.Folders("Outlook データ ファイル").Folders("受信トレイ").Folders("日報受信").Items

        sht.Cells(rowCnt + 1, 1).Value = itms1.SenderName    ' A列・差出人
        sht.Cells(rowCnt + 1, 2).Value = itms1.Subject       ' B列・件名
        sht.Cells(rowCnt + 1, 3).Value = itms1.ReceivedTime  ' C列・受信日時
        sht.Cells(rowCnt + 1, 4).Value = itms1.body          ' D列・本文

        rowCnt = Cells(Rows.Count, "D").End(xlUp).row
    
    Next

' セットしていた条件を解除
Set objOL = Nothing
Set sht = Nothing
Set objNAMESPC = Nothing

Range("A1").Select

End Sub

こちらがもう一つのＶＢＡです。

Option Explicit
Public Sub アウトルックVBA()
RunOutlookMacro "Project1.ThisOutlookSession.日報から取り出しに移動" 'ThisOutlookSession
End Sub

Public Sub RunOutlookMacro(ByVal MacroName As String)
If CreateObject("WbemScripting.SWbemLocator").ConnectServer.ExecQuery _
("Select * From Win32_Process Where Name = 'OUTLOOK.EXE'").Count < 1 Then
Shell "OUTLOOK.EXE"
End If
With CreateObject("Outlook.Application")
With .ActiveExplorer.CommandBars("Standard").Controls.Add(Type:=1, Temporary:=True)
.OnAction = MacroName
.Execute
.Delete
End With
.Quit
End With
End Sub

それぞれでは正常に動くのですがＣＡＬＬで連続で実行するとエラーとなってしまいます
実行時エラー９１　オブジェクト変数またはwithブロック変数が設定されていませんとなります
デバックで黄色になる行は
二つ目のＶＢＡのこの行となります。
With .ActiveExplorer.CommandBars("Standard").Controls.Add(Type:=1, Temporary:=True)

色々と自分なりに宣言の書き換えなど試してみたのですがどうにもエラーが解決できません。
無知を承知で質問しております。どうか解決方法が分かる方にご教授いただければ嬉しく思います
よろしくお願いします

Answer 1

エラーの出る行の直前に、以下の文を入れてみたらどうなりますか？

    .Explorers.Add(.GetNamespace("MAPI").GetDefaultFolder(6)).Display

Comments

[kurutonken]

ご回答ありがとうございます。さっそく試してみたところ
実行時エラー４４９
引数は省略できません
と表示されて頂いたコードの部分が黄色になってエラートなってしまいました。

お手数をおかけしてすいません

[jinoji]

では、以下のようにするとどうなりますか。

With CreateObject("Outlook.Application")
Set objNAMESPC = .GetNamespace("MAPI")
Set exps = .Explorers
If exps.Count = 0 Then
Set fol = objNAMESPC.GetDefaultFolder(6)
Set exp = exps.Add(fol, 0)
Else
Set exp = exps(1)
End If
'exp.Display
With exp.CommandBars("Standard").Controls.Add(Type:=1, Temporary:=True)
' 以下略

[kurutonken]

ゆっくりとＰＣに対応できる時間がなかなか取れなくて記入いただいていたのに返信が遅れて申し訳ございませんでした。さきほど頂いたコードで試させて頂いた結果ですが

コンパイルエラー　変数が定義されていません
と表示され
Set objNAMESPC = .GetNamespace("MAPI")の行の
objNAMESPCが選択される状態となりました。

なんどもありがとうございます。

[jinoji]

Dim objNamespc, exps, fol, exp
を上記の直前に入れてください。

[kurutonken]

ありがとうございます。完璧に動作いたしました。本当にありがとうございます。
私には到底かけないコードです。見ず知らずの私のために貴重なお時間を頂きましたこと
本当に感謝いたします。頂いたコードを大切に使わせて頂きます。
ありがとうございました。