BizFAXスマートキャスト(Mail to FAX)へVBSで送信

すごーくニッチな話なんだけど、BizFAXスマートキャストっていうNTTコミュニケーションズが提供してるFAX送受信サービスを使って帳票配信を自動化したいよーなんて相談がありました。

BizFAX スマートキャストとは

複合機から宛先ごとに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"