| |
初めて質問させて頂きます。
以前同じ職場にいた方がExcelで作成したメール配信ツールがあるのですが、
そのツールを改修して欲しいとの指示を受けました。
ExcelのVBAどころかプログラミングを行った経験はなく、何をどうやって良いか全く見当が付きません。
ただ理不尽な上司をギャフンと言わせてやりたいので、なんとかやり遂げたいと考えております。
Excelファイルの中でシートが3種類あり、「Format」「送信先リスト」「ログ」と分かれています。
1.「送信先リスト」の宛先(A列)にメールアドレスを入力し（アドレスはカンマを入れると複数入力が可能）
2.「Format」の宛先で”To””Cc””Bcc”のいずれかで送信するかを選択
3.「Format」の”メール送信”ボタンを押すとメールを送信
4.送信の結果が「ログ」に記載
上記の流れで送信できます。
今回改修を指示されたのは、現時点では”To””Cc””Bcc”いずれかしか選択できないのを、
”To””Cc””Bcc”それぞれメールアドレスを指定してメールを送れる様にしたいとの事でした。
Excelのプログラムの内容を添付しますので、なんとかお力を貸して頂けないでしょうか。
何卒宜しくお願い致します。
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
標準モジュール(mdlGlobal)
' メールアドレス（カンマで複数併記可）の正規表現
Public Const gcszRegIPAddress As String = "\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}"
Public Const gcszRegAsciiCode As String = "[\x01-\x7f]"
Public Const gcszRegDomain As String = "([\w\-]+\.)+[a-z]+"
Public Const gcszRegMailAddress As String = _
gcszRegAsciiCode & "+@(" & gcszRegIPAddress & "|" & gcszRegDomain & ")"
Public Const gcszRegMultiMailAddress As String = _
"^" & gcszRegMailAddress & "(," & gcszRegMailAddress & ")*$"
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
shtFormat(「Format」)
' メール送信
Private Sub cmdSendMail_Click()
Dim szSMTPServer As String
Dim szSubject As String, sztxtSubject As String
Dim szFrom As String, szReplyTo As String
Dim szTo As String, szCc As String, szBcc As String
Dim szAttachedFile As String, szAttachedPath As String
Dim szMessage As String, szMessageFormat As String
Dim rngAddress As Range
Dim szRet As String
Dim regReplaceCompany As RegExp, regReplacePost As RegExp
Dim regReplacePosition As RegExp, regReplaceName As RegExp
Dim regReplacePassword As RegExp, regMailAddress As RegExp
Dim regReplacePeriod As RegExp, regReplaceOthers_2 As RegExp
Dim regReplaceCompany_kenmei As RegExp
Dim iRet As Integer, lLogRow As Long
Application.EnableCancelKey = xlDisabled
' パラメータチェック
szRet = checkParameter
If szRet <> "" Then
' パラメータにエラーがあった場合、メッセージを表示して終了
MsgBox szRet, vbCritical, gcszValidateError
Exit Sub
End If
' 送信確認
If MsgBox(gcszSendMailCertify, vbOKCancel) <> vbOK Then
Exit Sub
End If
' 初期設定
szSMTPServer = txtSMTPServer.Value
sztxtSubject = txtSubject.Value
szFrom = txtFrom.Value
szReplyTo = txtReplyTo.Value
szTo = ""
szCc = ""
szBcc = ""
szAttachedFile = ""
If chkAttachedFile.Value = True Then
If optAttachedIndividual.Value = True Then
szAttachedPath = txtAttachedFileFolder.Value
If Right(szAttachedPath, 1) <> "\" Then
szAttachedPath = szAttachedPath & "\"
End If
ElseIf optAttachedCommon.Value = True Then
szAttachedFile = txtAttachedFileFolder.Value
End If
End If
szMessageFormat = txtMessage.Value
' 社名置換用正規表現
Set regReplaceCompany = New RegExp
regReplaceCompany.Pattern = "(^|[^" & gcszEscapeCharactor & "])(" & _
gcszReplaceCompany & ")"
regReplaceCompany.Global = True
' 部署置換用正規表現
省きます。
' 役職置換用正規表現
省きます。
' 名前置換用正規表現
省きます。
' パスワード置換用正規表現
省きます。
' その他1置換用正規表現
省きます。
' その他2置換用正規表現
省きます。
' メールアドレスチェック用正規表現
Set regMailAddress = New RegExp
regMailAddress.Pattern = gcszRegMultiMailAddress
' ログ出力開始行取得
lLogRow = shtLog.Cells(65536, 1).End(xlUp).Row + 1
Set rngAddress = shtSendList1.Cells(gciAddressStartRow, gciAddressColumn)
Do While rngAddress.Value <> ""
' 宛先リストが続く限り送信
' メールアドレスのチェック
If regMailAddress.Test(rngAddress.Value) = False Then
MsgBox gcszErrSendAddressWrong & rngAddress.Value, _
vbCritical, gcszValidateError
Exit Do
End If
' 送信先をオプションボタンに合わせて設定
If optAddressTo = True Then
szTo = rngAddress.Value
ElseIf optAddressCc = True Then
szCc = rngAddress.Value
ElseIf optAddressBcc = True Then
szBcc = rngAddress.Value
End If
' メッセージ置換（会社名、部署、役職、名前、パスワードを置換）
省きます。
' 二重エスケープを解決
szMessage = Replace(szMessage, _
gcszEscapeCharactor & gcszEscapeCharactor, gcszEscapeCharactor)
' 添付ファイルを設定
If chkAttachedFile.Value = True Then
If optAttachedIndividual.Value = True Then
szAttachedFile = szAttachedPath & _
shtSendList1.Cells(rngAddress.Row, gciFileNameColumn).Value
End If
' 添付ファイル有りメール送信
szRet = sendMailByCDO( _
szSMTPServer, szFrom, szTo, szCc, szBcc, _
szReplyTo, szSubject, szMessage, szAttachedFile)
Else
' 添付ファイル無しメール送信
szRet = sendMailByCDO( _
szSMTPServer, szFrom, szTo, szCc, szBcc, _
szReplyTo, szSubject, szMessage)
End If
' ログ出力
writeLog rngAddress.Value, _
shtSendList1.Cells(rngAddress.Row, gciNameColumn).Value, _
szRet, lLogRow
lLogRow = lLogRow + 1
If szRet <> "OK" Then
' 送信時エラー
' エラーメッセージを表示して終了
iRet = MsgBox(Mid(szRet, 3) + vbCr + gcszBeContinued, _
vbYesNo + vbCritical, gcszSendMailError)
If iRet = vbNo Then
Exit Do
End If
Else
End If
' 次のアドレスへ
Set rngAddress = rngAddress.Offset(1, 0)
Loop
If rngAddress.Value <> "" Then
' 送信失敗
MsgBox gcszMailSendFailed & vbCrLf & _
rngAddress.Row & "行目, " & rngAddress.Value & "にて失敗", _
vbExclamation, gcszMailSendFailed
Set rngAddress = Nothing
Else
' 送信成功
MsgBox gcszAllMailSendSuccessful, vbOKOnly, gcszAllMailSendSuccessful
End If
Application.EnableCancelKey = xlInterrupt
End Sub
'*******************************************************************************
' メール送信(CDO) ※参照設定:Microsoft CDO for Exchange 2000 Library
' Microsoft ActiveX Data Objects 2.x Library
'*******************************************************************************
' [引数]
'1.MailSmtpServer : SMTPサーバ名(又はIPアドレス)
'2.MailFrom : 送信元アドレス
'3.MailTo : 宛先アドレス(複数の場合はカンマで区切る)
'4.MailCc : CCアドレス(複数の場合はカンマで区切る)
'5.MailBcc : BCCアドレス(複数の場合はカンマで区切る)
'6.MailReplyTo : REPLY-TOアドレス
'7.MailSubject : 件名
'8.MailBody : 本文(改行はvbCrLf付加)
'9.MailAddFile : 添付ファイル(複数の場合はカンマで区切るか配列渡し) ※Option
'10.MailCharacter : 文字コード指定(デフォルトはShift-JIS) ※Option
' [戻り値]
'正常時："OK", エラー時："NG"+エラーメッセージ
'*******************************************************************************
Private Function sendMailByCDO(MailSmtpServer As String, _
MailFrom As String, _
MailTo As String, _
MailCc As String, _
MailBcc As String, _
MailReplyTo As String, _
MailSubject As String, _
MailBody As String, _
Optional MailAddFile As Variant, _
Optional MailCharacter As String) As String
Const cnsOK As String = "OK"
Const cnsNG As String = "NG"
Dim objCDO As New CDO.Message
Dim vntFILE As Variant
Dim IX As Long
Dim strCharacter As String, strBody As String, strChar As String
On Error GoTo SendMailByCDO_ERR
sendMailByCDO = cnsNG
' 文字コード指定の確認
If MailCharacter <> "" Then
' 指定ありの場合は指定値をセット
strCharacter = MailCharacter
Else
' 指定なしの場合はShift-JISとする
strCharacter = cdoShift_JIS
End If
' 本文の改行コードの確認
' Lfのみの場合Cr+Lfに変換
strBody = Replace(MailBody, vbLf, vbCrLf)
' 上記で元がCr+Lfの場合Cr+Cr+LfになるのでCr+Lfに戻す
MailBody = Replace(strBody, vbCr & vbCrLf, vbCrLf)
With objCDO
With .Configuration.Fields ' 設定項目
.Item(cdoSendUsingMethod) = cdoSendUsingPort ' 外部SMTP指定
.Item(cdoSMTPServer) = MailSmtpServer ' SMTPサーバ名
.Item(cdoSMTPServerPort) = 25 ' ポートNo.
.Item(cdoSMTPConnectionTimeout) = 60 ' タイムアウト
.Item(cdoSMTPAuthenticate) = cdoAnonymous ' 0
.Item(cdoLanguageCode) = strCharacter ' 文字セット指定
.Update ' 設定を更新
End With
.MimeFormatted = True
.Fields.Update
.From = MailFrom ' 送信者
If MailTo <> "" Then .To = MailTo ' 宛先
If MailCc <> "" Then .CC = MailCc ' CC
If MailBcc <> "" Then .BCC = MailBcc ' BCC
If MailReplyTo <> "" Then .ReplyTo = MailReplyTo ' Reply-to
.Subject = MailSubject ' 件名
.TextBody = MailBody ' 本文
.TextBodyPart.Charset = strCharacter ' 文字セット指定(本文)
' 添付ファイルの登録(複数対応)
If ((VarType(MailAddFile) <> vbError) And _
(VarType(MailAddFile) <> vbBoolean) And _
(VarType(MailAddFile) <> vbEmpty) And _
(VarType(MailAddFile) <> vbNull)) Then
If IsArray(MailAddFile) Then
For IX = LBound(MailAddFile) To UBound(MailAddFile)
.AddAttachment MailAddFile(IX)
Next IX
ElseIf MailAddFile <> "" Then
vntFILE = Split(CStr(MailAddFile), ",")
For IX = LBound(vntFILE) To UBound(vntFILE)
If Trim(vntFILE(IX)) <> "" Then
.AddAttachment Trim(vntFILE(IX))
End If
Next IX
End If
End If
.Send ' 送信
End With
Set objCDO = Nothing
sendMailByCDO = cnsOK
Exit Function
'-------------------------------------------------------------------------------
SendMailByCDO_ERR:
sendMailByCDO = cnsNG & Err.Number & " " & Err.Description
On Error GoTo 0
Set objCDO = Nothing
End Function
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
- 11/6/5(日) 15:57 -
