| |
仕事上で、メール送信をする必要があり
このサイト（http://www.hi-ho.ne.jp/babaq/basp21.html）
にて、ＢＡＳＰ２１で送信するマクロを作成しました。
しかし、宛先とＣＣの両方を指定して
複数送信したいのです。
具体的には、部長 は 宛先
課長や係長は ＣＣ
という感じです。
思考の渦に巻き込まれて先に、進めなくなりましたので
どなたか教えてください。
以下が、私の作成したマクロです。
ＢＡＳＰ２１のマクロから若干変更してあります
-----------------------------------------------------------------------
Dim ret As String
Dim szLogfile As String
Dim szServer As String, szTo As String, szFrom As String
Dim szSubject As String, szBody As String, szFile As String
Dim flBody
Dim i As Long
Dim fs, a As Object
Dim 宛先人数 As Variant
宛先人数 = Worksheets(1).Cells(1, 5)
Dim j As Variant
For j = 1 To 宛先人数
Worksheets(1).Cells(2 + j, 1) = "○"
Next j
On Error GoTo Err_Handler
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile(Worksheets("本文").Cells(15, 1), True)
' メール送信結果を記録するファイル名を指定します。
szServer = Worksheets("本文").Cells(11, 1) ' SMTPサーバ名
'
With Worksheets("宛名及び置換文字")
If .Cells(1, 3) & .Cells(1, 7) = "" Then
MsgBox "タイトルとＦＲＯＭを入力してください"
GoTo Exit_sub
Else
If MsgBox("タイトル：" & .Cells(1, 3) & "、送信元" & .Cells(1, 7) & "で良いですか？", _
vbOKCancel, "確認") = vbCancel Then
GoTo Exit_sub
End If
End If
szSubject = .Cells(1, 3) ' 件名
szFrom = .Cells(1, 7) ' 送信元
szTo = .Cells(3, 5) ' 宛先
If 宛先人数 > 1 Then ' cc アドレスがある場合は、それを 作成する
For i = 3 To 宛先人数
If .Cells(i, 1) = "○" Then
szTo = szTo & vbTab & "cc" & vbTab & .Cells(i, 5) ' 宛先
End If
Next i
End If ' cc アドレス作成終了
MsgBox szTo
GoTo owari99
szBody = .Cells(3, 6) ' 本文
szFile = .Cells(3, 11) '添付ファイル
ret = SendMail(szServer, szTo, szFrom, szSubject, szBody, szFile)
If Len(ret) <> 0 Then
a.WriteLine (Date & " " & Time & " " & ret & "−" & szTo & "−" & szBody)
'MsgBox "エラー" & ret & "−" & .Cells(i, 4)
.Cells(3, 1) = "エラー"
Else
.Cells(3, 1) = "完了"
End If
End With
' パラメータエラーのときは、戻り値にエラーメッセージが返ります。
MsgBox "終了"
GoTo Exit_sub
Err_Handler:
MsgBox Err.Description, vbCritical, "Error"
GoTo Exit_sub
Exit_sub:
a.Close
owari99:
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
- 05/12/10(土) 23:25 -
