Bacs1ソース
データベースを開いた状態で[挿入]-[クラスモジュール]でエディタが
開きますので次をカット＆ペーストします。
Bacs1という名前で保存します。
' Bacs1 クラス モジュール
'
' ●ReadBodyメソッド
' テキストファイルを読込んでBodyプロパティに設定します。
' 成功すると 1 、失敗すると 0 を返します。
' 使用例
' Dim mail As New Bacs1 'クラス使用宣言
' If mail.ReadBody("c:\aa.txt") <> 1 Then
' MsgBox "err"
' End If
'
' ●SendAllメソッド
' テーブル内のすべての行のメールIDにメールを送信します。
' 呼出し方
' SendAll テーブル名, カラム名
' テーブル名 : 宛先メールIDが存在するテーブル名
' カラム名 : 宛先メールIDが存在するカラム名
'
' 使用例
' Dim mail As New Bacs1 'クラス使用宣言
' mail.Server = "smtp.com" 'SMTPサーバ名
' mail.From = "who@who.com" '差出人メールID
' mail.Subj = "subject 1" '件名
' mail.Body = "test" & vbCrLf & "desu" ' 本文
' mail.Files = "c:\a.txt" & vbtab & "c:\b.txt" ' 添付ファイル
' mail.SendAll テーブル名, カラム名 ' 宛先メールIDのテーブル名とカラム名
'
' ●SendMailメソッド
' 指定のメールIDにメールを送信します。
' 呼出し方
' SendMail 宛先メールID[, 本文１][,本文２][,添付ファイル名]
'
' 使用例
' Dim mail As New Bacs1 'クラス使用宣言
' mail.Server = "smtp.com" 'SMTPサーバ名
' mail.From = "who@who.com" '差出人メールID
' mail.Subj = "subject 1" '件名
' mail.Body = "test" & vbCrLf & "desu" ' 本文
' mail.Files = "c:\a.txt" & vbtab & "c:\b.txt" ' 添付ファイル
' mail.SendMail "who2@who.com","だれだれさん" & vbcrlf
'
'
' プロパティの説明
' Serverプロパティ = SMTPサーバ名
' From プロパティ = 差出人メールID
' Subj プロパティ = 件名
' BodyHeader プロパティ = 本文の前につける文（名前など）
' Body プロパティ = 本文
' Files プロパティ = 添付ファイル名
'
Option Compare Database
Option Explicit
Private Const Pname = "Bacs1"
Private strsvname As Variant
Private strfrom As Variant
Private strsubj As Variant
Private strfiles As Variant
Private strbody As Variant
Private strbodyheader As Variant
Private basp21 As Object
Public Property Let Server(ByVal name As String)
strsvname = name
End Property
Public Property Get Server() As String
Server = strsvname
End Property
Public Property Let From(ByVal name As String)
strfrom = name
End Property
Public Property Get From() As String
From = strfrom
End Property
Public Property Let subj(ByVal name As String)
strsubj = name
End Property
Public Property Get subj() As String
subj = strsubj
End Property
Public Property Let body(ByVal name As String)
strbody = name
End Property
Public Property Get body() As String
body = strbody
End Property
Public Property Let bodyheader(ByVal name As String)
strbodyheader = name
End Property
Public Property Get bodyheader() As String
body = strbodyheader
End Property
Public Property Let files(ByVal name As String)
strfiles = name
End Property
Public Property Get files() As String
files = strfiles
End Property
Private Function Check_err() As Integer
Check_err = 0
If Len(strsvname) = 0 Then
MsgBox ("サーバ名が設定されていません(serverプロパティ)"), vbOKOnly, Pname
Exit Function
ElseIf Len(strfrom) = 0 Then
MsgBox ("From名が設定されていません(fromプロパティ)"), vbOKOnly, Pname
Exit Function
ElseIf Len(strsubj) = 0 Then
MsgBox ("Subjが設定されていません(subjプロパティ)"), vbOKOnly, Pname
Exit Function
ElseIf Len(strbody) = 0 Then
MsgBox ("Bodyが設定されていません(bodyプロパティ)"), vbOKOnly, Pname
Exit Function
End If
On Error GoTo err2
basp21.filecheck ("1") ' basp21 の初期設定チェック
Check_err = 1
exitfunc:
Exit Function
err2:
On Error GoTo err3
Set basp21 = CreateObject("basp21") ' BASP21の初期化
Resume Next
err3:
MsgBox ("BASP21が正しくインストールされていません"), vbOKOnly, Pname
Resume exitfunc
End Function
Public Function ReadBody(ByVal filename As String)
Dim fno As Integer, str As String
ReadBody = 0
On Error GoTo err4
fno = FreeFile()
Open filename For Input As #fno
strbody = ""
Do While Not EOF(fno)
Line Input #fno, str
strbody = strbody & str & vbCrLf
Loop
ReadBody = 1
exitsub:
Exit Function
err4:
MsgBox (filename & " をオープンできません"), vbOKOnly, Pname
Resume exitsub
End Function
Public Sub SendAll(ByVal tblname As String, ByVal colname As String)
If Check_err() = 0 Then Exit Sub
Dim db As Database, rs As Recordset
Set db = CurrentDb()
Dim sql As String
Dim mailto As Variant, body As Variant, ret As Variant
Dim ctr As Integer
ctr = 0
body = strbodyheader & strbody
Debug.Print body
sql = "select " & colname & " from " & tblname
Set rs = db.OpenRecordset(sql, dbOpenDynaset)
rs.MoveFirst
Do While Not rs.EOF
If Not IsNull(rs(0)) Then
mailto = rs(0)
Debug.Print mailto
ret = basp21.SendMail(strsvname, mailto, strfrom, strsubj, _
body, strfiles)
If Len(ret) <> 0 Then
Dim ok As Integer
ok = MsgBox("SendMailエラー " & ret & vbCrLf & "続行しますか", _
vbOKCancel, Pname)
If ok <> vbOK Then Exit Sub
Else
ctr = ctr + 1
End If
End If
rs.MoveNext
Loop
MsgBox ctr & " 件のメールを送信しました。", vbOKOnly, Pname
End Sub
Public Function SendMail(ByVal mailto As String, Optional pbodyheader, _
Optional pbody, Optional pfiles) As String
SendMail = ""
If Not IsMissing(pbodyheader) Then
strbodyheader = pbodyheader
End If
If Not IsMissing(pbody) Then
strbody = pbody
End If
If Not IsMissing(pfiles) Then
strfiles = pfiles
End If
mailto = Trim(mailto)
If Len(mailto) = 0 Then
MsgBox "mailto を指定してください", vbOKOnly, Pname
Exit Function
End If
If Check_err() = 0 Then Exit Function
Dim body As Variant, ret As Variant
body = strbodyheader & strbody
Debug.Print body
Debug.Print mailto
ret = basp21.SendMail(strsvname, mailto, strfrom, strsubj, _
body, strfiles)
SendMail = ret
End Function
|
Bacs使用例２ SendMailメソッド
顧客マスタを読んで本文の前に名前を追加して、同報送信する例を紹介します。
Option Compare Database
Option Explicit
Sub test2()
Dim bacs1 As New bacs1
bacs1.Server = "smtpserver"
bacs1.From = "who@who.com"
bacs1.subj = "subject 4"
If bacs1.ReadBody("c:\aa.txt") <> 1 Then
MsgBox "file read err"
Exit Sub
End If
Dim db As Database, rs As Recordset
Set db = CurrentDb()
Dim sql As String
Dim mailto As Variant, body As Variant, ret As Variant, names As Variant
Dim ctr As Integer
ctr = 0
sql = "select cemail,cname from master"
Set rs = db.OpenRecordset(sql, dbOpenDynaset)
rs.MoveFirst
Do While Not rs.EOF
If Not IsNull(rs(0)) Then
mailto = rs(0): names = rs(1)
ret = bacs1.SendMail(mailto, names & "様" & vbCrLf)
If Len(ret) <> 0 Then
Dim ok As Integer
ok = MsgBox("SendMailエラー " & ret & vbCrLf & "続行しますか", _
vbOKCancel, "mail2")
If ok <> vbOK Then Exit Sub
Else
ctr = ctr + 1
End If
End If
rs.MoveNext
Loop
MsgBox ctr & " 件のメールを送信しました。", vbOKOnly, "mail2"
End Sub
|