三流君 ken3のmemo置き場

メモ置き場、保管庫として利用。まとまっていませんがヨロシク

挨拶・自己紹介:
失敗続きのAB型の変わり者 :三流プログラマー Ken3です
フリーのエンジニア・個人事業主です・・と書くと聞こえはイイが(それとなくカッコよく聞こえるが)、 現在は小さな案件の受注請負 と 短期派遣 で 日々つつましく?ほそぼそと暮らしてます。
(※詳細は[三流君 三流プログラマーとは?]を見てください)


広告:


[記事一覧、バックナンバーを見る]

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

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


>EXCELVBAOutLookを起動し未受信のメールをサーバーから受信した後に
>未読のメールをエクセルに転記、その後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

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

これぞ三流コード、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 追記

忘れてた、質問は、


>EXCELVBAOutLookを起動し未受信のメールをサーバーから受信した後に
>未読のメールをエクセルに転記、その後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")

    '呪文1 名前空間 の 指定 と言っても、.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



三流君へ メッセージを送る

全ての質問に答えることはできませんが、
ダメもとで、気軽に質問、感想、メッセージを送ってくださいね・・・

感想や質問・要望・苦情など 三流君へメッセージを送る。
下記のフォームからメッセージを送ることができます。


あなたのお名前(ニックネーム):さん
返信は?:

アドレス:に返事をもらいたい
感想や質問↓:


(感想や質問・要望・苦情はHPで記事に載せることがあります。)
例:[XXXXさんへ回答例]←みたいに回答していたり...


Ken3 ホームページ 目次

分類:HPを大きく分けると4つの柱(分類)です。
・[Excel/Access VBA]の解説
・[ASP(Active Server Pages)]の解説。
・[元コンビニ店長時代の話]が弟に巻き込まれ、失敗した脱サラ、畑違い?の仕事で失敗。
・[プログラマーの愚痴]では、あまり見せたくない三流プログラマーの内面かな。
三流君を踏み台にする
主に上記4つの分類でHP作成やメルマガの発行を行ってます。
※更新頻度が落ちていて情報の鮮度が悪いです。

三流解説動画の再生リスト
https://www.youtube.com/user/ken3video/playlists

本当に三流なんです(笑):たまにスゴイですねなんて言われることもありますが、
真実は→ [三流君の真実は...] ←を初めに見てくださるとわかると思います。
(からくりは、成功例↑しか載せてなくて ヒドイ失敗例はお蔵入り迷宮入りが多かったりします)