Outlookで複数のファイルを添付するには？

発行内容

Outlookで複数のファイルを添付するには？

どうも、三流プログラマーのＫｅｎ３です。

今回は、
Outlookで*.xlsなど、複数のファイルを添付する、
そんな処理にチャレンジしてみたいと思います。

/*
 * １. 今回のキッカケ
*/

No.078 Outlookでファイルを添付するには？.Attachments.Add 
http://www.ken3.org/vba/backno/vba078.html
からもらった質問。
---
>ご紹介頂いた添付の自動処理ですが、添付するファイルが常に同じフォルダ
>にあって、ファイル名はその日によって異なるが拡張子だけは常に同じとい
>う場合、ワイルドカードって使えるんでしょうか？
>例えばC:\My Documents 内にあるエクセルファイルを添付したい場合、
>
>objMAIL.Attachments.Add "C:\My Documents\"*.xls""
>
>として試してみたら構文エラーと表示されてしまいます。
---
と質問をもらった。

う〜ん・・・どうしましょ・・・
>objMAIL.Attachments.Add "C:\My Documents\"*.xls""
で複数ファイルを添付したいかぁ・・・

/*
 * ２．勝手に仕様や考え方を変える
*/

上司や先輩が作った動作仕様を勝手に変えると、
動いたり、いい処理を作っても怒られてしまうこともあるのだが、
（※相手のプライドを立てながら・・政治的に動くプログラマーって...イヤだけど）
なんて話は、置いといて、

原因は、
>objMAIL.Attachments.Add "C:\My Documents\"*.xls""
で複数ファイルを添付できない
ならば、１つ１つバラバラで添付してみますか。
※１つ１つの連続が複数ってことで

/*
 * ３．ファイル名を取得する方法でDir関数を使う
*/

とすると、知りたいのは少し変わって、
C:\My Documents\*.xls
このファイル名を取得したいよね。

そんな時に使うのがDir関数です。(※他にもあるけど今回はこれで)

Sub aaa()

    'マイドキュメントの*.xlsファイル名をMSGBOXで表示する
    
    Dim strBASEPATH As String
    Dim strFILETYPE As String
    Dim strFileName As String
    
    'strBASEPATH = "C:\My Documents\"  '調べたい場所
    strBASEPATH = "C:\Documents and Settings\user2000\My Documents\"

    strFILETYPE = "*.xls"  'マッチングパターン

    'DIR関数にC:\My Documents\*.xlsみたいにワイルドカード付きを渡す
    strFileName = Dir(strBASEPATH & strFILETYPE) 
    '↑すると、一番最初の名前が返ってくる(順不同)
    
    '名前がなくなるまでループ
    While strFileName <> ""   'ファイル名が""空文字以外の間ループする
        'ファイル名を使って処理を行う
        MsgBox "ファイル名は" & strFileName & "です"
                'いろいろな処理を行う
        '↑と１つのファイルの処理が終わったら、次の名前を取り出します
        '↓次の名前の処理に移るには、Dir関数を引数無しで呼び出します
        strFileName = Dir  '←不思議だがこの引数無しで次のパターンを取り出せる
    Wend
    '↑こんな感じでループを作って１つ１つファイルを処理してみました。

End Sub

基本の作りは、
ファイル名=Dir("ファイルの場所＋*.xlsなどのパターン",ファイルの種類(省略化))
ではじめにC:\My Documents\*.xlsみたいにワイルドカード付きを渡す
すると、ファイル名が返ってくるので、

あとはループで、
While ファイル名が空になるまで(ファイル名で無い間)
   ファイル名がわかるのでファイルに対して処理を行う
   処理したよ

   処理が終了したら、次のファイル名に進まなきゃ
　 strFileName = Dir  '←＊１不思議だがこの引数無しで次のパターンを取り出せる
Wend ループの先頭へ

ポイントはDir関数を引数無しで呼ぶことかな。＊１

/*
 * ４．添付ファイルを繰り返しセットしてみた
*/

Dir関数でのテストが終了したら、
複数ファイルを添付する、そんなテストプログラムを作成してみます。

Sub testSEND送信()

    Dim oApp As Object    'アプリケーションオブジェクト
    Dim objMAIL As Object 'メールのオブジェクト
    Dim strMOJI As String '本文

    'アプリケーションオブジェクトの作成
    Set oApp = CreateObject("Outlook.Application")

    Set objMAIL = oApp.CreateItem(0) 'olMailItem=0
    
    strMOJI = "こんにちは" & vbCrLf _
            & "資料を送ります、" & vbCrLf _
            & "よろしくお願いします"

    objMAIL.To = "test@ken3.org"           '宛先
    objMAIL.Subject = "未承諾広告※（笑）"  '件名
    objMAIL.Body = strMOJI                 '本文の代入

    'ここでファイル数分 添付ファイルを＋する処理を行う
    Dim strBASEPATH As String
    Dim strFILETYPE As String
    Dim strFileName As String
    
    'strBASEPATH = "C:\My Documents\"  '調べたい場所
    strBASEPATH = "C:\Documents and Settings\user2000\My Documents\"
    strFILETYPE = "*.xls"  'マッチングパターン
    
    strFileName = Dir(strBASEPATH & strFILETYPE) 'DIR関数にPATH+*.xlsを渡す
    '↑すると、一番最初の名前が返ってくる(順不同)
    
    '名前がなくなるまでループ
    While strFileName <> ""   'ファイル名が""空文字以外の間ループする
        'ファイル名を使って処理を行う
            '↓１つ1つ添付する ↓↓パス＋ファイル名を渡す
        objMAIL.Attachments.Add strBASEPATH & strFileName 
        '↓次の名前の処理に移るには、Dir関数を引数無しで呼び出します
        strFileName = Dir  '←引数無しで次のパターンを取り出せる
    Wend
    '↑こんな感じでループを作って１つ１つファイルを処理してみました。

    objMAIL.Display    '編集メッセージの表示 .Sendから変更

    'おまけでＯｕｔｌｏｏｋ表示
    Dim myNameSpace As Object
    Dim myFolder As Object

    Set myNameSpace = oApp.GetNameSpace("MAPI")
    Set myFolder = myNameSpace.GetDefaultFolder(6) '規定のフォルダーを指定

    myFolder.Display  '表示

End Sub

チョット、ぐちゃぐちゃしてますが、こんな感じで複数無事に添付できたと思います。

/*
 * ５．終わりの挨拶
*/

今回は、
Dir関数を使用して、*.xlsのファイル名を取り出す。
その取り出した複数ファイルをOutlookで添付してみた。
そんな話でした。

三流君VBAでOutlookを操作する
http://www.ken3.org/cgi-bin/group/vba_outlook.asp
↑にVBA Outlook系のメルマガまとめてます、こちらも一口どうぞ。

全体的に斬新なテクニック系のネタじゃないのですが、
何か、感じ取ってくれると、うれしいです。

ＡＢ型の変わり者、三流プログラマーのＫｅｎ３でした。

ページフッター

ここまで、読んでいただきどうもです。ここから下は、三流君のホームページの紹介・案内です
目的の情報が見つかったか？少々心配しつつ、、、

種類別のリンク や 広告など

Blogとリンク:[三流君の作業日記]/ [VBAやASPのサンプルコード]/ 広告-[通販人気商品の足跡]