三流君 Outlook Mail メールを操作する

Option Explicit
Sub MAKE_MAIL_ITEM_TEST_NG()

    Dim oApp As Object
    Dim myNameSpace As Object
    Dim myFolder As Object

    Dim objMAIL As Object 'メールのオブジェクト
    Dim strMOJI As String '本文

    'outlook 起動
    Set oApp = CreateObject("Outlook.Application")

    Set myNameSpace = oApp.GetNamespace("MAPI")
    Set myFolder = myNameSpace.GetDefaultFolder(6) '規定のフォルダーを指定
    myFolder.Display  '表示 いつものクセで .Visible = True とやりがちだけど


    'メールアイテムの作成
    Set objMAIL = oApp.CreateItem(0) 'olMailItem=0 直値はいけないと思いつつ、
    objMAIL.Display   '画面表示(Mail入力、編集画面を表示)

    '宛先・件名・本文 などのデータを代入する
    objMAIL.To = "test@ken3.org"           '宛先 ほかに.cc や.Bccも可能です
    'objMAIL.CC = "vba@ken3.org"           '宛先 .cc
    'objMAIL.BCC = "vba@ken3.org ; oltest@ken3.org"         '宛先を複数は ; セミコロンで区切る
    
    objMAIL.Subject = "テスト メールの件名です "  '.Subjectに文字列設定で件名
    
    '本文を作る、(vbCrLfで改行されます)
    strMOJI = "こんにちは(このメールtestアドレスなので質問は別便で)" & vbCrLf _
            & " ここで 文字列を作って .Bodyに代入する" & vbCrLf _
            & " メールアイテムが作成されたらその後、 " & vbCrLf _
            & " .save 下書きへ保存 や .sendで送信(確認が出る)" & vbCrLf _
            & " 今回は、.Display で メール作成画面を表示" & vbCrLf _
            & Now() & "作成"

    objMAIL.Body = strMOJI                 '本文の代入

    '添付ファイルを送りたいって？ そんな時は、.Attachments.Add "ファイル名"
    'objMAIL.Attachments.Add "e:\work\test.txt"        '本当はファイルの存在チェックも事前にしたいけど
    'objMAIL.Attachments.Add "e:\work\作業報告書.xls"  '複数送りたかったら、再度.Addしてね

    objMAIL.Display   '編集画面のまま止めておきたい時 や テスト中に動作を見たいとき
    objMAIL.Save   '保存、下書きへ  保存後、用が無かったら.Closeで閉じるのがいいのかなぁ。。。
    'objMAIL.Close 2  '閉じる Mailの編集画面を閉じる
    
    'objMAIL.Send   '送信箱へ ※セキュリティの警告メッセージが出るよ
    
    'ここで、普通はオブジェクトの開放など、後始末をする。

End Sub

'Excel2003 VBA から OutLook2003を起動して 受信メールを1つ1つ取り出す
Sub OL_TEST_LOOK_MAIL_0221()  

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

    '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 とやりがちだけど
    
    '次にメールの中身を取り出したいと思います。
    Dim objMAILITEM As Object 'メールアイテム
    Dim n As Integer  'カウンター
    
    For n = 1 To myFolder.Items.Count  'フォルダーのアイテム数分ループ
        'メールを１通取り出す、変数にセットする
        Set objMAILITEM = myFolder.Items(n) '別にあらためてセットしなくても使えるけど
        'テストデータをセルにセットする※11行目からセットする。。。
        Cells(n + 10, "A") = objMAILITEM.CreationTime  '作成日
        Cells(n + 10, "B") = objMAILITEM.SenderName    '差出人
        Cells(n + 10, "C") = objMAILITEM.SenderEmailAddress    '差出人のアドレス
        Cells(n + 10, "D") = objMAILITEM.Subject       '件名
        Cells(n + 10, "E") = objMAILITEM.Body          '本文
    Next n

End Sub

Private Sub UserForm_Initialize()
    'フォームの初期化イベントでリストボックスにメールデータをセットする
    Dim objOL      As Object 'OutLookのアプリケーションオブジェクト
    Dim objNAMESPC As Object '名前空間
    Dim objFLD     As Object 'フォルダー保存用
    Dim objMAIL    As Object 'メールアイテム
    Dim strWORK As String

    Me.lstMAIL.Clear  '.Clearでリストボックスの内容を全てクリア
    'アプリケーションのオブジェクトを新規作成
    Set objOL = CreateObject("Outlook.Application")
    'Namespace オブジェクト作成
    Set objNAMESPC = objOL.GetNamespace("MAPI")
    'フォルダーの下、第二階層.Foldersでループさせる
    For Each objFLD In objNAMESPC.Folders(1).Folders
        'フォルダー名が受信トレイか？
        If objFLD.Name = "受信トレイ" Then
            'フォルダーのアイテム数分ループ Folders.Items
            For Each objMAIL In objFLD.Items
                '作成日:題名で文字列を作成する
                strWORK = objMAIL.CreationTime & ":" & objMAIL.Subject
                'データをセット
                Me.lstMAIL.AddItem (strWORK)
            Next objMAIL
        End If
    Next objFLD
    '後始末
    objOL.Quit
End Sub