XXXXXさんへ Outlook VBA メニュー・コマンド から すべて送受信を探し 実行

アウトルックで下記の質問をいただきました。

>EXCELのVBAでOutLookを起動し未受信のメールをサーバーから受信した後に
>未読のメールをエクセルに転記、その後OutLookを終了するVBAを作りたいの
>ですが、
>起動後のOutLookでメールサーバから自動的に新規メールを受信する
>部分ができません。

起動後に受信したいので、
送受信のコマンドを実行させてみます。と思ったら、

追記 .Session.SendAndReceive(True) で 送信OKと連絡をもらう

質問者自身から別回答をもらってしまった（笑）

>
>OutLook に SendAndReceive メソッドが有ったのでもしやと思い

> を Excel VBA で実行させたところできました。
>

↑でできたので、ここから下、お蔵入り(そのまま恥を残しておきますね)

ツール → 送受信 → すべて送受信
のコマンドを実行させてみます。

コマンドの処理は、
未完成の署名を選択するプログラム
http://ken3-info.blog.ocn.ne.jp/day/2009/02/22_vba_outlook_4a33.html
で使っていた
As Office.CommandBars
を 参考に探ってみます。

これはひどい 自分語脳内垂れ流し動画

下記、解説と言えない、これはひどい 自分語 脳内垂れ流し動画です。
Youtubeで大きく見る→Outlook VBA As Office.CommandBar から 送受信を探し .Execute で実行 - YouTube
www.youtube.com

これはひどい、ひどすぎる 三流コード

これぞ三流コード、If文のネストがひどすぎです(ぉぃぉぃ)

Sub test_CommandBar_a()

    Dim n As Integer  'Outlook 一番外側のメニュー
    Dim i As Integer  'Menu Barのループ
    Dim j As Integer  'ツール メニューのループ
    Dim k As Integer  '送受信 メニューのループ
    
    Dim cbMENU As Office.CommandBar 'メニューバー
    Dim cbTOOL As Office.CommandBarPopup 'ツールのメニュー
    Dim cbSEND As Office.CommandBarPopup '送受信のメニュー
    
    For n = 1 To Application.ActiveExplorer.CommandBars.Count 'Outlookのメニュー
        Debug.Print n, Application.ActiveExplorer.CommandBars.Item(n).Name
        
        If Application.ActiveExplorer.CommandBars.Item(n).Name = "Menu Bar" Then 'Menu Barを探す
            Set cbMENU = Application.ActiveExplorer.CommandBars.Item(n)  '見つかったので変数にセット
            
            For i = 1 To cbMENU.Controls.Count  '↑上でセットした、Menu Barの中を探す
                Debug.Print i, cbMENU.Controls(i).Caption
                
                If cbMENU.Controls(i).Caption = "ツール(&T)" Then  'ツールを探す
                    Set cbTOOL = cbMENU.Controls(i)     '見つかったので変数にセット
                    
                    For j = 1 To cbTOOL.Controls.Count  '次は↑で見つけたツールの中から送受信を探す
                        Debug.Print j, cbTOOL.Controls(j).Caption
                        
                        If cbTOOL.Controls(j).Caption = "送受信(&E)" Then  '送受信か？
                            Set cbSEND = cbTOOL.Controls(j)  '見つかったのでまたまた変数にセット
                            
                            For k = 1 To cbSEND.Controls.Count '最後に↑送受信の中から すべて送受信を探す
                                Debug.Print k, cbSEND.Controls(k).Caption
                                
                                If cbSEND.Controls(k).Caption = "すべて送受信(&A)" Then 'やっと見つけたか？
                                    'コマンドの実行 .Executeで実行する
                                    cbSEND.Controls(k).Execute  '見つけたコマンド実行
                                    Exit For '見つけたので送受信のループを抜ける
                                End If
                            Next k
                            
                            Exit For 'ツールのループを抜ける
                        End If
                        
                    Next j
                    
                    Exit For 'Menu Barのループを抜ける
                End If
                
            Next i
            Exit For  '大外 Outlook コマンドバー の ループを抜ける
        End If
    
    Next n

End Sub

コードのポイントは、
送受信のコマンドを実行させたかったので、
ActiveExplorer.CommandBars
から、ツールを探し、
次に、
.CommandBar から 送受信を探す、
さらに
.CommandBarPopup から すべて送受信を探しだし、
.Execute で実行 してみました。

※↑と、馬鹿みたいに 上から 探してみました（笑）

上から順番に探すなら・・・少しひどいコード

上から順番にループで探しているだけなので、
ブロック単位に分けて、存在チェックを入れながら探してみました。

'メニューから 全て送受信を探し、実行する
Sub test_CommandBar_b()

    Dim n As Integer  'ループのカウンタ
    
    Dim cbMENU As Office.CommandBar      'メニューバー 格納用
    Dim cbTOOL As Office.CommandBarPopup 'ツールのメニュー 格納用
    Dim cbSEND As Office.CommandBarPopup '送受信のメニュー 格納用
    Dim ctlSENDALL As Office.CommandBarControl  'すべてを送受信、コントロール格納用
    
'Outlookの全体メニュー Application.ActiveExplorer.CommandBars からMenu Barを探す
    Set cbMENU = Nothing    'まず、Menu Bar格納用の変数を空にする
    For n = 1 To Application.ActiveExplorer.CommandBars.Count 'Outlookのコマンドバーの数ループ
        Debug.Print n, Application.ActiveExplorer.CommandBars.Item(n).Name
        
        '名前(.Name)がMenu Barのアイテム(Item(n番目))を探し、格納用変数に代入する
        If Application.ActiveExplorer.CommandBars.Item(n).Name = "Menu Bar" Then 'Menu Barを探す
            Set cbMENU = Application.ActiveExplorer.CommandBars.Item(n)  '見つかったので変数にセット
            Exit For  '大外 Outlook コマンドバー の ループを抜ける
        End If
    Next n
    '↑で見つかったか？変数にセットされているかで判断する
    If cbMENU Is Nothing Then  '中身がなければ(Nothingなら)
        MsgBox "Menu Barが見つかりません"
        Exit Sub   '↑メッセージを表示して関数を抜ける
    End If

'次に↑で見つけた、Menu Bar から ツールを探す
    Set cbTOOL = Nothing    'ツールのメニューバーをNothingで初期化
    For n = 1 To cbMENU.Controls.Count  'Menu Barの中を探す
        Debug.Print n, cbMENU.Controls(n).Caption
        
        '表題(.Caption)がツールのアイテム(.Controls(n番目))を探し、格納用変数に代入する
        If cbMENU.Controls(n).Caption = "ツール(&T)" Then  'ツールを探す
            Set cbTOOL = cbMENU.Controls(n)     '見つかったのでツール格納用変数にセット
            Exit For '↑代入後、Menu Barのループを抜ける
        End If
    Next n
    '↑で見つかったか？変数にセットされているかで判断する
    If cbTOOL Is Nothing Then  '中身がなければ(Nothingなら)
        MsgBox "ツールメニューが見つかりません"
        Exit Sub   '↑メッセージを表示して関数を抜ける
    End If

'次は ツール(cbTOOL)の中から 送受信を探します
    Set cbSEND = Nothing    '変数を初期化
    For n = 1 To cbTOOL.Controls.Count  '↑で見つけたツールの中から送受信を探す
        Debug.Print n, cbTOOL.Controls(n).Caption
        
        '表題(.Caption)が送受信のアイテム(.Controls(n番目))を探し、格納用変数に代入する
        If cbTOOL.Controls(n).Caption = "送受信(&E)" Then  '表題が送受信か？
            Set cbSEND = cbTOOL.Controls(n)  '見つかったのでn番目をまたまた変数にセット
            Exit For 'ツールのループを抜ける
        End If
    Next n
    '↑で見つかったか？変数にセットされているかで判断する
    If cbSEND Is Nothing Then  '中身がなければ(Nothingのまま)
        MsgBox "送受信のメニューが見つかりません"
        Exit Sub   '↑メッセージを表示して関数を抜ける
    End If

'やっと、↑送受信から、すべてを送受信 を 探す
    Set ctlSENDALL = Nothing   'コントロールの変数を初期化する
    For n = 1 To cbSEND.Controls.Count '最後に↑送受信の中から すべて送受信を探す
        Debug.Print n, cbSEND.Controls(n).Caption
        
        '表題(.Caption)がすべて送受信のアイテム(.Controls(n番目))を探し、格納用変数に代入する
        If cbSEND.Controls(n).Caption = "すべて送受信(&A)" Then 'やっと見つけたか？
            Set ctlSENDALL = cbSEND.Controls(n)    'みつけたn番目のコントロールをセットする
            Exit For '見つけたので送受信のループを抜ける
        End If
    Next n
    If ctlSENDALL Is Nothing Then  '中身がなければ(Nothingのまま)
        MsgBox "すべて送受信のコントロールが見つかりません"
        Exit Sub   '↑メッセージを表示して関数を抜ける
    End If
    
'やっとセットされたコントーる(みつけたコマンド)を .Executeで実行する
    ctlSENDALL.Execute  'コントロール.Executeで実行

'お疲れちゃん の 変数たちを解放する
    Set ctlSENDALL = Nothing
    Set cbSEND = Nothing
    Set cbTOOL = Nothing
    Set cbMENU = Nothing
    
End Sub

↑少しは、ましになったけど、まだまだだなぁ。
そんな 少しひどい コードでした。
※プロなら、再帰処理を使って、スマートに書けよ・・・と言われそうですが。。。

Item("名前") Controls("名前") で 参照できた(（笑）)

http://support.microsoft.com/kb/201095/ja

の

Sub cmdPrint_Click()
Item.GetInspector.CommandBars.Item("Menu Bar").Controls("File") _
.Controls("Print...").Execute
End Sub

で、できますね（笑）
※頭から探していた 自分が恥ずかしかったり(ぉぃぉぃ)

終わりの挨拶

またまた、やっちまったなぁ感のある
脳内 自分語 垂れ流し の 解説動画とコードでした。

もしかして、参考元の
http://ken3-info.blog.ocn.ne.jp/day/2009/02/22_vba_outlook_4a33.html
↑こっちで 1 からTo 35000 件 総当たりで .FindControlのほうがスッキリしてたかも？
※まぁ、ドッチもダメですが。

正解の 再帰処理でスマートに多重階層を処理しろよ・・・と、
読者の声が聞こえたところで、逃げるように失礼します。

何かの参考となれば(反面教師となれば)幸いです。 三流プログラマー Ken3

2012-02-22 追記

忘れてた、質問は、

>EXCELのVBAでOutLookを起動し未受信のメールをサーバーから受信した後に
>未読のメールをエクセルに転記、その後OutLookを終了するVBAを作りたいの
>ですが、
>起動後のOutLookでメールサーバから自動的に新規メールを受信する
>部分ができません。

Excelからのコントロールだった。

下記、頭に Outlookの起動を入れただけのコード。

Option Explicit

'Outlookを起動後、メニューから 全て送受信を探し、実行する
Sub test_Outlook_sendall()

'Outlookの起動
    Dim oApp        As Object 'As Outlook.Application OutlookのApplication オブジェクトを入れる
    Dim myNameSpace As Object 'As Outlook.NameSpace 名前のスペースと言われても、、
    Dim myFolder    As Object 'As Outlook.Folder フォルダー指定

    'outlook 起動をCreateObjectで ※これだと複数起動してしまうがご勘弁を
    Set oApp = CreateObject("Outlook.Application")

    '呪文１ 名前空間 の 指定 と言っても、.GetNamespace("MAPI")しただけ
    Set myNameSpace = oApp.GetNamespace("MAPI")
    
    '次は作業フォルダーの指定(.GetDefaultFolder) と 表示(.Display)
    Set myFolder = myNameSpace.GetDefaultFolder(6) '規定のフォルダー olFolderInbox=6 指定
    myFolder.Display  '表示 いつものクセで .Visible = True とやりがちだけど

    '通常サイズ olNormalWindow=2 で表示(ほかに olMaximized=0,olMinimized=1)
    oApp.ActiveWindow.WindowState = 2   'olNormalWindow=2 を セット

'ここから、メニュー・コマンドバーを探り、すべて送受信を実行する

    Dim n As Integer  'ループのカウンタ
    Dim cbMENU As Object 'As Office.CommandBar      'メニューバー 格納用
    Dim cbTOOL As Object 'As Office.CommandBarPopup 'ツールのメニュー 格納用
    Dim cbSEND As Object 'As Office.CommandBarPopup '送受信のメニュー 格納用
    Dim ctlSENDALL As Object 'As Office.CommandBarControl  'すべてを送受信、コントロール格納用
    
'Outlookの全体メニュー Application.ActiveExplorer.CommandBars からMenu Barを探す
    Set cbMENU = Nothing    'まず、Menu Bar格納用の変数を空にする
    For n = 1 To oApp.ActiveExplorer.CommandBars.Count 'oapp で Outlookのコマンドバー参照
        Debug.Print n, oApp.ActiveExplorer.CommandBars.Item(n).Name
        
        '名前(.Name)がMenu Barのアイテム(Item(n番目))を探し、格納用変数に代入する
        If oApp.ActiveExplorer.CommandBars.Item(n).Name = "Menu Bar" Then 'Menu Barを探す
            Set cbMENU = oApp.ActiveExplorer.CommandBars.Item(n)  '見つかったので変数にセット
            Exit For  '大外 Outlook コマンドバー の ループを抜ける
        End If
    Next n
    '↑で見つかったか？変数にセットされているかで判断する
    If cbMENU Is Nothing Then  '中身がなければ(Nothingなら)
        MsgBox "Menu Barが見つかりません"
        Exit Sub   '↑メッセージを表示して関数を抜ける
    End If

'次に↑で見つけた、Menu Bar から ツールを探す
    Set cbTOOL = Nothing    'ツールのメニューバーをNothingで初期化
    For n = 1 To cbMENU.Controls.Count  'Menu Barの中を探す
        Debug.Print n, cbMENU.Controls(n).Caption
        
        '表題(.Caption)がツールのアイテム(.Controls(n番目))を探し、格納用変数に代入する
        If cbMENU.Controls(n).Caption = "ツール(&T)" Then  'ツールを探す
            Set cbTOOL = cbMENU.Controls(n)     '見つかったのでツール格納用変数にセット
            Exit For '↑代入後、Menu Barのループを抜ける
        End If
    Next n
    '↑で見つかったか？変数にセットされているかで判断する
    If cbTOOL Is Nothing Then  '中身がなければ(Nothingなら)
        MsgBox "ツールメニューが見つかりません"
        Exit Sub   '↑メッセージを表示して関数を抜ける
    End If

'次は ツール(cbTOOL)の中から 送受信を探します
    Set cbSEND = Nothing    '変数を初期化
    For n = 1 To cbTOOL.Controls.Count  '↑で見つけたツールの中から送受信を探す
        Debug.Print n, cbTOOL.Controls(n).Caption
        
        '表題(.Caption)が送受信のアイテム(.Controls(n番目))を探し、格納用変数に代入する
        If cbTOOL.Controls(n).Caption = "送受信(&E)" Then  '表題が送受信か？
            Set cbSEND = cbTOOL.Controls(n)  '見つかったのでn番目をまたまた変数にセット
            Exit For 'ツールのループを抜ける
        End If
    Next n
    '↑で見つかったか？変数にセットされているかで判断する
    If cbSEND Is Nothing Then  '中身がなければ(Nothingのまま)
        MsgBox "送受信のメニューが見つかりません"
        Exit Sub   '↑メッセージを表示して関数を抜ける
    End If

'やっと、↑送受信から、すべてを送受信 を 探す
    Set ctlSENDALL = Nothing   'コントロールの変数を初期化する
    For n = 1 To cbSEND.Controls.Count '最後に↑送受信の中から すべて送受信を探す
        Debug.Print n, cbSEND.Controls(n).Caption
        
        '表題(.Caption)がすべて送受信のアイテム(.Controls(n番目))を探し、格納用変数に代入する
        If cbSEND.Controls(n).Caption = "すべて送受信(&A)" Then 'やっと見つけたか？
            Set ctlSENDALL = cbSEND.Controls(n)    'みつけたn番目のコントロールをセットする
            Exit For '見つけたので送受信のループを抜ける
        End If
    Next n
    If ctlSENDALL Is Nothing Then  '中身がなければ(Nothingのまま)
        MsgBox "すべて送受信のコントロールが見つかりません"
        Exit Sub   '↑メッセージを表示して関数を抜ける
    End If
    
'やっとセットされたコントーる(みつけたコマンド)を .Executeで実行する
    ctlSENDALL.Execute  'コントロール.Executeで実行

'お疲れちゃん の 変数たちを解放する
    Set ctlSENDALL = Nothing
    Set cbSEND = Nothing
    Set cbTOOL = Nothing
    Set cbMENU = Nothing
    
End Sub