すごーくニッチな話なんだけど、BizFAXスマートキャストっていうNTTコミュニケーションズが提供してるFAX送受信サービスを使って帳票配信を自動化したいよーなんて相談がありました。
複合機から宛先ごとにFAXを送るのは大変だから、このクラウドFAX基盤からメールでデータ飛ばしてFAXでしか受付してくれないレガシーなお得意様へFAXデータを配信したいと。
このシステム、メールAPIの受け口としてメールにFAX送信先を入力したテキストと配信したい帳票のPDF or TIFFファイルを添付して送れば、その番号へFAXしてくれるらしい。
詳細なカスタマイズはともかく、とりあえず使えそうな感じにサンプルスクリプトだけ用意してみた。
前提として、メーラはOutlookちゃんです。
１カラム目にFAX送信先を入力したテキスト、２カラム目に配信したい帳票パスを入力したCSVファイルを、このvbsファイルにドラッグ＆ドロップするとCSVのリストを１行づつ読んでメールをバシバシ飛ばしますよ。
事前にファイルパスの存在確認だけして、無ければエラーログ出力します。
メール飛びまくるから、テストは自己責任でね・・・?
っても、事例がニッチすぎて参考になる人なんていないだろうけどもねぇ?
'■*************************************************************
'■* サンプル ～ BizFAXスマートキャスト Mail to FAX ～
'■* vbsファイルにファイルドロップで受け取ったCSVファイルを
'■* 一行づつ読込、ファイルを添付して、ひたすらメール配信
'■*************************************************************
Dim olk, mailTo, mailSubject, mailBody, Rslt, SendFlg
Dim CSV_Text, CSV_Lines, CSV_Cols
'■■■ CSVファイルリスト取得処理 ■■■
If WScript.Arguments.Count = 1 Then
CSV_File = WScript.Arguments(0)
Else
Msgbox "CSVファイルをドロップして起動して下さい。", vbInformation, "停止 - 起動方法が違います。"
WScript.Quit 0
End If
'■■■ メール関連 初期処理 ■■■
Set olk = CreateObject("Outlook.Application")
mailTo = "test@yizm.work"
mailSubject = "件名サンプル"
mailBody = "#userid=xxxxxx" & vbCrLf & “#passwd=xxxxx”
'■■■ リスト読込処理 ■■■
CSV_Text = Read_TEXT(CSV_File)
CSV_Lines = Split(CSV_Text, vbCrLf)
Rslt = True
For r=1 To UBound(CSV_Lines)
CSV_Cols = Split(Replace(CSV_Lines(r),"""",""), ",")
If UBound(CSV_Cols) = 1 Then
SendFlg = SendMailToFax(CSV_Cols(0), CSV_Cols(1))
Rslt = Rslt AND SendFlg
End If
Next
If Rslt Then
Msgbox "メール送信が完了しました。", vbInformation, "完了 - メールが送信されました。"
Else
Msgbox "送信されなかったメールがあります。" & vbCrLf & "ErrLog_Send_Mail.logを確認して下さい。", vbWarning, "警告 - 配信されなかったメールがあります。"
End If
'■■■ メール関連 終了処理 ■■■
Set olk = Nothing
WScript.Quit 0
'■■■ 以下、呼び出し関数 ■■■
'■ 呼び出し関数 - メール送信
Function SendMailToFax(mailAttach1, mailAttach2)
Dim item, objFS
If File_Exists2(mailAttach1, mailAttach2) Then
Set item = olk.CreateItem(0)
item.To = mailTo
item.Subject = mailSubject
item.Body = mailBody
item.Attachments.Add mailAttach1
item.Attachments.Add mailAttach2
'item.Display
item.Send
Set item = Nothing
SendMailToFax = True
Else
SendMailToFax = False
End If
End Function
'■ 呼び出し関数 - テキスト読込
Function Read_TEXT(FilePath)
Dim objFS, objTXT, Rslt
Set objFS = CreateObject("Scripting.FileSystemObject")
If objFS.FileExists(FilePath) Then
Set objTXT = objFS.OpenTextFile(FilePath, 1)
Rslt = objTXT.ReadAll()
objTXT.close
Set objTXT = Nothing
Else
Rslt = ""
End If
Set objFS = Nothing
Read_TEXT = Rslt
End Function
'■ 呼び出し関数 - テキスト追記
Function Append_TEXT(ContentStr, FilePath)
Dim objFS, objTXT
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objTXT = objFS.OpenTextFile(FilePath, 8, True)
objTXT.WriteLine ContentStr
objTXT.close
Set objTXT = Nothing
Set objFS = Nothing
End Function
'■ 呼び出し関数 - ファイル存在確認
Function File_Exists2(mailAttach1, mailAttach2)
Dim objFS, flg1, flg2, ErrPath
Set objFS = CreateObject("Scripting.FileSystemObject")
ErrPath = objFS.GetParentFolderName(WScript.ScriptFullName) & "\ErrLog_Send_Mail.log"
flg1 = objFS.FileExists(mailAttach1)
flg2 = objFS.FileExists(mailAttach2)
If Not flg1 Then Append_TEXT Now & ",ファイルが存在しませんでした。(" & mailAttach1 & ")", ErrPath
If Not flg2 Then Append_TEXT Now & ",ファイルが存在しませんでした。(" & mailAttach2 & ")", ErrPath
File_Exists2 = flg1 AND flg2
End Function
たとえば、こんなCSVをドロップすればメールがビュンビュン飛ぶわけだ。
宛先リスト,帳票パス "C:\Temp\attach_sample\address_3.txt","C:\Temp\attach_sample\aws_associate.pdf" "C:\Temp\attach_sample\address_4.txt","C:\Temp\attach_sample\aws_associate.pdf"