マクロ上でデータファイルを添付してメールを自動送信するプロシージャをモジュールでインポートして利用できるものを用意しました。
※このメール送信は、Outlook Expressなどの標準メールソフトを経由せず、BASP21というフリーの外部コンポーネントを使用して送信します。
Excelには元々、「SendMail」メソッドが用意されていました。何が違うのでしょう。
| 項 目 | SendMailメソッド | BASP21コンポーネント |
| 本文作成 | 不可 | 可能 |
| メールソフトの互換性 | Outlook以外では困難。 バージョンにより動作が違う。 |
メールソフトに依存しない |
| 本文のみ送信 | 自ブック添付が前提なので不可。 | 可能 |
| 複数ファイル添付 | 自ブック添付が前提なので不可。 | 可能 |
| 確認メッセージ | 必須 (SendKeysなどでの回避はバージョン非互換) |
原則なし(必要なら、そのように記述するだけ) |
| 宛先 | 配列指定で複数可能 | 宛先、CC、BCCそれぞれ複数指定可能 |
| 送信ログ | 送信済トレイに残る | メールソフトを経由しないので、原則残らない。(BCC等で代用できる) |
| インストール | 元々の標準メールソフトを利用するため、インストール不要。 | コンポーネントのインストールが必要。 (但し、フリーソフトで再起動等不要) |
これらのことから、Excelでのメールの操作についてはBASP21のような外部コンポーネントを使う方法の方が安定動作すると考えています。
これ以外に、コンポーネントのインストール不要なCDOによるメール送信の方法があります。これはWindows2000以降に限定され、またBASP21と違って受信はできないようです。
このCDOによるメール送信は「VBA応用」のページに用意しています。
さらに、このサンプルでは以下の機能を追加の機能を追加してあります。
| 項 目 | 内 容 |
| 添付ファイルの圧縮 | UnLHA32.dllを併用することで、添付ファイルをLHA形式に圧縮して添付することができます。この時、添付ファイルが複数ある場合は、１つの圧縮ファイルに収容されます。 圧縮ファイルはフォルダごと指定できますが、フォルダの指定を省略すると、WindowsのTEMP指定のフォルダに出力されます。 ※圧縮する対象にフォルダを指定することができますが、この場合、複数のフォルダは指定できません。 |
| ファイル圧縮後の処置 | 圧縮ファイルの送信後は、その圧縮ファイルを削除するか、圧縮元となったファイルを削除するか、何も削除しないか選択できます。 |
| 宛先や添付ファイルの 複数指定 |
宛先、CC、BCC等は配列で引き渡すことで複数を指定できますが、１次配列変数の他、縦方向のセル範囲を直接指定することも可能としました。 サンプルでもこの方法を採っています。範囲指定内に空白セルがある場合は対象から除外されます。 |
| 自動ダイアルアップ送信 | ネットワークにダイアルアップ接続する設定になっているPCで利用される場合は、ダイアルアップ登録名を指定するだけで自動的にダイアルアップして送信します。 送信完了後は自動的にダイアルアップ接続を切断します。 |
| 送信者の BCC自動登録 |
コンポーネントでのメール送信は、メールソフトを操作しないため、「送ったかどうか」について完了メッセージかログファイルを参照しないと判りません。 このため、元プログラムで操作しなくても、送信時に送信者をBCCに加える機能を用意してあります。 |
サンプルは、宛先や添付ファイルをシート上に設定しておいて、「メール送信」で送信を行なうものです。「API関連」でサンプルを提示していますが、こちらの方が転用利用が簡単にできるようにしてあります。但し、「API関連」の方は「CreateObject」でハンドリングしているのに対し、こちらではFunctionのCallで呼んでいます。このため、「BASP21」の中で「BSMTP.dll」のみSYSTEMフォルダにコピーしてあれば動作します。
(この画像をクリックすると、ダウンロードができます。)
※実際にメールの設定を行なってから、送信させて下さい。当初はダミーの値を登録してあります。
ダウンロードしたままでは「テストモード」となっており、そのまま「メール送信」ボタンをクリックしても送信は行なわれずに下記メッセージが表示されます。
メール送信に必要な設定をこのメッセージで確認の上、問題なく送信ができる状態と判断されたら、一番最後に説明しているコンパイルスイッチの変更を行なって下さい。
なお、設定が正しいかは、当初自分自身のメールアドレスを宛先に登録するなどして確認して下さい。
※本機能には「BASP21」コンポーネント(フリーソフト)が必要です。
宛先、CC、BCCは、画面右側に必要数登録して下さい。
添付ファイルの登録は、シート右下の「添付ファイル」の項目を選択した状態で「添付ファイルの参照登録」をクリックして下さい。「ファイルを開く」のダイアログで登録ができます。添付ファイルは５件まで登録できるようにしてあります。(ワイルドカードの記述の可能です。)
また、「添付ファイル」の下の「圧縮ファイル名」に任意のファイル名(フォルダ指定不要)を入力すると、指定した添付ファイルを１つの圧縮ファイル(LHA形式)に圧縮して送信します。
※この圧縮ファイルの指定には、「UNLHA32」コンポーネント(フリーソフト)が必要です。
※通常、メールにフォルダを添付することはできませんが、フォルダごと圧縮ファイルに納めて添付することは可能です。
本モジュールも「添付ファイル」にフォルダ名を指定して「圧縮ファイル名」を指定することでそのフォルダをルートフォルダとした配下全てのサブフォルダ、ファイルをフォルダ構成のまま添付させることが可能です。
なお、現在の仕様では、フォルダを圧縮させる場合に圧縮ファイルを「EXE」形式にしてしまうとフォルダ構成が解除されて圧縮されます。
「メール送信」で送信が完了すると、メッセージが表示されます。
※エラーが発生した場合は、エラーメッセージが表示されます。
ダウンロードしたファイルを解凍すると、上記のサンプルのExcelワークブックと「modSendMailByBASP21.bas」が作成されます。この「modSendMailByBASP21.bas」を他にメール送信を行ないたいExcelの仕組みを持つワークブックのVBEにインポートして「SendMailByBASP21」のFunctionプロシージャを呼び出すことで利用できます。
汎用化させているため、引数が多くなっています。動作確認を確実に行なってからご利用下さい。
(このサンプルはModule1に記述されています。)
'*******************************************************************************
' メール送信処理
'*******************************************************************************
Option Explicit
Private Const cnsTitle As String = "メール送信処理"
'*******************************************************************************
' メール送信処理
'*******************************************************************************
Sub SEND_MAIL()
Dim xlAPP As Application
Dim GYOMAX(1 To 4) As Long
Dim IX As Long
Dim swOwnerBCC As Boolean
Dim intDelMode As Integer
Dim MSG As String
Dim FF As Integer
Dim strFileName As String
Dim strMessage As String
Set xlAPP = Application
With ActiveSheet
' 宛先各項目の最終行判定→GYOMAX1,2,3
GYOMAX(1) = .Range("$J$65536").End(xlUp).Row ' 宛先
GYOMAX(2) = .Range("$L$65536").End(xlUp).Row ' CC
GYOMAX(3) = .Range("$N$65536").End(xlUp).Row ' BCC
' 未登録対処として最低1件は登録されたものとする(ブランクは送信処理側で対応)
For IX = 1 To 3
If GYOMAX(IX) < 3 Then GYOMAX(IX) = 3
Next IX
' 添付ファイル最終行判定
GYOMAX(4) = .Range("$B$32:$C$32").End(xlUp).Row' 添付ファイル
If GYOMAX(4) < 27 Then GYOMAX(4) = 27
If .Cells(33, 2).Value = "送信者をBCCに加える" Then swOwnerBCC = True
If .Cells(34, 2).Value <> "" Then intDelMode = CInt(Left$(.Cells(34, 2).Value, 1))
' 本文の編集(セル内改行でLF→CRLF変換、署名を接合)
strMessage = Replace(.Cells(11, 2).Value, vbLf, vbCrLf) & vbCrLf & _
Replace(.Cells(22, 2).Value, vbLf, vbCrLf)
'-----------------------------------------------------------------------
' ■Eメール送信の呼出し(modSendMailByBASP21)
' [引数]
' strDialUp : ダイアルアップ登録名(ダイアルアップしない時はブランク)
' strDomain : ドメイン名(xxxx.co.jp等)
' strSMTP : SMTPサーバ名(smtp.xxxx.co.jp,mail.xxxx.co.jp等)
' strPort : 通常は「25」,ブランクの場合は「25」
' strTimeOut : 「60」位が適当,ブランクの場合は「60」
' strFromName : 送信元名称
' strFromAddr : 送信元アドレス
' vntToName : 宛先名称(複数の場合は配列をセットする)
' vntToAddr : 宛先アドレス(複数の場合は配列をセットする,配列要素数は宛先名称と一致させる)
' vntCCName : CC宛先名称(複数の場合は配列をセットする)
' vntCCAddr : CC宛先アドレス(複数の場合は配列をセットする,配列要素数はCC名と一致させる)
' vntBCCName : BCC宛先名称(複数の場合は配列をセットする)
' vntBCCAddr : BCC宛先アドレス(複数の場合は配列をセットする,配列要素数はBCC名と一致させる)
' swOwnerBCC : Trueの場合、送信元アドレスをBCCに加える
' strSubj : 件名
' strMessage : 本文(署名も付加してセット)
' strCaption : 親ウィンドウのCaption
' vntFileName : フルパス添付ファイル名(複数の場合は配列をセットする) ※ない場合はブランク
' strLzhFile : 上記添付ファイルを圧縮する場合はその圧縮ファイル名(パス名不要)
' intDelMode : 圧縮時の削除方法(0=削除なし, 1=圧縮ファイルを削除, 2=元ファイルを削除)
' [戻り値]
' "OK"=成功, それ以外はエラーメッセージ
If GYOMAX(4) > 27 Then
' 添付ファイルが複数の場合
MSG = SendMailByBASP21(.Cells(3, 2).Value, _
.Cells(4, 2).Value, _
.Cells(5, 2).Value, _
.Cells(6, 2).Value, _
.Cells(7, 2).Value, _
.Cells(8, 2).Value, _
.Cells(9, 2).Value, _
.Range("$I$3:$I$" & GYOMAX(1)).Value, _
.Range("$J$3:$J$" & GYOMAX(1)).Value, _
.Range("$K$3:$K$" & GYOMAX(2)).Value, _
.Range("$L$3:$L$" & GYOMAX(2)).Value, _
.Range("$M$3:$M$" & GYOMAX(3)).Value, _
.Range("$N$3:$N$" & GYOMAX(3)).Value, _
swOwnerBCC, _
.Cells(10, 2).Value, _
strMessage, _
xlAPP.Caption, _
.Range("$B$27:$H$" & GYOMAX(4)).Value, _
.Cells(32, 2).Value, intDelMode)
Else
' 添付ファイルが単一の場合(フォルダ対応)
MSG = SendMailByBASP21(.Cells(3, 2).Value, _
.Cells(4, 2).Value, _
.Cells(5, 2).Value, _
.Cells(6, 2).Value, _
.Cells(7, 2).Value, _
.Cells(8, 2).Value, _
.Cells(9, 2).Value, _
.Range("$I$3:$I$" & GYOMAX(1)).Value, _
.Range("$J$3:$J$" & GYOMAX(1)).Value, _
.Range("$K$3:$K$" & GYOMAX(2)).Value, _
.Range("$L$3:$L$" & GYOMAX(2)).Value, _
.Range("$M$3:$M$" & GYOMAX(3)).Value, _
.Range("$N$3:$N$" & GYOMAX(3)).Value, _
swOwnerBCC, _
.Cells(10, 2).Value, _
strMessage, _
xlAPP.Caption, _
.Cells(27, 2).Value, _
.Cells(32, 2).Value, intDelMode)
End If
'-----------------------------------------------------------------------
End With
' LOG書出し
strFileName = ThisWorkbook.Path & "\" & _
Left$(ThisWorkbook.Name, (Len(ThisWorkbook.Name) - 3)) & "log"
FF = FreeFile
Open strFileName For Append As #FF
Print #FF, Format$(Now, "YY/MM/DD hh:mm:ss") & " " & MSG
Close #FF
If MSG <> "OK" Then
MsgBox MSG, vbExclamation
Else
MsgBox "メール送信が完了しました。", vbInformation
End If
End Sub
'*******************************************************************************
' 添付ファイル登録処理
'*******************************************************************************
Sub GET_FILENAME()
Dim xlAPP As Application
Dim strFileName As String
Dim GYO As Long
Set xlAPP = Application
GYO = ActiveCell.Row
If ((ActiveCell.Column <> 2) Or (GYO < 26) Or (GYO > 30)) Then Exit Sub
strFileName = xlAPP.GetOpenFilename("全てのファイル (*.*),*.*",, _
"メール添付するファイルの登録")
If StrConv(strFileName, vbUpperCase) = "FALSE" Then Exit Sub
Cells(GYO, 2).Value = strFileName
End Sub
'-----------------------------<< End of Source >>-------------------------------
| 01 | strDialUp | ダイアルアップ回線を使用している場合のみ、ダイアルアップの登録名を登録します。サンプルではブランク("")固定としています。 |
| 02 | strDomain | ドメイン名を登録します。通常はメールアドレスの「@」の右側です。 |
| 03 | strSMTP | SMTPサーバ名を登録します。(DNSで名前解決できることが送信の前提です。) |
| 04 | strPort | ポート番号を登録します。ブランク("")にすると「25」として動作します。 |
| 05 | strTimeOut | タイムアウト秒数を登録します。ブランク("")にすると「60」として動作します。 |
| 06 | strFromName | 送信者の氏名等を登録します。日本語名でも構いません。ブランク("")可。 |
| 07 | strFromAddr | 送信者のメールアドレスを登録します。 |
| 08 | vntToName | 宛先の氏名等を登録します。複数の宛先の場合は配列を登録します。サンプルでは１件の登録でも配列を使用しています。(単純文字列、又は１次配列、又は２次元目を１固定とした２次配列で引き渡せるので縦方向１列のセル範囲を直接指定できます。) |
| 09 | vntToAddr | 宛先のメールアドレスを登録します。複数の宛先の場合は配列を登録します。配列の要素の数は「vntToName」と同じでなければなりません。(単純文字列、又は１次配列、又は２次元目を１固定とした２次配列で引き渡せるので縦方向１列のセル範囲を直接指定できます。) |
| 10 | vntCCName | CCの宛先の氏名等を登録します。登録方法は「vntToName」と同じです。(単純文字列、又は１次配列、又は２次元目を１固定とした２次配列で引き渡せるので縦方向１列のセル範囲を直接指定できます。) |
| 11 | vntCCAddr | CCの宛先のメールアドレスを登録します。登録方法は「vntToAddr」と同じです。(単純文字列、又は１次配列、又は２次元目を１固定とした２次配列で引き渡せるので縦方向１列のセル範囲を直接指定できます。) |
| 12 | vntBCCName | BCCの宛先の氏名等を登録します。登録方法は「vntToName」と同じです。(単純文字列、又は１次配列、又は２次元目を１固定とした２次配列で引き渡せるので縦方向１列のセル範囲を直接指定できます。) |
| 13 | vntBCCAddr | BCCの宛先のメールアドレスを登録します。登録方法は「vntToAddr」と同じです。(単純文字列、又は１次配列、又は２次元目を１固定とした２次配列で引き渡せるので縦方向１列のセル範囲を直接指定できます。) |
| 14 | swOwnerBCC | 送信者をBCCに加える場合はTrue、不要であればFalseを登録します。本機能はメールソフトを経由する機能ではないので送信履歴が残りません。この設定をTrueにしておけば自分をBCC宛にして送信されるので、メールソフトで受信して送信の確認ができます。 |
| 15 | strSubj | 件名を登録します。 |
| 16 | strMessage | メールの文面を署名まで含めて登録します。 |
| 17 | strCaption | ダイアルアップ動作やファイル圧縮で別ウィンドウが表示されるため、制御を正しく戻せるようにウィンドウハンドルを引き渡すためのウィンドウ名をセットします。ユーザーフォーム上から呼び出す場合は必須ですが、シート上で呼ぶ場合はブランクでも構いません。 |
| 18 | vntFileName | 添付ファイル名をフルパスで登録します。複数の場合は配列を登録します。添付ファイルを使用しない場合は省略できます。ファイル名の存在は呼び元の処理で確認して下さい。(単純文字列、又は１次配列、又は２次元目を１固定とした２次配列で引き渡せるので縦方向１列のセル範囲を直接指定できます。)また、「*」や「?」を使うワイルドカードも指定できます。 |
| 19 | strLzhFile | 添付ファイルを圧縮する場合は、圧縮ファイルのファイル名を登録します。この時フォルダは表意しないファイル名とします。添付ファイルが複数登録されている場合は、１つの圧縮ファイルに収容されます。拡張子は「LZH」か「EXE」で「EXE」の場合は自動解凍書庫形式となります。拡張子を省略すると「LZH」として処理されます。ブランク("")もしくは省略した場合は圧縮は行なわれません。 フォルダを指定せずに記述することができ、この場合はWindowsのTEMP指定のフォルダに出力されます。 |
| 20 | intDelMode | 添付ファイルの圧縮時の後処理を指定できます。 0=削除動作なし 1=圧縮したファイルを削除する。 2=圧縮ファイルを残し、圧縮元の添付ファイルを削除する。 |
strCaption以降は不要な場合、引数の記述を省略することが出来ます。
但し、引数の並び順の上で、手前を省略して後を指定することはできません。このような場合は省略する引数の値は「""」として下さい。
- ダウンロードした状態では、正しい設定が行なわれていませんから、そのまま送信はできません。
この状態での誤操作を避けるため、初期の送信記述部分はメッセージ表示にしてあります。
引数などのテストが完了した段階で、「modSendMailByBASP21.bas」のこの部分(赤矢印の先)の「0」を「1」に変更した上でワークブックを上書き保存してからご利用下さい。
送信部分の記述説明などは、「メール送受信、添付ファイルの処理」でも説明しています。
また、コンポーネントのインストール不要なCDOによるメール送信は「VBA応用」のページに用意しています。 - ※よくあるエラーメッセージを紹介しておきます。(これ以外にも多種あります))
BASP21がインストールされていない(BSMTP.dllがシステムフォルダに存在しない)と以下のエラーが表示されます。
メールサーバの設定が正しくないと以下のエラーが表示されます。
宛先などのメールアドレスが正しくない("@"がない等)と以下のエラーが表示されます。
'*******************************************************************************
' Eメール送信機能 ※BSMTP.dll(BASP21),UNLHA32.dll必須
'
' 作成者:井上治 URL:http://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'*******************************************************************************
Option Explicit
'**********↓↓↓実際に送信を行なう段階でこの値を「1」に変更して下さい↓↓↓
#Const cnsSW_TEST = 0 ' テスト中(=0)
'#Const cnsSW_TEST = 1 ' 本番(=1)
'**********↑↑↑実際に送信を行なう段階でこの値を「1」に変更して下さい↑↑↑
Private Const INTERNET_AUTODIAL_FORCE_ONLINE = 1
Private Const INTERNET_AUTODIAL_FORCE_UNATTENDED = 2
Private Const INTERNET_DIAL_UNATTENDED = &H8000
Private Const INTERNET_AUTODIAL_FAILIFSECURITYCHECK = 4
Private Const g_cnsNG = "NG"
Private Const g_cnsOK = "OK"
Private Const g_cnsYen = "\"
Private Const g_cnsLZH = ".lzh"
Private Const g_cnsERRMSG1 = "が正しくありません。"
Private Const g_cnsCNT1 = 3 ' 格納テーブル1次元目の要素数(固定)
Private Const MAX_PATH = 260
' メール送信API(BASP21)
Private Declare Function SendMail Lib "BSMTP.dll" _
(szServer As String, szTo As String, szFrom As String, _
szSubject As String, szBody As String, szFile As String) As String
' LHA圧縮を操作するAPI(UNLHA32)
Private Declare Function Unlha Lib "UNLHA32.dll" _
(ByVal lhWnd As Long, ByVal szCmdLine As String, _
ByVal szOutPut As String, ByVal wSize As Long) As Long
' ダイアルアップエントリーを指定して接続(IE4以上必須)
Private Declare Function InternetDial Lib "WININET.dll" _
(ByVal hwndParent As Long, ByVal lpszConnectoid As String, _
ByVal dwFlags As Long, lpdwConnection As Long, _
ByVal dwReserved As Long) As Long
' ダイアルアップIDを指定して切断
Private Declare Function InternetHangUp Lib "WININET.dll" _
(ByVal dwConnection As Long, ByVal dwReserved As Long) As Long
' ウィンドゥハンドルを返す
Private Declare Function FindWindow Lib "USER32.dll" _
Alias "FindWindowA" (ByVal lpClassName As Any, _
ByVal lpWindowName As Any) As Long
' Sleep
Private Declare Sub Sleep Lib "KERNEL32.dll" _
(ByVal dwMilliseconds As Long)
' SYSTEMディレクトリ名取得API
Private Declare Function GetSystemDirectory Lib "KERNEL32.dll" _
Alias "GetSystemDirectoryA" _
(ByVal lpBuffer As String, ByVal nSize As Long) As Long
' WindowsのTEMPフォルダ取得
Private Declare Function GetTempPath Lib "KERNEL32.dll" _
Alias "GetTempPathA" _
(ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
'*******************************************************************************
' Eメール送信機能(BSMTP.dll必須)
'*******************************************************************************
' [引数]
' strDialUp : ダイアルアップ登録名(ダイアルアップしない時はブランク)
' strDomain : ドメイン名(xxxx.co.jp等)
' strSMTP : SMTPサーバ名(smtp.xxxx.co.jp,mail.xxxx.co.jp等)
' strPort : 通常は「25」,ブランクの場合は「25」
' strTimeOut : 「60」位が適当,ブランクの場合は「60」
' strFromName : 送信元名称
' strFromAddr : 送信元アドレス
' vntToName : 宛先名称(複数の場合は配列)
' vntToAddr : 宛先アドレス(複数の場合は配列,配列要素数は宛先名称と要一致)
' vntCCName : CC宛先名称(複数の場合は配列)
' vntCCAddr : CC宛先アドレス(複数の場合は配列,配列要素数はCC名と要一致)
' vntBCCName : BCC宛先名称(複数の場合は配列)
' vntBCCAddr : BCC宛先アドレス(複数の場合は配列,配列要素数はBCC名と要一致)
' swOwnerBCC : Trueの場合、送信元アドレスをBCCに加える
' strSubj : 件名
' strMessage : 本文(署名も付加してセット)
' strCaption : 親ウィンドウのCaption
' vntFileName : フルパス添付ファイル名(複数の場合は配列) ※ない場合はブランク
' strLzhFile : 上記添付ファイルを圧縮する場合はその圧縮ファイル名(パス名不要)
' intDelMode : 圧縮時の削除方法(0=削除なし, 1=圧縮ファイルを削除, 2=元ファイルを削除)
' [戻り値]
' "OK"=成功, それ以外はエラーメッセージ
'*******************************************************************************
Public Function SendMailByBASP21(strDialUp As String, _
strDomain As String, _
strSMTP As String, _
strPort As String, _
strTimeOut As String, _
strFromName As String, _
strFromAddr As String, _
vntToName As Variant, _
vntToAddr As Variant, _
vntCCName As Variant, _
vntCCAddr As Variant, _
vntBCCName As Variant, _
vntBCCAddr As Variant, _
swOwnerBCC As Boolean, _
strSubj As String, _
strMessage As String, _
Optional strCaption As String, _
Optional vntFileName As Variant, _
Optional strLzhFile As String, _
Optional intDelMode As Integer) As String
Dim xlAPP As Application
Dim strDIAL_ENTRY As String ' ダイアルアップエントリー
Dim strSV_Name As String ' ドメイン/SMTP:ポート:タイムアウト
Dim strMailFrom As String ' 送信元登録
Dim strMailto As String ' 送信先登録
Dim strTable() As String ' 配列値格納テーブル
Dim MAX2 As Integer ' テーブルに格納した要素数(2次元目最大値)
Dim CNT2() As Integer ' テーブルに格納した要素数(2次元目各要素)
Dim vntName As Variant ' 宛先名Work
Dim vntAddr As Variant ' アドレスWork
Dim strPathName As String ' 添付ファイルのフォルダ名
Dim strFileName As String ' 添付ファイル
Dim swLine As Byte ' ダイアル接続スイッチ
Dim hWnd As Long ' ウィンドウハンドル
Dim lngConnID As Long ' コネクションコード
Dim IX As Long ' テーブルIndex
Dim IX1 As Long ' テーブルIndex
Dim IX2 As Long ' テーブルIndex
Dim IX3 As Long ' テーブルIndex
Dim lngRet As Long ' リターンコード
Dim strRC As String ' BASP21戻り値
Dim strMSG As String ' メッセージ
Dim vntMSG As Variant ' メッセージWork
Dim strName As String ' Work
Dim strAddr As String ' Work
SendMailByBASP21 = g_cnsNG
Set xlAPP = Application
' BSMTP.dllの存在確認
If Dir(FP_GET_SYSTEM_PATH & "BSMTP.dll", vbNormal) = "" Then
SendMailByBASP21 = _
"送信コンポーネント「BSMTP.dll」がインストールされていません。"
Exit Function
End If
'-------------------------------------------------------------------------------
' ■準備処理(引き渡しパラメータの作成)
' ドメイン/SMTP:ポート:タイムアウト
If Trim$(strPort) = "" Then strPort = "25"
If Trim$(strTimeOut) = "" Then strTimeOut = "60"
strSV_Name = Trim$(strDomain) & "/" & _
Trim$(strSMTP) & ":" & _
Trim$(strPort) & ":" & _
Trim$(strTimeOut)
' Variant項目未使用の場合の対応
If IsError(vntToName) Then vntToName = ""
If IsError(vntToAddr) Then vntToAddr = ""
If IsError(vntCCName) Then vntCCName = ""
If IsError(vntCCAddr) Then vntCCAddr = ""
If IsError(vntBCCName) Then vntBCCName = ""
If IsError(vntBCCAddr) Then vntBCCAddr = ""
If IsError(vntFileName) Then vntFileName = ""
' 送信元登録
If Trim$(strFromAddr) = "" Then
SendMailByBASP21 = "送信元のメールアドレスがありません"
Exit Function
End If
If Trim$(strFromName) = "" Then
strMailFrom = Trim$(strFromAddr)
Else
strMailFrom = Trim$(strFromName) & _
"<" & Trim$(strFromAddr) & ">"
End If
' 配列で引き渡される可能性がある項目を全て別テーブルに格納し直す
' (以後は全て配列の文字列変数として処理できる)
MAX2 = 0
ReDim strTable(g_cnsCNT1, MAX2)
ReDim CNT2(g_cnsCNT1)
vntMSG = Array("宛先", "CC宛先", "BCC宛先", "添付ファイル名")
For IX1 = 0 To g_cnsCNT1
Select Case IX1
Case 0: vntName = vntToName: vntAddr = vntToAddr ' 宛先
Case 1: vntName = vntCCName: vntAddr = vntCCAddr ' CC
Case 2: vntName = vntBCCName: vntAddr = vntBCCAddr ' BCC
Case 3: vntName = vntFileName: vntAddr = vntFileName ' 添付ファイル
End Select
IX3 = 0
If IsArray(vntAddr) = True Then
' 格納テーブルに配列を格納
For IX2 = LBound(vntAddr) To UBound(vntAddr)
On Error GoTo MakeArray_ARRAY2
strAddr = Trim$(vntAddr(IX2))
If ((IX1 < g_cnsCNT1) And (IX2 <= UBound(vntName))) Then
On Error GoTo MakeArray_ARRAY3
strName = Trim$(vntName(IX2))
Else
strName = ""
End If
GoSub MakeArray_SUB
Next IX2
Else
If IX1 < g_cnsCNT1 Then
strName = Trim$(vntName)
Else
strName = ""
End If
strAddr = Trim$(vntAddr)
GoSub MakeArray_SUB
End If
CNT2(IX1) = IX3
Next IX1
If CNT2(0) < 1 Then
SendMailByBASP21 = "宛先のメールアドレスがありません"
Exit Function
End If
' 送信者をBCCに追加指定の処理(swOwnerBCC指定の場合)
If swOwnerBCC = True Then
CNT2(2) = CNT2(2) + 1
If CNT2(2) > MAX2 Then
MAX2 = CNT2(2)
ReDim Preserve strTable(g_cnsCNT1, MAX2)
End If
If strFromName <> "" Then
strTable(2, CNT2(2)) = strFromName & "<" & strFromAddr & ">"
Else
strTable(2, CNT2(2)) = strFromAddr
End If
End If
' 送信先登録(宛先,CC,BCCをTab区切りテキストにする)
strMailto = ""
For IX1 = 0 To 2
If CNT2(IX1) >= 1 Then
Select Case IX1
Case 1: strMailto = strMailto & vbTab & "cc"
Case 2: strMailto = strMailto & vbTab & "bcc"
End Select
IX = 1
Do While IX <= CNT2(IX1)
' 2件目以降はTab区切りでセット
If strMailto = "" Then
strMailto = strTable(IX1, IX)
Else
strMailto = strMailto & vbTab & strTable(IX1, IX)
End If
IX = IX + 1
Loop
End If
Next IX1
' 添付ファイル処理
strFileName = ""
If Trim$(strLzhFile) <> "" Then
' 圧縮ファイルが指定されている場合は圧縮ファイルを添付ファイルに指定
strMSG = FP_ArchiveByUNLHA32(strLzhFile, vntFileName, strCaption)
If strMSG <> g_cnsOK Then
SendMailByBASP21 = "圧縮ファイルの作成に失敗しました。" & vbCr & _
strMSG
Exit Function
End If
strFileName = strLzhFile
Else
' 圧縮ファイルが指定されていない場合はTab区切りテキストにする
IX1 = g_cnsCNT1
IX = 1
Do While IX <= CNT2(IX1)
If strFileName = "" Then
strFileName = strTable(IX1, IX)
Else
strFileName = strFileName & vbTab & strTable(IX1, IX)
End If
IX = IX + 1
Loop
End If
'-------------------------------------------------------------------------------
' ■送信処理
' ダイアルアップ接続(エントリ名が指定されている場合のみ)
strDIAL_ENTRY = Trim$(strDialUp)
If strDIAL_ENTRY <> "" Then
strMSG = ""
swLine = 0
xlAPP.StatusBar = "「" & strDIAL_ENTRY & "」に接続中です．．．．"
' ウィンドウハンドルを取得
hWnd = FP_GET_HWND(strCaption)
lngConnID = 0
' リモート接続を起動
lngRet = InternetDial(hWnd, strDIAL_ENTRY, _
INTERNET_AUTODIAL_FORCE_UNATTENDED, lngConnID, 0&)
If ((lngRet <> 0) And (lngRet <> 633)) Then
strMSG = "「" & strDIAL_ENTRY & "」への接続に失敗しました。"
Select Case lngRet
Case 623: strMSG = strMSG & vbCr & " (ダイアルエントリー名が不存在)"
Case 668: strMSG = strMSG & vbCr & " (パスワードが未登録)"
Case Else: strMSG = strMSG & vbCr & _
" (その他エラー : " & CStr(lngRet) & " )"
End Select
SendMailByBASP21 = strMSG
Exit Function
End If
swLine = 1
End If
' BASP21(BSMTP.dll)実行
xlAPP.StatusBar = "メールを送信中です．．．．"
On Error GoTo BASP_ERROR
#If cnsSW_TEST = 1 Then
' 本番
strRC = SendMail(strSV_Name, strMailto, strMailFrom, strSubj, _
strMessage, strFileName)
#Else
' テスト(引数表示のみ)
MsgBox "・ドメイン/SMTP:ポート:タイムアウト = " & strSV_Name & vbCr & _
"・宛先 = " & strMailto & vbCr & _
"・差出人 = " & strMailFrom & vbCr & _
"・件名 = " & strSubj & vbCr & _
"・添付 = " & strFileName & vbCr & vbCr & _
"※これはテスト用の確認メッセージです。" & vbCr & _
" 本番に切り替えるには、modSendMailByBASP21_2の最初にある" & vbCr & _
" コンパイルスイッチ「cnsSW_TEST」の値を「1」に変更して保存して下さい。"
#End If
' ダイアルコネクションを切断
If swLine = 1 Then
' 回線を切断
xlAPP.StatusBar = "「" & strDIAL_ENTRY & "」を切断中です．．．．"
InternetHangUp lngConnID, 0&
AppActivate xlAPP.Caption ' Excelをアクティブにする
swLine = 0
End If
If strRC <> "" Then
SendMailByBASP21 = strRC & vbCr & vbCr & _
"サーバーに接続できないか、切断されました。"
xlAPP.StatusBar = False
Exit Function
End If
'-------------------------------------------------------------------------------
' ■終了処理(圧縮ファイル指定時の事後削除処理)
' 圧縮ファイルを作成した場合は削除するか判定する(送信正常時のみ)
If strLzhFile <> "" Then
xlAPP.DisplayAlerts = False
Select Case intDelMode
Case 1
' 圧縮ファイルを削除する
Kill strLzhFile
Case 2
' 元ファイルを削除する
If IsArray(vntFileName) = True Then
' 配列指定時は順次削除
vntAddr = vntFileName
For IX2 = LBound(vntAddr) To UBound(vntAddr)
On Error GoTo MakeArray_ARRAY2
strAddr = Trim$(vntAddr(IX2))
On Error Resume Next
Kill strAddr
Next IX2
On Error GoTo 0
Else
' 単一ファイル指定
strFileName = Trim$(vntFileName)
On Error Resume Next
Kill strFileName
On Error GoTo 0
End If
End Select
xlAPP.DisplayAlerts = True
End If
SendMailByBASP21 = g_cnsOK
AppActivate xlAPP.Caption ' Excelをアクティブにする
xlAPP.StatusBar = False
Exit Function
'-------------------------------------------------------------------------------
' 1次元参照でエラーの場合は2次元として処理(セル範囲格納対応)
MakeArray_ARRAY2:
On Error GoTo MakeArray_ERROR
strAddr = Trim$(vntAddr(IX2, 1))
Resume Next
'-------------------------------------------------------------------------------
' 1次元参照でエラーの場合は2次元として処理(セル範囲格納対応)
MakeArray_ARRAY3:
On Error GoTo MakeArray_ERROR
strName = Trim$(vntName(IX2, 1))
Resume Next
'-------------------------------------------------------------------------------
' 格納テーブルにセットする
MakeArray_SUB:
If strAddr <> "" Then
IX3 = IX3 + 1
If IX3 > MAX2 Then
' 最大値で格納テーブルの要素数を変更
MAX2 = IX3
ReDim Preserve strTable(g_cnsCNT1, MAX2)
End If
If strName <> "" Then
strTable(IX1, IX3) = strName & "<" & strAddr & ">"
Else
strTable(IX1, IX3) = strAddr
End If
' 宛先に送信者アドレスがある場合はBCC付加しない
If strAddr = strFromAddr Then swOwnerBCC = False
End If
Return
'-------------------------------------------------------------------------------
' エラー処理
MakeArray_ERROR:
SendMailByBASP21 = "パラメータ登録処理に失敗しました。(" & _
vntMSG(IX1) & ")" & vbCr & " (" & Err.Description & ")"
xlAPP.StatusBar = False
Exit Function
'-------------------------------------------------------------------------------
' BASP21実行時エラー
BASP_ERROR:
strRC = "メール送信コンポーネント「BASP21」が実行できません。" & _
vbCr & Err.Number & " " & Err.Description
Resume Next
End Function
'*******************************************************************************
' ファイル圧縮機能(UNLHA32.dll必須)
'*******************************************************************************
' [引数]
' strTarget : 圧縮後のファイル名
' vntSource : 圧縮対象のファイル名(複数の場合は配列をセットする)
' strCaption : 親ウィンドウのCaption
' [戻り値]
' "OK"=成功, それ以外はエラーメッセージ
'*******************************************************************************
Public Function FP_ArchiveByUNLHA32(strTarget As String, _
vntSource As Variant, _
Optional strCaption As String) As String
Dim xlAPP As Application
Dim strFileName As String ' ファイル名(work)
Dim strPathName As String ' 圧縮ファイルのフォルダ
Dim strExeName As String ' 自動解凍圧縮ファイル
Dim strCommand As String ' UNLHAコマンドライン
Dim strBuffer As String ' Work
Dim strEXT As String ' 拡張子
Dim IX As Long ' テーブルIndex
Dim hWnd As Long ' ウィンドウハンドル
Dim strMSG As String ' UNLHA32エラーメッセージ
Dim cntSource As Long ' 入力ファイル数
FP_ArchiveByUNLHA32 = g_cnsNG
Set xlAPP = Application
xlAPP.StatusBar = "圧縮ファイル作成中．．．．"
' UNLHA32.dllの存在確認
If Dir(FP_GET_SYSTEM_PATH & "UNLHA32.dll", vbNormal) = "" Then
FP_ArchiveByUNLHA32 = _
"圧縮コンポーネント「UNLHA32」がインストールされていません。"
Exit Function
End If
' 出力ファイルにパスがない場合はTEMPフォルダに出力
strFileName = Trim$(strTarget)
If ((Left$(strFileName, 2) <> "\\") And _
(Mid$(strFileName, 2, 2) <> ":\")) Then
' TEMPフォルダを受領
strPathName = FP_GET_TEMP_PATH
strTarget = strPathName & strFileName
Else
strTarget = strFileName
IX = Len(strFileName)
Do While IX > 1
If Mid$(strFileName, IX, 1) = g_cnsYen Then Exit Do
IX = IX - 1
Loop
strPathName = Left$(strFileName, IX)
End If
' 拡張子の判定
strEXT = StrConv(Right$(strTarget, 3), vbUpperCase)
If ((strEXT <> "LZH") And (strEXT <> "EXE")) Then
If Mid$(strTarget, Len(strTarget) - 3, 1) <> "." Then
strTarget = strTarget & g_cnsLZH
Else
strFileName = Left$(strTarget, Len(strTarget) - 4)
strTarget = strFileName & g_cnsLZH
End If
ElseIf strEXT = "EXE" Then
strExeName = strTarget
strFileName = Left$(strTarget, Len(strTarget) - 4)
strTarget = strFileName & g_cnsLZH
End If
' 同名ファイルが存在する場合は削除
If Dir(strTarget, vbNormal) <> "" Then Kill strTarget
' UNLHAのコマンドラインを編集
strCommand = "a """ & strTarget & """"
If IsArray(vntSource) = True Then
For IX = LBound(vntSource) To UBound(vntSource)
On Error GoTo UnLha_ARRAY
strFileName = Trim$(vntSource(IX))
On Error GoTo 0
If strFileName <> "" Then
If GetAttr(strFileName) And vbDirectory Then
FP_ArchiveByUNLHA32 = _
"複数指定ではフォルダは指定できません。"
GoTo UnLha_EXIT
Else
strCommand = strCommand & " """ & strFileName & """"
End If
cntSource = cntSource + 1
End If
Next IX
ElseIf IsError(vntSource) <> True Then
strFileName = Trim$(vntSource)
If strFileName <> "" Then
If GetAttr(strFileName) And vbDirectory Then
' フォルダ指定の場合は配下全てを格納
strCommand = strCommand & " -d1 """ & _
Left(strFileName, Len(strFileName) - _
Len(Dir(strFileName, vbDirectory))) & "\"" " & _
Dir(strFileName, vbDirectory)
Else
strCommand = strCommand & " """ & strFileName & """"
End If
cntSource = cntSource + 1
End If
End If
' 有効な入力ファイルがない場合は無視
If cntSource < 1 Then
strTarget = ""
FP_ArchiveByUNLHA32 = g_cnsOK
Exit Function
End If
On Error GoTo UnLha_ERROR
' ウィンドウハンドルを取得
hWnd = FP_GET_HWND(strCaption)
' コマンドラインに従ってUNLHAを操作
strBuffer = String(256, Chr$(0))
If Unlha(hWnd, strCommand, strBuffer, Len(strBuffer)) = 0& Then
If strEXT = "EXE" Then
' EXE形式指定の場合は自動解凍書庫に変換
strCommand = "s -gw2 """ & strTarget & """ """ & strPathName & """"
strBuffer = String(256, Chr$(0))
If Unlha(hWnd, strCommand, strBuffer, Len(strBuffer)) = 0& Then
Kill strTarget
strTarget = strExeName
FP_ArchiveByUNLHA32 = g_cnsOK
Else
FP_ArchiveByUNLHA32 = _
Left$(strBuffer, InStr(1, strBuffer, Chr$(0)) - 1)
End If
Else
FP_ArchiveByUNLHA32 = g_cnsOK
End If
Else
FP_ArchiveByUNLHA32 = Left$(strBuffer, InStr(1, strBuffer, Chr$(0)) - 1)
End If
GoTo UnLha_EXIT
'-------------------------------------------------------------------------------
' 配列操作エラー対応(2次元配列の場合は再配置して戻る)
UnLha_ARRAY:
On Error GoTo UnLha_ERROR2
strFileName = Trim$(vntSource(IX, 1))
Resume Next
'-------------------------------------------------------------------------------
' UNLHA32実行時エラー
UnLha_ERROR:
FP_ArchiveByUNLHA32 = "圧縮コンポーネント「UNLHA32」が実行できません。" & _
vbCr & Err.Number & " " & Err.Description
GoTo UnLha_EXIT
'-------------------------------------------------------------------------------
' 配列操作時エラー
UnLha_ERROR2:
FP_ArchiveByUNLHA32 = "入力ファイル指定が正しくありません。(UNLHA32)" & _
vbCr & Err.Number & " " & Err.Description
'-------------------------------------------------------------------------------
' UNLHA32処理終了
UnLha_EXIT:
On Error Resume Next
AppActivate xlAPP.Caption
End Function
'*******************************************************************************
' WindowsのSYSTEMフォルダ取得
'*******************************************************************************
' [戻り値] SYSTEMフォルダ(エラー無視)
'*******************************************************************************
Private Function FP_GET_SYSTEM_PATH() As String
Dim strBuffer As String
Dim strPathName As String
' Bufferを確保
strBuffer = String(MAX_PATH, Chr(0))
' SYSTEMディレクトリ名取得
Call GetSystemDirectory(strBuffer, MAX_PATH)
' Null文字の手前までを有効として表示(カッコ内はロングファイル名変換後)
strPathName = Left$(strBuffer, InStr(1, strBuffer, Chr(0)) - 1)
If Right$(strPathName, 1) <> g_cnsYen Then strPathName = strPathName & g_cnsYen
FP_GET_SYSTEM_PATH = strPathName
End Function
'*******************************************************************************
' WindowsのTEMPフォルダ取得
'*******************************************************************************
' [戻り値] TEMPフォルダ(エラー無視)
'*******************************************************************************
Private Function FP_GET_TEMP_PATH() As String
Dim strBuffer As String
Dim strPathName As String
' Bufferを確保
strBuffer = String(MAX_PATH, Chr(0))
' SYSTEMディレクトリ名取得
Call GetTempPath(MAX_PATH, strBuffer)
' Null文字の手前までを有効として表示(カッコ内はロングファイル名変換後)
strPathName = Left$(strBuffer, InStr(1, strBuffer, Chr(0)) - 1)
If Right$(strPathName, 1) <> g_cnsYen Then strPathName = strPathName & g_cnsYen
FP_GET_TEMP_PATH = strPathName
End Function
'*******************************************************************************
' ウィンドウハンドルの取得
'*******************************************************************************
' [引数]
' strCaption : ウィンドウのCaption(クラスは自動判断)
' [戻り値]
' hWnd : ウィンドウハンドル値(失敗はゼロ)
'*******************************************************************************
Private Function FP_GET_HWND(strCaption As String) As Long
Dim strClassName As String
strClassName = "XLMAIN"
Select Case strCaption
Case "": strCaption = Application.Caption
Case Application.Caption
Case Else
' UserFormの場合
If Val(Application.Version) <= 8 Then
strClassName = "ThunderXFrame" ' Excel97
Else
strClassName = "ThunderDFrame" ' Excel2000以降
End If
End Select
On Error GoTo GET_HWND_ERR
FP_GET_HWND = FindWindow(strClassName, strCaption)
Exit Function
'-------------------------------------------------------------------------------
GET_HWND_ERR:
FP_GET_HWND = 0&
End Function
'-----------------------------<< End of Source >>-------------------------------
' Eメール送信機能 ※BSMTP.dll(BASP21),UNLHA32.dll必須
'
' 作成者:井上治 URL:http://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'*******************************************************************************
Option Explicit
'**********↓↓↓実際に送信を行なう段階でこの値を「1」に変更して下さい↓↓↓
#Const cnsSW_TEST = 0 ' テスト中(=0)
'#Const cnsSW_TEST = 1 ' 本番(=1)
'**********↑↑↑実際に送信を行なう段階でこの値を「1」に変更して下さい↑↑↑
Private Const INTERNET_AUTODIAL_FORCE_ONLINE = 1
Private Const INTERNET_AUTODIAL_FORCE_UNATTENDED = 2
Private Const INTERNET_DIAL_UNATTENDED = &H8000
Private Const INTERNET_AUTODIAL_FAILIFSECURITYCHECK = 4
Private Const g_cnsNG = "NG"
Private Const g_cnsOK = "OK"
Private Const g_cnsYen = "\"
Private Const g_cnsLZH = ".lzh"
Private Const g_cnsERRMSG1 = "が正しくありません。"
Private Const g_cnsCNT1 = 3 ' 格納テーブル1次元目の要素数(固定)
Private Const MAX_PATH = 260
' メール送信API(BASP21)
Private Declare Function SendMail Lib "BSMTP.dll" _
(szServer As String, szTo As String, szFrom As String, _
szSubject As String, szBody As String, szFile As String) As String
' LHA圧縮を操作するAPI(UNLHA32)
Private Declare Function Unlha Lib "UNLHA32.dll" _
(ByVal lhWnd As Long, ByVal szCmdLine As String, _
ByVal szOutPut As String, ByVal wSize As Long) As Long
' ダイアルアップエントリーを指定して接続(IE4以上必須)
Private Declare Function InternetDial Lib "WININET.dll" _
(ByVal hwndParent As Long, ByVal lpszConnectoid As String, _
ByVal dwFlags As Long, lpdwConnection As Long, _
ByVal dwReserved As Long) As Long
' ダイアルアップIDを指定して切断
Private Declare Function InternetHangUp Lib "WININET.dll" _
(ByVal dwConnection As Long, ByVal dwReserved As Long) As Long
' ウィンドゥハンドルを返す
Private Declare Function FindWindow Lib "USER32.dll" _
Alias "FindWindowA" (ByVal lpClassName As Any, _
ByVal lpWindowName As Any) As Long
' Sleep
Private Declare Sub Sleep Lib "KERNEL32.dll" _
(ByVal dwMilliseconds As Long)
' SYSTEMディレクトリ名取得API
Private Declare Function GetSystemDirectory Lib "KERNEL32.dll" _
Alias "GetSystemDirectoryA" _
(ByVal lpBuffer As String, ByVal nSize As Long) As Long
' WindowsのTEMPフォルダ取得
Private Declare Function GetTempPath Lib "KERNEL32.dll" _
Alias "GetTempPathA" _
(ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
'*******************************************************************************
' Eメール送信機能(BSMTP.dll必須)
'*******************************************************************************
' [引数]
' strDialUp : ダイアルアップ登録名(ダイアルアップしない時はブランク)
' strDomain : ドメイン名(xxxx.co.jp等)
' strSMTP : SMTPサーバ名(smtp.xxxx.co.jp,mail.xxxx.co.jp等)
' strPort : 通常は「25」,ブランクの場合は「25」
' strTimeOut : 「60」位が適当,ブランクの場合は「60」
' strFromName : 送信元名称
' strFromAddr : 送信元アドレス
' vntToName : 宛先名称(複数の場合は配列)
' vntToAddr : 宛先アドレス(複数の場合は配列,配列要素数は宛先名称と要一致)
' vntCCName : CC宛先名称(複数の場合は配列)
' vntCCAddr : CC宛先アドレス(複数の場合は配列,配列要素数はCC名と要一致)
' vntBCCName : BCC宛先名称(複数の場合は配列)
' vntBCCAddr : BCC宛先アドレス(複数の場合は配列,配列要素数はBCC名と要一致)
' swOwnerBCC : Trueの場合、送信元アドレスをBCCに加える
' strSubj : 件名
' strMessage : 本文(署名も付加してセット)
' strCaption : 親ウィンドウのCaption
' vntFileName : フルパス添付ファイル名(複数の場合は配列) ※ない場合はブランク
' strLzhFile : 上記添付ファイルを圧縮する場合はその圧縮ファイル名(パス名不要)
' intDelMode : 圧縮時の削除方法(0=削除なし, 1=圧縮ファイルを削除, 2=元ファイルを削除)
' [戻り値]
' "OK"=成功, それ以外はエラーメッセージ
'*******************************************************************************
Public Function SendMailByBASP21(strDialUp As String, _
strDomain As String, _
strSMTP As String, _
strPort As String, _
strTimeOut As String, _
strFromName As String, _
strFromAddr As String, _
vntToName As Variant, _
vntToAddr As Variant, _
vntCCName As Variant, _
vntCCAddr As Variant, _
vntBCCName As Variant, _
vntBCCAddr As Variant, _
swOwnerBCC As Boolean, _
strSubj As String, _
strMessage As String, _
Optional strCaption As String, _
Optional vntFileName As Variant, _
Optional strLzhFile As String, _
Optional intDelMode As Integer) As String
Dim xlAPP As Application
Dim strDIAL_ENTRY As String ' ダイアルアップエントリー
Dim strSV_Name As String ' ドメイン/SMTP:ポート:タイムアウト
Dim strMailFrom As String ' 送信元登録
Dim strMailto As String ' 送信先登録
Dim strTable() As String ' 配列値格納テーブル
Dim MAX2 As Integer ' テーブルに格納した要素数(2次元目最大値)
Dim CNT2() As Integer ' テーブルに格納した要素数(2次元目各要素)
Dim vntName As Variant ' 宛先名Work
Dim vntAddr As Variant ' アドレスWork
Dim strPathName As String ' 添付ファイルのフォルダ名
Dim strFileName As String ' 添付ファイル
Dim swLine As Byte ' ダイアル接続スイッチ
Dim hWnd As Long ' ウィンドウハンドル
Dim lngConnID As Long ' コネクションコード
Dim IX As Long ' テーブルIndex
Dim IX1 As Long ' テーブルIndex
Dim IX2 As Long ' テーブルIndex
Dim IX3 As Long ' テーブルIndex
Dim lngRet As Long ' リターンコード
Dim strRC As String ' BASP21戻り値
Dim strMSG As String ' メッセージ
Dim vntMSG As Variant ' メッセージWork
Dim strName As String ' Work
Dim strAddr As String ' Work
SendMailByBASP21 = g_cnsNG
Set xlAPP = Application
' BSMTP.dllの存在確認
If Dir(FP_GET_SYSTEM_PATH & "BSMTP.dll", vbNormal) = "" Then
SendMailByBASP21 = _
"送信コンポーネント「BSMTP.dll」がインストールされていません。"
Exit Function
End If
'-------------------------------------------------------------------------------
' ■準備処理(引き渡しパラメータの作成)
' ドメイン/SMTP:ポート:タイムアウト
If Trim$(strPort) = "" Then strPort = "25"
If Trim$(strTimeOut) = "" Then strTimeOut = "60"
strSV_Name = Trim$(strDomain) & "/" & _
Trim$(strSMTP) & ":" & _
Trim$(strPort) & ":" & _
Trim$(strTimeOut)
' Variant項目未使用の場合の対応
If IsError(vntToName) Then vntToName = ""
If IsError(vntToAddr) Then vntToAddr = ""
If IsError(vntCCName) Then vntCCName = ""
If IsError(vntCCAddr) Then vntCCAddr = ""
If IsError(vntBCCName) Then vntBCCName = ""
If IsError(vntBCCAddr) Then vntBCCAddr = ""
If IsError(vntFileName) Then vntFileName = ""
' 送信元登録
If Trim$(strFromAddr) = "" Then
SendMailByBASP21 = "送信元のメールアドレスがありません"
Exit Function
End If
If Trim$(strFromName) = "" Then
strMailFrom = Trim$(strFromAddr)
Else
strMailFrom = Trim$(strFromName) & _
"<" & Trim$(strFromAddr) & ">"
End If
' 配列で引き渡される可能性がある項目を全て別テーブルに格納し直す
' (以後は全て配列の文字列変数として処理できる)
MAX2 = 0
ReDim strTable(g_cnsCNT1, MAX2)
ReDim CNT2(g_cnsCNT1)
vntMSG = Array("宛先", "CC宛先", "BCC宛先", "添付ファイル名")
For IX1 = 0 To g_cnsCNT1
Select Case IX1
Case 0: vntName = vntToName: vntAddr = vntToAddr ' 宛先
Case 1: vntName = vntCCName: vntAddr = vntCCAddr ' CC
Case 2: vntName = vntBCCName: vntAddr = vntBCCAddr ' BCC
Case 3: vntName = vntFileName: vntAddr = vntFileName ' 添付ファイル
End Select
IX3 = 0
If IsArray(vntAddr) = True Then
' 格納テーブルに配列を格納
For IX2 = LBound(vntAddr) To UBound(vntAddr)
On Error GoTo MakeArray_ARRAY2
strAddr = Trim$(vntAddr(IX2))
If ((IX1 < g_cnsCNT1) And (IX2 <= UBound(vntName))) Then
On Error GoTo MakeArray_ARRAY3
strName = Trim$(vntName(IX2))
Else
strName = ""
End If
GoSub MakeArray_SUB
Next IX2
Else
If IX1 < g_cnsCNT1 Then
strName = Trim$(vntName)
Else
strName = ""
End If
strAddr = Trim$(vntAddr)
GoSub MakeArray_SUB
End If
CNT2(IX1) = IX3
Next IX1
If CNT2(0) < 1 Then
SendMailByBASP21 = "宛先のメールアドレスがありません"
Exit Function
End If
' 送信者をBCCに追加指定の処理(swOwnerBCC指定の場合)
If swOwnerBCC = True Then
CNT2(2) = CNT2(2) + 1
If CNT2(2) > MAX2 Then
MAX2 = CNT2(2)
ReDim Preserve strTable(g_cnsCNT1, MAX2)
End If
If strFromName <> "" Then
strTable(2, CNT2(2)) = strFromName & "<" & strFromAddr & ">"
Else
strTable(2, CNT2(2)) = strFromAddr
End If
End If
' 送信先登録(宛先,CC,BCCをTab区切りテキストにする)
strMailto = ""
For IX1 = 0 To 2
If CNT2(IX1) >= 1 Then
Select Case IX1
Case 1: strMailto = strMailto & vbTab & "cc"
Case 2: strMailto = strMailto & vbTab & "bcc"
End Select
IX = 1
Do While IX <= CNT2(IX1)
' 2件目以降はTab区切りでセット
If strMailto = "" Then
strMailto = strTable(IX1, IX)
Else
strMailto = strMailto & vbTab & strTable(IX1, IX)
End If
IX = IX + 1
Loop
End If
Next IX1
' 添付ファイル処理
strFileName = ""
If Trim$(strLzhFile) <> "" Then
' 圧縮ファイルが指定されている場合は圧縮ファイルを添付ファイルに指定
strMSG = FP_ArchiveByUNLHA32(strLzhFile, vntFileName, strCaption)
If strMSG <> g_cnsOK Then
SendMailByBASP21 = "圧縮ファイルの作成に失敗しました。" & vbCr & _
strMSG
Exit Function
End If
strFileName = strLzhFile
Else
' 圧縮ファイルが指定されていない場合はTab区切りテキストにする
IX1 = g_cnsCNT1
IX = 1
Do While IX <= CNT2(IX1)
If strFileName = "" Then
strFileName = strTable(IX1, IX)
Else
strFileName = strFileName & vbTab & strTable(IX1, IX)
End If
IX = IX + 1
Loop
End If
'-------------------------------------------------------------------------------
' ■送信処理
' ダイアルアップ接続(エントリ名が指定されている場合のみ)
strDIAL_ENTRY = Trim$(strDialUp)
If strDIAL_ENTRY <> "" Then
strMSG = ""
swLine = 0
xlAPP.StatusBar = "「" & strDIAL_ENTRY & "」に接続中です．．．．"
' ウィンドウハンドルを取得
hWnd = FP_GET_HWND(strCaption)
lngConnID = 0
' リモート接続を起動
lngRet = InternetDial(hWnd, strDIAL_ENTRY, _
INTERNET_AUTODIAL_FORCE_UNATTENDED, lngConnID, 0&)
If ((lngRet <> 0) And (lngRet <> 633)) Then
strMSG = "「" & strDIAL_ENTRY & "」への接続に失敗しました。"
Select Case lngRet
Case 623: strMSG = strMSG & vbCr & " (ダイアルエントリー名が不存在)"
Case 668: strMSG = strMSG & vbCr & " (パスワードが未登録)"
Case Else: strMSG = strMSG & vbCr & _
" (その他エラー : " & CStr(lngRet) & " )"
End Select
SendMailByBASP21 = strMSG
Exit Function
End If
swLine = 1
End If
' BASP21(BSMTP.dll)実行
xlAPP.StatusBar = "メールを送信中です．．．．"
On Error GoTo BASP_ERROR
#If cnsSW_TEST = 1 Then
' 本番
strRC = SendMail(strSV_Name, strMailto, strMailFrom, strSubj, _
strMessage, strFileName)
#Else
' テスト(引数表示のみ)
MsgBox "・ドメイン/SMTP:ポート:タイムアウト = " & strSV_Name & vbCr & _
"・宛先 = " & strMailto & vbCr & _
"・差出人 = " & strMailFrom & vbCr & _
"・件名 = " & strSubj & vbCr & _
"・添付 = " & strFileName & vbCr & vbCr & _
"※これはテスト用の確認メッセージです。" & vbCr & _
" 本番に切り替えるには、modSendMailByBASP21_2の最初にある" & vbCr & _
" コンパイルスイッチ「cnsSW_TEST」の値を「1」に変更して保存して下さい。"
#End If
' ダイアルコネクションを切断
If swLine = 1 Then
' 回線を切断
xlAPP.StatusBar = "「" & strDIAL_ENTRY & "」を切断中です．．．．"
InternetHangUp lngConnID, 0&
AppActivate xlAPP.Caption ' Excelをアクティブにする
swLine = 0
End If
If strRC <> "" Then
SendMailByBASP21 = strRC & vbCr & vbCr & _
"サーバーに接続できないか、切断されました。"
xlAPP.StatusBar = False
Exit Function
End If
'-------------------------------------------------------------------------------
' ■終了処理(圧縮ファイル指定時の事後削除処理)
' 圧縮ファイルを作成した場合は削除するか判定する(送信正常時のみ)
If strLzhFile <> "" Then
xlAPP.DisplayAlerts = False
Select Case intDelMode
Case 1
' 圧縮ファイルを削除する
Kill strLzhFile
Case 2
' 元ファイルを削除する
If IsArray(vntFileName) = True Then
' 配列指定時は順次削除
vntAddr = vntFileName
For IX2 = LBound(vntAddr) To UBound(vntAddr)
On Error GoTo MakeArray_ARRAY2
strAddr = Trim$(vntAddr(IX2))
On Error Resume Next
Kill strAddr
Next IX2
On Error GoTo 0
Else
' 単一ファイル指定
strFileName = Trim$(vntFileName)
On Error Resume Next
Kill strFileName
On Error GoTo 0
End If
End Select
xlAPP.DisplayAlerts = True
End If
SendMailByBASP21 = g_cnsOK
AppActivate xlAPP.Caption ' Excelをアクティブにする
xlAPP.StatusBar = False
Exit Function
'-------------------------------------------------------------------------------
' 1次元参照でエラーの場合は2次元として処理(セル範囲格納対応)
MakeArray_ARRAY2:
On Error GoTo MakeArray_ERROR
strAddr = Trim$(vntAddr(IX2, 1))
Resume Next
'-------------------------------------------------------------------------------
' 1次元参照でエラーの場合は2次元として処理(セル範囲格納対応)
MakeArray_ARRAY3:
On Error GoTo MakeArray_ERROR
strName = Trim$(vntName(IX2, 1))
Resume Next
'-------------------------------------------------------------------------------
' 格納テーブルにセットする
MakeArray_SUB:
If strAddr <> "" Then
IX3 = IX3 + 1
If IX3 > MAX2 Then
' 最大値で格納テーブルの要素数を変更
MAX2 = IX3
ReDim Preserve strTable(g_cnsCNT1, MAX2)
End If
If strName <> "" Then
strTable(IX1, IX3) = strName & "<" & strAddr & ">"
Else
strTable(IX1, IX3) = strAddr
End If
' 宛先に送信者アドレスがある場合はBCC付加しない
If strAddr = strFromAddr Then swOwnerBCC = False
End If
Return
'-------------------------------------------------------------------------------
' エラー処理
MakeArray_ERROR:
SendMailByBASP21 = "パラメータ登録処理に失敗しました。(" & _
vntMSG(IX1) & ")" & vbCr & " (" & Err.Description & ")"
xlAPP.StatusBar = False
Exit Function
'-------------------------------------------------------------------------------
' BASP21実行時エラー
BASP_ERROR:
strRC = "メール送信コンポーネント「BASP21」が実行できません。" & _
vbCr & Err.Number & " " & Err.Description
Resume Next
End Function
'*******************************************************************************
' ファイル圧縮機能(UNLHA32.dll必須)
'*******************************************************************************
' [引数]
' strTarget : 圧縮後のファイル名
' vntSource : 圧縮対象のファイル名(複数の場合は配列をセットする)
' strCaption : 親ウィンドウのCaption
' [戻り値]
' "OK"=成功, それ以外はエラーメッセージ
'*******************************************************************************
Public Function FP_ArchiveByUNLHA32(strTarget As String, _
vntSource As Variant, _
Optional strCaption As String) As String
Dim xlAPP As Application
Dim strFileName As String ' ファイル名(work)
Dim strPathName As String ' 圧縮ファイルのフォルダ
Dim strExeName As String ' 自動解凍圧縮ファイル
Dim strCommand As String ' UNLHAコマンドライン
Dim strBuffer As String ' Work
Dim strEXT As String ' 拡張子
Dim IX As Long ' テーブルIndex
Dim hWnd As Long ' ウィンドウハンドル
Dim strMSG As String ' UNLHA32エラーメッセージ
Dim cntSource As Long ' 入力ファイル数
FP_ArchiveByUNLHA32 = g_cnsNG
Set xlAPP = Application
xlAPP.StatusBar = "圧縮ファイル作成中．．．．"
' UNLHA32.dllの存在確認
If Dir(FP_GET_SYSTEM_PATH & "UNLHA32.dll", vbNormal) = "" Then
FP_ArchiveByUNLHA32 = _
"圧縮コンポーネント「UNLHA32」がインストールされていません。"
Exit Function
End If
' 出力ファイルにパスがない場合はTEMPフォルダに出力
strFileName = Trim$(strTarget)
If ((Left$(strFileName, 2) <> "\\") And _
(Mid$(strFileName, 2, 2) <> ":\")) Then
' TEMPフォルダを受領
strPathName = FP_GET_TEMP_PATH
strTarget = strPathName & strFileName
Else
strTarget = strFileName
IX = Len(strFileName)
Do While IX > 1
If Mid$(strFileName, IX, 1) = g_cnsYen Then Exit Do
IX = IX - 1
Loop
strPathName = Left$(strFileName, IX)
End If
' 拡張子の判定
strEXT = StrConv(Right$(strTarget, 3), vbUpperCase)
If ((strEXT <> "LZH") And (strEXT <> "EXE")) Then
If Mid$(strTarget, Len(strTarget) - 3, 1) <> "." Then
strTarget = strTarget & g_cnsLZH
Else
strFileName = Left$(strTarget, Len(strTarget) - 4)
strTarget = strFileName & g_cnsLZH
End If
ElseIf strEXT = "EXE" Then
strExeName = strTarget
strFileName = Left$(strTarget, Len(strTarget) - 4)
strTarget = strFileName & g_cnsLZH
End If
' 同名ファイルが存在する場合は削除
If Dir(strTarget, vbNormal) <> "" Then Kill strTarget
' UNLHAのコマンドラインを編集
strCommand = "a """ & strTarget & """"
If IsArray(vntSource) = True Then
For IX = LBound(vntSource) To UBound(vntSource)
On Error GoTo UnLha_ARRAY
strFileName = Trim$(vntSource(IX))
On Error GoTo 0
If strFileName <> "" Then
If GetAttr(strFileName) And vbDirectory Then
FP_ArchiveByUNLHA32 = _
"複数指定ではフォルダは指定できません。"
GoTo UnLha_EXIT
Else
strCommand = strCommand & " """ & strFileName & """"
End If
cntSource = cntSource + 1
End If
Next IX
ElseIf IsError(vntSource) <> True Then
strFileName = Trim$(vntSource)
If strFileName <> "" Then
If GetAttr(strFileName) And vbDirectory Then
' フォルダ指定の場合は配下全てを格納
strCommand = strCommand & " -d1 """ & _
Left(strFileName, Len(strFileName) - _
Len(Dir(strFileName, vbDirectory))) & "\"" " & _
Dir(strFileName, vbDirectory)
Else
strCommand = strCommand & " """ & strFileName & """"
End If
cntSource = cntSource + 1
End If
End If
' 有効な入力ファイルがない場合は無視
If cntSource < 1 Then
strTarget = ""
FP_ArchiveByUNLHA32 = g_cnsOK
Exit Function
End If
On Error GoTo UnLha_ERROR
' ウィンドウハンドルを取得
hWnd = FP_GET_HWND(strCaption)
' コマンドラインに従ってUNLHAを操作
strBuffer = String(256, Chr$(0))
If Unlha(hWnd, strCommand, strBuffer, Len(strBuffer)) = 0& Then
If strEXT = "EXE" Then
' EXE形式指定の場合は自動解凍書庫に変換
strCommand = "s -gw2 """ & strTarget & """ """ & strPathName & """"
strBuffer = String(256, Chr$(0))
If Unlha(hWnd, strCommand, strBuffer, Len(strBuffer)) = 0& Then
Kill strTarget
strTarget = strExeName
FP_ArchiveByUNLHA32 = g_cnsOK
Else
FP_ArchiveByUNLHA32 = _
Left$(strBuffer, InStr(1, strBuffer, Chr$(0)) - 1)
End If
Else
FP_ArchiveByUNLHA32 = g_cnsOK
End If
Else
FP_ArchiveByUNLHA32 = Left$(strBuffer, InStr(1, strBuffer, Chr$(0)) - 1)
End If
GoTo UnLha_EXIT
'-------------------------------------------------------------------------------
' 配列操作エラー対応(2次元配列の場合は再配置して戻る)
UnLha_ARRAY:
On Error GoTo UnLha_ERROR2
strFileName = Trim$(vntSource(IX, 1))
Resume Next
'-------------------------------------------------------------------------------
' UNLHA32実行時エラー
UnLha_ERROR:
FP_ArchiveByUNLHA32 = "圧縮コンポーネント「UNLHA32」が実行できません。" & _
vbCr & Err.Number & " " & Err.Description
GoTo UnLha_EXIT
'-------------------------------------------------------------------------------
' 配列操作時エラー
UnLha_ERROR2:
FP_ArchiveByUNLHA32 = "入力ファイル指定が正しくありません。(UNLHA32)" & _
vbCr & Err.Number & " " & Err.Description
'-------------------------------------------------------------------------------
' UNLHA32処理終了
UnLha_EXIT:
On Error Resume Next
AppActivate xlAPP.Caption
End Function
'*******************************************************************************
' WindowsのSYSTEMフォルダ取得
'*******************************************************************************
' [戻り値] SYSTEMフォルダ(エラー無視)
'*******************************************************************************
Private Function FP_GET_SYSTEM_PATH() As String
Dim strBuffer As String
Dim strPathName As String
' Bufferを確保
strBuffer = String(MAX_PATH, Chr(0))
' SYSTEMディレクトリ名取得
Call GetSystemDirectory(strBuffer, MAX_PATH)
' Null文字の手前までを有効として表示(カッコ内はロングファイル名変換後)
strPathName = Left$(strBuffer, InStr(1, strBuffer, Chr(0)) - 1)
If Right$(strPathName, 1) <> g_cnsYen Then strPathName = strPathName & g_cnsYen
FP_GET_SYSTEM_PATH = strPathName
End Function
'*******************************************************************************
' WindowsのTEMPフォルダ取得
'*******************************************************************************
' [戻り値] TEMPフォルダ(エラー無視)
'*******************************************************************************
Private Function FP_GET_TEMP_PATH() As String
Dim strBuffer As String
Dim strPathName As String
' Bufferを確保
strBuffer = String(MAX_PATH, Chr(0))
' SYSTEMディレクトリ名取得
Call GetTempPath(MAX_PATH, strBuffer)
' Null文字の手前までを有効として表示(カッコ内はロングファイル名変換後)
strPathName = Left$(strBuffer, InStr(1, strBuffer, Chr(0)) - 1)
If Right$(strPathName, 1) <> g_cnsYen Then strPathName = strPathName & g_cnsYen
FP_GET_TEMP_PATH = strPathName
End Function
'*******************************************************************************
' ウィンドウハンドルの取得
'*******************************************************************************
' [引数]
' strCaption : ウィンドウのCaption(クラスは自動判断)
' [戻り値]
' hWnd : ウィンドウハンドル値(失敗はゼロ)
'*******************************************************************************
Private Function FP_GET_HWND(strCaption As String) As Long
Dim strClassName As String
strClassName = "XLMAIN"
Select Case strCaption
Case "": strCaption = Application.Caption
Case Application.Caption
Case Else
' UserFormの場合
If Val(Application.Version) <= 8 Then
strClassName = "ThunderXFrame" ' Excel97
Else
strClassName = "ThunderDFrame" ' Excel2000以降
End If
End Select
On Error GoTo GET_HWND_ERR
FP_GET_HWND = FindWindow(strClassName, strCaption)
Exit Function
'-------------------------------------------------------------------------------
GET_HWND_ERR:
FP_GET_HWND = 0&
End Function
'-----------------------------<< End of Source >>-------------------------------
 |
←SendMailByBASP21.exe (83KB) |