'***************************************************************************************************
' メール送信機能サンプル(ASPページ呼び出し) Module1(Module)
'
' 作成者:井上治 URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'変更日付 Rev 変更履歴内容------------------------------------------------------------------------>
'07/12/18(1.00)新規作成
'18/07/11(1.01)*.xlsm化
'20/03/02(1.02)コード整理、他
'***************************************************************************************************
Option Explicit
Option Private Module
'===================================================================================================
' 送信ページの指定(実際の環境に合わせて変更して下さい)
Const g_cnsMailUrl As String = "http://localhost/MailSend.asp"
'***************************************************************************************************
' ■■■ ワークシート側ボタンからの呼び出し処理 ■■■
'***************************************************************************************************
'* 処理名 :SendMail_for_ASP
'* 機能 :メール送信(ASPページ呼び出し)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2007年12月18日
'* 作成者 :井上 治
'* 更新日 :2020年03月02日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Public Sub SendMail_for_ASP()
'-----------------------------------------------------------------------------------------------
Dim lngRow As Long ' 行番号
Dim lngRowEnd As Long ' 最終行番号
Dim strMassage As String ' 送信メッセージ(全体)
Dim strBody As String ' 本文
Dim strRes As String ' 処理結果
'---------------------------------------------------------------------------
' POSTメッセージの編集(URLエンコードは外部関数化)
strMassage = "TXT_FROM=" & FP_Encode_URL(Cells(1, 2).Value) & _
"&TXT_TO=" & FP_Encode_URL(Cells(2, 2).Value)
' CC
If Cells(3, 2).Value <> "" Then
strMassage = strMassage & "&TXT_CC=" & FP_Encode_URL(Cells(3, 2).Value)
End If
' BCC
If Cells(4, 2).Value <> "" Then
strMassage = strMassage & "&TXT_BCC=" & FP_Encode_URL(Cells(4, 2).Value)
End If
' 本文
strBody = Cells(6, 2).Value
lngRow = 7
lngRowEnd = Cells(26, 2).End(xlUp).Row
' 本文(2行目以降)
Do While lngRow <= lngRowEnd
strBody = strBody & vbCrLf & Cells(lngRow, 2).Value
lngRow = lngRow + 1
Loop
strMassage = strMassage & "&TXT_SUBJ=" & FP_Encode_URL(Cells(5, 2).Value) & _
"&TXT_BODY=" & FP_Encode_URL(strBody)
'---------------------------------------------------------------------------
' POST送信(MSXML2の実行時バインド)
With CreateObject("MSXML2.XMLHTTP")
.Open "POST", g_cnsMailUrl, False
.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.Send (strMassage)
strRes = .ResponseText
End With
If Trim(strRes) <> "" Then MsgBox strRes
End Sub
'***************************************************************************************************
' ■■■ サブ処理(Private) ■■■
'***************************************************************************************************
'* 処理名 :FP_Encode_URL
'* 機能 :URLエンコード処理(BASP21利用)
'---------------------------------------------------------------------------------------------------
'* 返り値 :変換後文字列(String)
'* 引数 :Arg1 = 変換前文字列(String)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2007年12月18日
'* 作成者 :井上 治
'* 更新日 :2020年03月02日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Function FP_Encode_URL(ByRef strSource As String) As String
'-----------------------------------------------------------------------------------------------
Static objBASP21 As Object ' BASP21
' 初回オブジェクト取得
If objBASP21 Is Nothing Then
Set objBASP21 = CreateObject("BASP21")
End If
' URLエンコード
FP_Encode_URL = objBASP21.Base64(strSource, 4)
End Function
'----------------------------------------<< End of Source >>----------------------------------------
フォームを取り扱うために「
' POST送信(MSXML2の実行時バインド)
With CreateObject("MSXML2.XMLHTTP")
.Open "POST", g_cnsMailUrl, False
.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.Send (strMessage)
strRes = .ResponseText
End With
これだけに集約されています。
'***************************************************************************************************
' ■■■ サブ処理(Private) ■■■
'***************************************************************************************************
'* 処理名 :FP_Encode_URL
'* 機能 :URLエンコード処理(独自記述)
'---------------------------------------------------------------------------------------------------
'* 返り値 :変換後文字列(String)
'* 引数 :Arg1 = 変換前文字列(String)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2007年12月18日
'* 作成者 :井上 治
'* 更新日 :2020年03月02日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Function FP_Encode_URL(ByRef strSource As String) As String
'-----------------------------------------------------------------------------------------------
Const cnsPer As String = "%"
Const cnsZero As String = "0"
Dim lngLenB As Long ' バイト長
Dim lngIx As Long ' テーブルINDEX
Dim bytChar As Byte ' 1バイト分WORK
Dim bytTbl() As Byte ' バイト配列
Dim strBuf As String ' 変換後WORK
FP_Encode_URL = ""
lngLenB = LenB(StrConv(strSource, vbFromUnicode))
' ブランクの場合は終了
If lngLenB < 1 Then Exit Function
'---------------------------------------------------------------------------
' 入力文字列をバイト配列に格納
ReDim bytTbl(lngLenB - 1)
bytTbl = StrConv(strSource, vbFromUnicode)
'---------------------------------------------------------------------------
' 文字列全体を繰り返す
Do While lngIx < lngLenB
' 配列から1Byte取り出す
bytChar = bytTbl(lngIx)
' 出力文字列を編集
If (((bytChar >= &H81) And (bytChar <= &H9F)) Or _
((bytChar >= &HE0) And (bytChar <= &HEF))) Then
' 2バイト文字の1バイト目の処理
GoSub Encode_URL_SUB
lngIx = lngIx + 1
' 後半バイトがない場合は終了
If lngIx >= lngLenB Then Exit Do
' 2バイト文字の2バイト目の処理
bytChar = bytTbl(lngIx)
GoSub Encode_URL_SUB
ElseIf bytChar = &H20 Then
' 半角空白文字
strBuf = strBuf & "+"
ElseIf (((bytChar >= &H40) And (bytChar <= &H5A)) Or _
((bytChar >= &H61) And (bytChar <= &H7A)) Or _
((bytChar >= &H30) And (bytChar <= &H39)) Or _
(bytChar = &H2A) Or (bytChar = &H2D) Or _
(bytChar = &H2E) Or (bytChar = &H5F)) Then
' 変換不要文字(文字コードを戻す)
strBuf = strBuf & Chr(bytChar)
Else
' その他(変換出力)
GoSub Encode_URL_SUB
End If
' 次へ
lngIx = lngIx + 1
Loop
' 変換結果を返す
FP_Encode_URL = strBuf
Exit Function
'===================================================================================================
' 出力編集共通処理(Hex値出力)
Encode_URL_SUB:
strBuf = strBuf & cnsPer & Right(cnsZero & Hex(bytChar), 2)
Return
End Function
'----------------------------------------<< End of Source >>----------------------------------------
この関数の記述は調べた結果を元に作成していますが、