オートメーション機能を利用してAccessの顧客データからOutlook経由で電子メールを自動送信するためのお手本
図6-3-1 Outlook経由で電子メールを送信するサンプルデータベース
このサンプルデータベースでは、Accessの顧客テーブルから電子メールを自動送信します。顧客テーブルには、電子メールアドレス、性別、誕生日、趣味、嗜好などの顧客情報を格納しておきます。電子メールを送信する対象者は、Accessのクエリを使用して絞込みします。
電子メールを送信するには、メール検索のコンボボックスから、既に送信したメールの雛型を選択します。新規メールを送信するときは、フォーム最下位のレコード移動ボタンから、レコードの追加ボタンをクリックして入力します。メール検索のコンボボックスから、メールの雛型を選択すると、メールタイプ、宛先（クエリ）、件名、本文が自動的に表示されます。宛先（クエリ）のコンボボックスからは、宛先を絞り込むためのクエリを選択します。（クエリは、事前に作成しておきます。）件名のコンボボックスからは、今回送信するメールの件名を選択します。コンボボックスの一覧に表示されていない件名を入力すると、自動的に登録します。最後に、本文にデータを入力したら、送信ボタンをクリックして送信します。（メールの本文は、HTML形式にて送信することも可能です。）オプションとして、３個のファイルを添付することができます。添付１-３のコマンドボタンをクリックすると、Windowsのコモンダイアログが表示されますので、目的の添付ファイルを選択します。
サンプルデータベースでは、Outlookの宛先（BCC：）に１００人ぐらいの単位でメールアドレスを指定して高速化しています。Outlookの送信トレイに登録されたメールは、Outlook から送信、または送受信ボタンをクリックしたときに、送信されます。
サンプルデータベース(CH6-3.mdb)では、以下に示すノウハウを習得することができます。
◆ Access からOutlook を起動して電子メールを送信する方法
◆ Outlook の宛先（BCC）に複数のメールアドレスを指定してメールを一括して送信する方法
◆ HTML形式で電子メールを送信する方法
◆ 電子メールにファイルを添付する方法
◆ Windowsのコモンダイアログを使用する方法
◆ コンボボックスに入力した新規データをテーブルに追加する方法
◆ フォーム上の必須項目を自動的にチェックする汎用関数を作成する方法
◆ フィールドがデータ型がメモ型のとき、データを取得する方法（GetChunkの使い方）
● サンプルデータベースで使用するテーブル/クエリを準備するには
１ Access を起動したら作業フォルダに、新規データベースCH6-3.mdbを作成します。
２ データベースウィンドウからテーブル
をクリックしたら、一覧からデザインビューでテーブルを作成するをダブルクリックします。テーブルのデザインビューが表示されたら、tblEmailAddrテーブルのフィールド名、データ型を入力します。全てのフィールド名を入力したら、フィールド名EmailIDを選択して、主キーのアイコン
をクリックして主キーを設定します。テーブルを、tblEmailAddrの名称で保存してサンプルデータを入力します。同様の手順で、tblMailTypeとtblSubjectテーブルを登録します。
表6-3-1 tblEmailAddrテーブルの構造
|
テーブル名 |
説 明 |
作成日 |
最終更新日 |
||
|
tblEmailAddr |
メールアドレスを格納します |
|
|
||
|
No |
フィールド名 |
データ型 |
サイズ |
説 明 |
|
|
1 |
EmailID |
オートナンバー型 |
4 |
主ｷｰ設定 |
|
|
2 |
SenderName |
テキスト型 |
25 |
|
|
|
3 |
Email |
テキスト型 |
60 |
|
|
|
4 |
Gender |
テキスト型 |
1 |
Male, Female |
|
|
5 |
BirthDate |
日付/時刻型 |
8 |
|
|
|
6 |
Description |
テキスト型 |
255 |
|
|
|
7 |
Select1 |
Yes/No型 |
1 |
|
|
|
8 |
Select2 |
Yes/No型 |
1 |
|
|
|
9 |
Select3 |
Yes/No型 |
1 |
|
|
|
10 |
Added |
日付/時刻型 |
8 |
|
|
|
11 |
Updated |
日付/時刻型 |
8 |
|
|
表6-3-2 tblMailTypeテーブルの構造
|
テーブル名 |
説 明 |
作成日 |
最終更新日 |
||
|
tblMailType |
送信済みメールの履歴を保存します |
|
|
||
|
No |
フィールド名 |
データ型 |
サイズ |
説 明 |
|
|
1 |
MailTypeID |
オートナンバー型 |
4 |
主ｷｰ設定 |
|
|
2 |
MailType |
テキスト型 |
255 |
|
|
|
3 |
QueryName |
テキスト型 |
255 |
|
|
|
4 |
Subject |
テキスト型 |
255 |
|
|
|
5 |
Body |
メモ型 |
0 |
|
|
|
6 |
AttachmentPath1 |
テキスト型 |
255 |
|
|
|
7 |
AttachmentPath2 |
テキスト型 |
255 |
|
|
|
8 |
AttachmentPath3 |
テキスト型 |
255 |
|
|
表6-3-3 tblSubjectテーブルの構造
|
テーブル名 |
説 明 |
作成日 |
最終更新日 |
||
|
tblSubject |
メールの件名を格納します |
|
|
||
|
No |
フィールド名 |
データ型 |
サイズ |
説 明 |
|
|
1 |
SubjectID |
オートナンバー型 |
4 |
主ｷｰ設定 |
|
|
2 |
SubjectName |
テキスト型 |
50 |
|
|
図6-3-2 tblEmailAddrにサンプルデータを入力した例
３ テーブルを作成したら、データベースウィンドウからクエリ
をクリックして、一覧からデザインビューでクエリを作成するをダブルクリックします。テーブルの表示ダイアログが表示されたらtblEmailAddrを選択して追加ボタンをクリックします。閉じるのボタンをクリックして表示ダイアログを閉じます。tblEmailAddrのフィールド一覧から、SenderName, Email, EmailID,
Select1をダブルクリックしてQEBフィールドに移動します。EmailIDの並べ替えのコンボボックスをクリックして昇順を選択します。Select1の抽出条件にTrueを設定して、ニュースレター購読者1のみ抽出されるように絞込みます。クエリを”Access Knwohow 購読者１”の名称で保存して閉じます。
図6-3-3 ニュースレター購読者1用のクエリ作成
４ Accessのクエリを使用すると、図6-3-4のように顧客データを性別（女性）、年齢（20歳～29歳）などで絞込みしてダイレクトメールを送信することができます。
図6-3-4 顧客データを性別、年齢で絞込みした例
５ テーブルとクエリの準備ができたら、Accessを終了させます。
● 顧客テーブルから電子メールを送信するフォームを作成するには
１ Access を起動したら、作業フォルダに作成した CH6-3.mdbを開きます。
２ データベースウィンドウが表示されたら、モジュール
をクリックして新規作成ボタンをクリックします。
３ VBEが起動されてモジュールウィンドウが表示されたら、VBEのツールメニューから参照設定をクリックします。参照設定のダイアログが表示されたら、参照可能なライブラリファイルからMicrosoft Outlook X.X Object LibraryとMicrosoft DAO 3.6 Object Libraryを選択してOKボタンをクリックします。Visual Basic For Application, Microsoft Access 9.0 Object Library, OLE AutomationそしてMicrosoft ActiveX Data Object 2.1 Libraryは、既に選択されています。
図6-3-5 リストボックスからMicrosoft Outlook 9.0 Object LibraryとMicrosoft DAO 3.6 Object Libraryを選択した例
４ モジュールウィンドウに戻ったらCH6-3.mdbを開いてbasAutomation, basChangeProperty, basMyLib, basWindowsCommonDialogをコピーして貼り付けます。
５ データベースウィンドウからフォーム
をクリックしたら、新規作成ボタンをクリックします。フォームの新規作成ダイアログが表示されたら、基になるテーブル/クエリのコンボボックスからtblMailTypeを選択します。リストボックスからデザインビューを選択したら、OKボタンをクリックします。
フォームのデザインビューが表示されたら、ツールボックスのアイコン
をクリックして、ツールボックスを表示させます。ツールボックスのコントロールウィザードのアイコン
がクリック（ウィザード機能が有効になっている）されているか確認したら、コンボボックスのアイコン
をクリックして、フォームヘッダーに配置します。コンボボックスのウィザードが起動されたら、指示に従って、tblMailTypeテーブルを表示するコンボボックスを作成します。コンボボックスのプロパティを表示させたら、表6-3-4のように設定します。
次に、ツールボックスからコマンドボタンのアイコン
をクリックして、コンボボックスの右側に３個（右側から閉じる、送信、ヘルプ）のコマンドボタンを作成します。コマンドボタンのプロパティを表示させたら、表6-3-4のように設定します。
表6-3-4 フォームヘッダーに作成したコントロールのプロパティ
|
コントロールの種類 |
プロパティ |
値 |
|
コンボボックス |
名前 |
cboMailType |
|
値集合タイプ |
テーブル/クエリ |
|
|
値集合ソース |
SELECT tblMailType.MailTypeID, tblMailType.MailType FROM tblMailType ORDER BY tblMailType.MailType; |
|
|
連結列 |
１ |
|
|
列数 |
２ |
|
|
列幅 |
0cm;5.5cm |
|
|
コマンドボタン１ |
名前 |
cmdExit |
|
ピクチャ |
ビットマップ |
|
|
クリック時 |
イベントプロシージャ |
|
|
コマンドボタン２ |
名前 |
cmdSubmit |
|
ピクチャ |
ビットマップ |
|
|
クリック時 |
イベントプロシージャ |
|
|
コマンドボタン３ |
名前 |
cmdHelp |
|
ピクチャ |
ビットマップ |
|
|
クリック時 |
イベントプロシージャ |
６ メニューからフィールドリストのアイコン
を表示させたら、MailTypeID、MailType、QueryName、Subject、Body、AttachmentPath1、AttachmentPath2、AttachmentPath3をドラッグしてフォーム詳細に配置します。QueryNameのテキストボックスを選択したら、マウスの右ボタンをクリックして、ショートカットメニューを表示させます。ショートカットメニューからコントロールの種類の変更èコンボボックスを選択してコンボボックスに変更します。同様の手順で、Subjectのテキストボックスを選択したら、コンボボックスに変更します。ツールボックスから、チェックボックスのアイコン
をクリックして、Bodyのテキストボックスの左側に配置します。チェックボックスの周りに、四角形を作成してくぼみをつけます。最後に、ツールボックスからコマンドボタンのアイコンをクリックして、Attachment1-3のテキストボックスの左側に配置します。フォームの詳細に配置したコントロールのプロパティは、表6-3-5のように設定します。
表6-3-5 フォーム詳細に作成したコントロールのプロパティ
|
コントロールの種類 |
プロパティ |
値 |
|
テキストボックス１ |
名前/コントロールソース |
MailTypeID |
|
可視 |
いいえ |
|
|
テキストボックス２ |
名前 |
txtMailType |
|
コントロールソース |
MailType |
|
|
エラーメッセージ |
メールタイプを入力してください！ |
|
|
コンボボックス１ |
名前 |
cboQueryName |
|
コントロールソース |
QueyName |
|
|
値集合タイプ |
テーブル/クエリ |
|
|
値集合ソース |
SELECT MsysObjects.Name FROM MsysObjects WHERE (((Left([Name],1))<>'~') AND ((MsysObjects.Type)=5)) ORDER BY MsysObjects.Name; |
|
|
連結列 |
１ |
|
|
列数 |
１ |
|
|
エラーメッセージ |
宛先用のクエリを選択してください！ |
|
|
コンボボックス２ |
名前 |
cboSubject |
|
コントロールソース |
Subject |
|
|
値集合タイプ |
テーブル/クエリ |
|
|
値集合ソース |
SELECT tblSubject.SubjectName,
tblSubject.SubjectID FROM tblSubject ORDER BY tblSubject.SubjectID; |
|
|
連結列 |
１ |
|
|
列数 |
２ |
|
|
列幅 |
15cm;0cm |
|
|
入力チェック |
はい |
|
|
エラーメッセージ |
件名を選択または入力してください！ |
|
|
テキストボックス３ |
名前 |
txtBody |
|
コントロールソース |
Body |
|
|
エラーメッセージ |
本文を入力してください！ |
|
|
テキストボックス４ |
名前 |
txtAttachmentPath1 |
|
コントロールソース |
AttachmentPath1 |
|
|
テキストボックス５ |
名前 |
txtAttachmentPath2 |
|
コントロールソース |
AttachmentPath2 |
|
|
テキストボックス６ |
名前 |
txtAttachmentPath3 |
|
コントロールソース |
AttachmentPath3 |
|
|
チェックボックス |
名前 |
chkHTML |
|
既定値 |
False |
|
|
四角形 |
立体表示 |
くぼみ |
|
コマンドボタン１ |
名前 |
cmdAttachmentPath1 |
|
標題 |
添付１ |
|
|
クリック時 |
イベントプロシージャ |
|
|
コマンドボタン２ |
名前 |
cmdAttachmentPath2 |
|
標題 |
添付２ |
|
|
クリック時 |
イベントプロシージャ |
|
|
コマンドボタン３ |
名前 |
cmdAttachmentPath3 |
|
標題 |
添付３ |
|
|
クリック時 |
イベントプロシージャ |
図6-3-6 QueyNameのショートカットメニューを表示させて、テキストボックスからコンボボックスに変更する例
７ メニューからコードのアイコン
をクリックしてフォームモジュールを表示させます。CH6-3.mdbを開いて、frmEmailのフォームモジュールをコピーして貼り付けます。フォームモジュールの詳細は、リスト6-3-1を参照してください。フォームをfrmEmailの名称で保存します。フォームからヘルプボタンをクリックしたときに表示される、フォームfrmReadMeの作り方については省略します。
図6-3-7 フォームに全てのコントロールを配置して完成させた例
８ メニューからビューのアイコン
をクリックして、フォームを表示させます。フォームが表示されたら、フォーム最下位のレコード移動ボタンからレコードの追加ボタン
をクリックします。
メールタイプのテキストボックスに“テスト１”を入力します。宛先（クエリ）のコンボボックスから、“Access Knowhow 購読者１”を選択します。件名のコンボボックスに、“テスト１”を入力します。“テスト１が件名テーブルにありません！ 登録しますか？”のメッセージが表示されたら、“はい”のボタンをクリックして登録します。本文に“テスト１”を入力したら、送信ボタンをクリックします。“１件のメールが作成されました！・・・・”のメッセージが表示されたら、OKボタンをクリックします。
Outlookを起動したら、送信トレイに切り替えて、メールが登録されているか確認します。宛先のメールアドレスは、BCCに格納されます。メールアドレスが複数の場合、約１００人ぐらいのメールアドレスがセミコロン（;）区切りで格納されます。メールが登録されていることを確認したら、送信ボタンをクリックして送信します。
図6-3-8 Outlook 2000の送信トレイにメールが登録された例
９ 既に、送信したメールを雛型として再使用するときは、メール検索のコンボボックスから、目的の雛型を選択します。宛先、件名、本文に雛型の内容が表示されますので、変更箇所があれば変更して送信ボタンをクリックしてメールを作成します。
図6-3-9 メール検索のコンボボックスから、送信済みメールの雛型を選択して再送信する例
１０ フォームを保存したら、Access を終了させます。
Form_Current()イベントの処理
このイベントは、フォームに表示されているレコードが移動するときに発生します。このイベントでは、メール検索のコンボボックスとフォームに表示されているレコードを同期させます。
cboMailType_AfterUpdate()イベントの処理
このイベントは、メール検索のコンボボックスが更新されたときに発生します。このイベントでは、コンボボックスで選択したメールタイプを検索してフォーム上に表示させます。フォームに連結されているレコードを検索するのに、レコードセットのクローンを使用しています。Set rs = Me.RecordsetCloneで、フォームのレコードセットのクローンを設定したら、FindFirstメソッドで目的のレコードを検索して、フォーム上に表示します。検索したレコードをフォームに表示させるには、Bookmarkプロパティを使用します。Me.Bookmark = .Bookmarkのように、クローンのブックマークをフォームのブックマークに設定すると、目的のレコードが表示されます。
cboSubject_NotInList()イベントの処理
このイベントは、コンボボックスの一覧に無い件名を入力したときに発生します。このイベントでは、コンボボックスに入力した件名をtblSubjectテーブルに新規登録します。MsgBoxで、“件名が件名テーブルにありません！ 登録しますか？”のメッセージを表示して、“はい”をクリックしたとき、レコードを追加します。“いいえ”をクリックしたときは、引数ResponseにacDataErrDisplay（エラーメッセージを表示することを意味する）を設定して戻ります。“はい”をクリックしたときは、OpenRecordsetメソッドで、tblSubjectを開いて、AddNew/Updateメソッドを使用してレコードを追加します。最後に、引数ResponseにacDataErrAdd（レコードを追加したことを意味する）を設定して戻ります。
cmdAttachmentPath1_Click()、
cmdAttachmentPath2_Click()、
cmdAttachmentPath3_Click()イベントの処理
これらのイベントは、フォームの添付ファイルボタンをクリックしたときに発生します。これらのイベントでは、OpenFile_FS()関数を使用してWindowsのコモンダイアログを表示させます。Windowsのコモンダイアログからは、ドライブ名、フォルダを選択して目的の添付ファイルを検索することができます。選択されたファイルのフルパス名は、テキストボックスに表示されます。
txtAttachmentPath1_BeforeUpdate()、
txtAttachmentPath2_BeforeUpdate()、
txtAttachmentPath3_BeforeUpdate()イベントの処理
これらのイベントは、テキストボックスが更新される前に発生します。これらのイベントでは、Exists()関数を呼び出して、添付ファイルが存在するか調べます。添付ファイルが存在しないときは、引数CancelにTrueを設定して入力された添付ファイルを無効とします。
cmdSubmit_Click()イベントの処理
このイベントは、フォームから送信ボタンをクリックしたときに発生します。このイベントでは、CheckRequiredFields_FS()関数を呼び出して、フォーム上の入力項目に漏れが無いか調べます。戻り値としてFalse(記入漏れ無し)/True(記入漏れ有り)のいずれかが返されます。CheckRequiredFields_FS()を使用する場合、フォーム上の必須項目のエラーメッセージプロパティ(ValidationText)に、エラーメッセージを格納しておきます。(CheckRequiredFields_FS()は、コントロールのエラーメッセージプロパティにメッセージが納されているとき、そのコントロールを必須項目と判断します。)
CheckRequiredField_FS()は、basMyLibに登録されていますので、詳細はそちらを参照してください。
フォーム上の必須項目に、入力漏れがないことを確認したら、レコードを保存してSubmitMailBCC()関数を呼び出して送信メールを作成します。SubmitMailBCC()は、リスト3-3-2を参照してください。
cmdHelp_Click()イベントの処理
このイベントは、フォームからヘルプのボタンをクリックしたときに発生します。このイベントでは、DoCmdのOpenFormメソッドでヘルプ用のフォームfrmReadMeを開きます。尚、frmReadMeを作成する手順は、省略していますので、事前に作成しておいてください。
cmdExit_Click()イベントの処理
このイベントは、フォームから閉じるのボタンをクリックしたときに発生します。このイベントでは、DoCmdのCloseメソッドで現在開かれているフォームを閉じます。
Exists()関数
この関数は、引数で指定されたファイルが実際に存在するかどうか調べます。ファイルが存在するかどうかは、DIR()関数を使用して調べます。指定したファイルが存在するときは、戻り値としてファイル名が返されます。指定したファイルが存在しないときは、長さ０の文字列が返されます。
リスト6-3-1 frmEmailのフォームモジュール
|
Option Compare Database Option Explicit Private Sub Form_Current() With cboMailType .Value = MailTypeID .Requery End With End Sub Private Sub cboMailType_AfterUpdate() Dim rs As DAO.Recordset
Set rs = Me.RecordsetClone With rs .FindFirst "[MailTypeID] = " & cboMailType If .NoMatch Then .MoveFirst End If Me.Bookmark = .Bookmark .Close End With Set rs = Nothing
End Sub Private Sub cboSubject_NotInList(NewData As String, Response As Integer) Dim strMsg As String Dim rs As DAO.Recordset strMsg = NewData & " が件名テーブルにありません！" _ & vbCrLf & "登録しますか？" If MsgBox(strMsg, vbYesNo + vbQuestion) = vbNo Then Response = acDataErrDisplay Exit Sub End If
Set rs = CurrentDb.OpenRecordset("tblSubject", dbOpenTable) With rs .AddNew !SubjectName = NewData .Update .Close End With Set rs = Nothing Response = acDataErrAdded End Sub Private Sub cmdAttachmentPath1_Click() With Me.txtAttachmentPath1 .Value = OpenFile_FS("C:\", "添付ﾌｧｲﾙ１を選択してください !") End With End Sub Private Sub cmdAttachmentPath2_Click() With Me.txtAttachmentPath2 .Value = OpenFile_FS("C:\", "添付ﾌｧｲﾙ２を選択してください !") End With End Sub Private Sub cmdAttachmentPath3_Click() With Me.txtAttachmentPath3 .Value = OpenFile_FS("C:\", "添付ﾌｧｲﾙ３を選択してください !") End With End Sub Private Sub cmdExit_Click() DoCmd.Close End Sub Private Sub cmdHelp_Click() DoCmd.OpenForm "frmReadMe" End Sub Private Sub cmdSubmit_Click() Dim fOK As Boolean If Not CheckRequiredFields_FS(Me) Then DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70 fOK = SubmitMailBCC(Me) End If End Sub Private Sub txtAttachmentPath1_BeforeUpdate(Cancel As Integer) With Me.txtAttachmentPath1 If Len(Nz(.Value)) > 0 Then If Not Exists(.Value) Then Cancel = True End If End If End With End Sub Private Sub txtAttachmentPath2_BeforeUpdate(Cancel As Integer) With Me.txtAttachmentPath2 If Len(Nz(.Value)) > 0 Then If Not Exists(.Value) Then Cancel = True End If End If End With End Sub Private Sub txtAttachmentPath3_BeforeUpdate(Cancel As Integer) With Me.txtAttachmentPath3 If Len(Nz(.Value)) > 0 Then If Not Exists(.Value) Then Cancel = True End If End If End With End Sub Private Function Exists(varFileName As Variant) As Boolean Exists = False If Len(Nz(varFileName)) > 0 Then If Len(Trim(Dir(varFileName))) > 0 Then Exists = True Else MsgBox "添付ﾌｧｲﾙ ＜" & varFileName & "＞ が見つかりません！", _ vbExclamation + vbOKOnly End If End If End Function |
SubmitMailBCC()関数
この関数は、フォームからメール送信ボタンをクリックしたときに呼ばれます。この関数では、フォームで指定された宛先用のクエリを開いて、送信メールを作成します。Outlook では、宛先を、TO,CC,BCCの３種類の方法で指定することができます。この関数では、送信メールの作成処理を高速化するために、BCC指定で複数のメールアドレスを指定する方法を採用しています。メールの送信は、BCCの宛先の長さが２０００（約１００人分）になった時点でOutlookの送信トレイに登録します。メールの送信時間は、宛先にTOを使用した場合と比較して、１００分１に短縮されます。
この関数では、フォームからメール送信情報を取得するのに、フォームのレコードセットクローンを使用しています。Set rsMailType = frm.RecordsetCloneで、レコードセットのクローンを取得したら、.Bookmark = frm.Bookmarkでクローンのレコードをフォーム上のレコードと同期させます。クローンのレコードを同期させたら、レコードセットからクエリ名称、件名、本文、添付ファイルを取得してメモリ変数に退避します。本文は、メモ型のフィールドに格納されていますので、GetChunk()メソッドを使用して取得します。
Set rsMailType = frm.RecordsetClone
With rsMailType
.Bookmark = frm.Bookmark
strQueryName = Trim(!QueryName)
strSubject = Trim(!Subject)
lngSize = !Body.FieldSize
strBody = !Body.GetChunk(0,
lngSize)
strAttachmentPath1 =
Nz(!AttachmentPath1)
strAttachmentPath2 =
Nz(!AttachmentPath2)
strAttachmentPath3 =
Nz(!AttachmentPath3)
.Close
End With
Set rsMailType = Nothing
OpenRecordset()メソッドで宛先のクエリを開いたら、Outlook のインスタンスを生成します。GetObject(, "Outlook.Application")で、Outlook が既に起動されているか調べます。Outlook が起動されていないときは、CreateObject("Outlook.Application")でインスタンスを生成します。
fOutlookIsRunning = True
Set mobjOutlook = GetObject(,
"Outlook.Application")
If mobjOutlook Is Nothing Then
Set mobjOutlook =
CreateObject("Outlook.Application")
If mobjOutlook Is Nothing Then
MsgBox "MS Outlook
9.0 is not installed on your computer"
Exit Function
End If
fOutlookIsRunning = False
End If
Do Until .EOF…Loopでは、宛先用のレコードセットを先頭から順番に読み込んで、宛先(BCC)を作成します。宛先の長さが２０００を超えたら、SendMailを呼び出して送信メールをOutlook 2000に登録します。
SendMail()
このプロシージャは、Outlook のメールアイテムオブジェクトを作成して、Outlook の送信トレイに送信メールを登録します。OutlookオブジェクトのCreateItemメソッドでメールアイテムオブジェクトを作成したら、BCC、Subject, Bodyプロパティに値を設定します。本文をHTML形式で送信するときは、HTMLBodyプロパティをTrueに設定します。添付ファイルは、Attachments.Addで追加します。最後に、Importanceプロパティに重要度(olImportanceHigh)を設定したら、Sendメソッドでメールを送信トレイに登録します。送信トレイに登録されたメールは、Outlook から送信ボタンをクリックしたときに送信されます。
リスト6-3-2 basAutomationモジュール
|
Option Compare Database Option Explicit Private mobjOutlook As Outlook.Application Public Function SubmitMailBCC(frm As Form) As Boolean Dim fOutlookIsRunning As Boolean
Dim db As DAO.Database Dim rsEmailAddr As DAO.Recordset ' tblEmailAddr Dim rsMailType As DAO.Recordset ' tblMailType
Dim strQueryName As String Dim strSubject As String Dim lngSize As Long Dim strBody As String Dim strAttachmentPath1 As String Dim strAttachmentPath2 As String Dim strAttachmentPath3 As String Dim varRC As Variant
Dim intCnt As Integer Dim strBCC As String
On Error GoTo Err_SubmitMail DoCmd.Hourglass (True)
' ﾌｫｰﾑ上に表示されている情報をﾒﾓﾘ変数に退避する Set rsMailType = frm.RecordsetClone With rsMailType .Bookmark = frm.Bookmark strQueryName = Trim(!QueryName) strSubject = Trim(!Subject) lngSize = !Body.FieldSize strBody = !Body.GetChunk(0, lngSize) strAttachmentPath1 = Nz(!AttachmentPath1) strAttachmentPath2 = Nz(!AttachmentPath2) strAttachmentPath3 = Nz(!AttachmentPath3) .Close End With Set rsMailType = Nothing
Set rsEmailAddr = CurrentDb.OpenRecordset(strQueryName, dbOpenSnapshot) With rsEmailAddr If .BOF And .EOF Then MsgBox "宛名のｸｴﾘｰに該当するﾚｺｰﾄﾞがありません！" GoTo Exit_SubmitMail End If End With
' Outlook 2000のｲﾝｽﾀﾝｽを生成する(既にｲﾝｽﾀﾝｽが生成されているときは再使用する) On Error Resume Next fOutlookIsRunning = True Set mobjOutlook = GetObject(, "Outlook.Application") If mobjOutlook Is Nothing Then Set mobjOutlook = CreateObject("Outlook.Application") If mobjOutlook Is Nothing Then MsgBox "MS Outlook 9.0 is not installed on your computer" Exit Function End If fOutlookIsRunning = False End If
On Error GoTo Err_SubmitMail
With rsEmailAddr intCnt = 0 .MoveFirst varRC = SysCmd(acSysCmdInitMeter, "送信中です...", 100) Do Until .EOF varRC = SysCmd(acSysCmdUpdateMeter, .PercentPosition) intCnt = intCnt + 1 strBCC = strBCC & !Email & ";" If Len(strBCC) > 2000 Then strBCC = Left(strBCC, Len(strBCC) - 1) ' strip last ; Call SendMail(strBCC, strSubject, strBody, _ strAttachmentPath1, strAttachmentPath2, strAttachmentPath3, _ frm.chkHTML) strBCC = vbNullString End If .MoveNext Loop If Len(strBCC) Then strBCC = Left(strBCC, Len(strBCC) - 1) ' strip last ; Call SendMail(strBCC, strSubject, strBody, _ strAttachmentPath1, strAttachmentPath2, strAttachmentPath3, _ frm.chkHTML) End If
varRC = SysCmd(acSysCmdRemoveMeter) MsgBox intCnt & " 件のﾒｰﾙが作成されました！" & vbCrLf & vbCrLf _ & "Outlook 2000を起動して送信ボタンをクリックしてください..." .Close End With Set rsEmailAddr = Nothing
Exit_SubmitMail: On Error Resume Next DoCmd.Hourglass (False)
If Not rsMailType Is Nothing Then rsMailType.Close Set rsMailType = Nothing End If
If Not rsEmailAddr Is Nothing Then rsEmailAddr.Close Set rsEmailAddr = Nothing End If
If Not mobjOutlook Is Nothing Then If Not fOutlookIsRunning Then mobjOutlook.Quit End If Set mobjOutlook = Nothing End If
Exit Function Err_SubmitMail: MsgBox Err.Description, vbInformation + vbOKOnly, Err.Number Resume Exit_SubmitMail
End Function Private Sub SendMail(strBCC As String, strSubject As String, strBody As String, _ strAttachment1 As String, _ strAttachment2 As String, _ strAttachment3 As String, _ Optional fHTML As Boolean = False)
Dim objMailItem As Object
Set objMailItem = mobjOutlook.CreateItem(olMailItem) With objMailItem .BCC = strBCC .Subject = strSubject If fHTML Then .HTMLBody = strBody Else .Body = strBody & vbCrLf & vbCrLf End If If Len(strAttachment1) Then .Attachments.Add strAttachment1 End If If Len(strAttachment2) Then .Attachments.Add strAttachment2 End If If Len(strAttachment3) Then .Attachments.Add strAttachment3 End If .Importance = olImportanceHigh .Send End With Set objMailItem = Nothing End Sub |
Tip
|
フォーム上の必須項目に入力漏れが無いか調べるには： CheckRequiredFields_FS()関数を使用すると、フォーム上の必須項目に入力漏れがないか簡単に調べることができます。この関数は、汎用化されていますので引数にフォームを指定するだけで、どのフォームからでも呼び出すことができます。この関数を使用するときは、必須項目のコントロールのエラーメッセージ（ValidationText）プロパティに、未入力時のエラーメッセージを格納しておきます。 例えば、フォームの氏名のテキストボックスが必須項目のとき、エラーメッセージプロパティに“氏名を入力してください！”のように未入力時に表示されるエラーメッセージを格納します。 フォームから関数を呼び出すには、CheckRequiredFields_FS(Me)のように引数に対象となるフォームを指定します。 CheckRequiredFields_FS()関数は、エラーを検出したとき、エラーメッセージプロパティに格納されているメッセージを表示してフォーカスをそのフィールドに移動します。この関数は、１回の呼び出しで１個のエラーしか検出しませんが、
If Len(Trim(Nz(.Value))) = 0 Then
MsgBox .ValidationText, vbExclamation + vbOKOnly
.SetFocus
CheckRequiredFields_FS = True
Exit For
End If の部分を変更してメモリ変数にエラーメッセージを格納するようにすれば、複数のエラーを検出することもできます。 １回の呼び出しで１個のエラーを検出する関数： Public Function CheckRequiredFields_FS(frm As Form) As Boolean Dim ctl As Control CheckRequiredFields_FS =
False With frm For Each ctl In
.Section(acDetail).Controls
With ctl
Select Case .ControlType
Case acTextBox, acComboBox
If Len(Trim(Nz(.ValidationText))) > 0 Then
If Len(Trim(Nz(.Value))) = 0 Then
MsgBox .ValidationText, vbExclamation + vbOKOnly
.SetFocus
CheckRequiredFields_FS = True
Exit For
End If
End If
End Select
End With Next ctl End With End Function １回の呼び出しで複数のエラーを検出する関数： Public Function CheckRequiredFields2_FS(frm As Form) As Boolean Dim ctl As Control Dim strMsg As String CheckRequiredFields2_FS =
False With frm For Each ctl In
.Section(acDetail).Controls
With ctl
Select Case .ControlType
Case acTextBox, acComboBox
If Len(Trim(Nz(.ValidationText))) > 0 Then
If Len(Trim(Nz(.Value))) = 0 Then
If Len(strMsg) = 0 Then
.SetFocus
End If strMsg = strMsg & .ValidationText &
vbNewLine
CheckRequiredFields2_FS = True
End If
End If
End Select
End With Next ctl If Len(strMsg)
Then
MsgBox strMsg, vbExclamation + vbOKOnly End If End With End Function |