Excelの更新をメール通知

共有ネットワークドライブ上にExcelファイルを台帳として
保管しております。
誰かが追記したときに、他の人へも更新したことをメール
連絡しているのですが、この作業を省力化したく思います。
記入してあるセルはＡ、Ｂ、Ｃ列だけ、連絡先も固定なんでもしかしたらマクロ化できるのかなぁと思うのですが如何でしょうか？

A列：年月日、B列：件名、Ｃ列：記入者です。
最下行を読み取り
A & "日に" & Ｃ & "さんが & Ｂ"を追加しました"
と云う内容でメールを送れたら嬉しいです。

保存時若しくは終了時にマクロでメール送信できればいいなと思うのですが、どなたかご興味あればさわりだけでもサンプル作っていただけませんでしょうか？

No.1 ベストアンサー 回答者： k_o_j_i 回答日時： 2004/05/09 01:33

VBAでメールの送受信をするのは、簡単そうですが標準コントロールがないんですね。

APIでも無理なので外部コントロールを導入するしかありません。
「BASP21」というコンポーネントに付属している「BSMTP.DLL」をシステムディレクトリにコピーすれば出来るかも知れません。

「BASP21」http://www.hi-ho.ne.jp/babaq/basp21.html

下は適当に作ってみたサンプルです。
ThisWorkbook内に貼り付ければいいと思います。

Option Explicit
'SendMail関数の宣言
Declare Function SendMail Lib "bsmtp" _
(szServer As String, szTo As String, _
szFrom As String, szSubject As String, szBody As String, szFile As String) As String

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim ret As String '戻り値
Dim szServer As String, szTo As String, szFrom As String
Dim szSubject As String, szBody As String, szFile As String
Dim readRow As Long '最終行
Dim dtmDate As Date
Dim strSubject As String
Dim strMember As String
Dim fs, a As Object

On Error GoTo Err_Handler
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile("c:\log.txt", True)

szServer = "smtp.ocn.ne.jp" 'サーバー名
szTo = "*@kantei.go.jp" '宛先
szFrom = "**@kantei.go.jp" '送信元
szSubject = "更新" 'メールの主題
szFile = ""

'最終行から入力データを取得
With Worksheets("Sheet1") 'シート名
readRow = .Cells.SpecialCells(xlCellTypeLastCell).Row + 1
.Cells(readRow, 1) = dtmDate '年月日
.Cells(readRow, 2) = strSubject '件名
.Cells(readRow, 3) = strMember '記入者
End With
If dtmDate = Date Then '年月日が今日ならば
szBody = dtmDate & "に" & strMember & "さんが" & strSubject & _
"を追加しました"
ret = SendMail(szServer, szTo, szFrom, szSubject, szBody, szFile)
' パラメータエラーのときは、戻り値にエラーメッセージが返ります。
If Len(ret) <> 0 Then
a.WriteLine (Date & " " & Time & " " & ret & "－" & szTo & "－" & szBody)
MsgBox "エラー"
Else
MsgBox "完了"
End If
End If
GoTo Exit_sub

Err_Handler:
MsgBox Err.Description, vbCritical, "Error"
GoTo Exit_sub

Exit_sub:
a.Close
End Sub

本当に適当なので動かない可能性大です(;^_^A
適宜修正下さい。

参考URL：http://www.hi-ho.ne.jp/babaq/basp21.html

この回答へのお礼

ご回答ありがとうございました。
ココで一旦区切ってポイントつけさせていただきます。
今後ともよろしくお願いします。

お礼日時：2004/05/15 22:49

No.2 回答者： k_o_j_i 回答日時： 2004/05/09 02:21

１で回答したものです。

下のコードを自分で試してみましたがやっぱり駄目でした(^^ゞ
成功例は以下の通りです。

ThisWorkbook内に
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call main
End Sub

「標準モジュール」を追加してその中に
Option Explicit
'SendMail関数の宣言
Declare Function SendMail Lib "bsmtp" _
(szServer As String, szTo As String, _
szFrom As String, szSubject As String, szBody As String, szFile As String) As String
Public Sub main()
Dim ret As String '戻り値
Dim szServer As String, szTo As String, szFrom As String
Dim szSubject As String, szBody As String, szFile As String
Dim readRow As Long '最終行
Dim dtmDate As Date
Dim strSubject As String
Dim strMember As String
Dim fs, a As Object

On Error GoTo Err_Handler
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile("c:\log.txt", True)

szServer = "smtp02.odn.ne.jp" 'サーバー名
szTo = "*@japan.104.net" '宛先
szFrom = "**@japan.104.net" '送信元
szSubject = "更新" 'メールの主題
szFile = ""

'最終行から入力データを取得
With Worksheets("Sheet1") 'シート名
readRow = .Cells.SpecialCells(xlCellTypeLastCell).Row
dtmDate = .Cells(readRow, 1) '年月日
strSubject = .Cells(readRow, 2) '件名
strMember = .Cells(readRow, 3) '記入者
End With
If dtmDate = Date Then '年月日が今日ならば
szBody = dtmDate & "に" & strMember & "さんが" & strSubject & _
"を追加しました"
ret = SendMail(szServer, szTo, szFrom, szSubject, szBody, szFile)
' パラメータエラーのときは、戻り値にエラーメッセージが返ります。
If Len(ret) <> 0 Then
a.WriteLine (Date & " " & Time & " " & ret & "－" & szTo & "－" & szBody)
MsgBox "エラー"
Else
MsgBox "完了"
End If
End If
GoTo Exit_sub

Err_Handler:
MsgBox Err.Description, vbCritical, "Error"
GoTo Exit_sub

Exit_sub:
a.Close

End Sub

これでファイルを閉じる際にメールが送信されます（Win2K＆Excel2000にて確認）
なお、「bsmtp.dll」はシステムディレクトリ以外でも上手く機能します。その場合は
Declare Function SendMail Lib "bsmtp" _
を
Declare Function SendMail Lib "d:\bsmtp.dll" _
というようにフルパスで指定してやれば良いようです。

この回答へのお礼

dll配付等が面倒なのでなるだけ使わないように検討中です
今までヘルプとにらめっこしていました。
半自動ですがこんなカンジで・・・
後は、本文について先の最終行取得を盛り込んで
ゴニョゴニョしてたら完成出来るかなと思う次第です。

宛先 = Cells(2, 1)
件名 = Cells(2, 2)
本文 = Cells(2, 3)
アドレス = "mailto:" & 宛先 & "?subject=" & 件名 & "&body=" & 本文
With Worksheets(1)
.Hyperlinks.Add Anchor:=.Range("a5"), _
Address:=アドレス, _
ScreenTip:="click", _
TextToDisplay:="送信"
End With

不明点ありましたらもう少し相談に乗っていただきたく
もうすこしお付合いくださいませ。

お礼日時：2004/05/11 21:14