wsh-vbsでFAX送信ついでに送信履歴までもっともらしくデータ化して管理するふりなんかしてみたり

戻る

当たり前の話ですが、送信するにあたって、相手先のFAX番号の入力は求めません。
VBSファイルに、送りたいファイルをDragDropしたら、ただちに送信処理に入ります。
だからといってコード中にFAX番号を直埋め込みするわけでもありません。
20人いたら20個のVBSファイルを用意することになりますが、相手がどこの誰だろうと中身は一緒、すべて下のコードです。

FAX番号はVBSファイル名に埋め込んでしまいましょう。
そのほうが間違いが起こりにくい。

というわけで、メモ帳にコードを貼り付けて保存するさい、ファイル名の右側14文字は FAX番号10桁.vbsになるようにしてください。
("faxto玉虫厨子商会_0345678912.vbs" みたいなカタチ)
右側14文字から.vbsを削った残りの10文字が全部数字じゃなければ処理途中で蹴ります。

あと、FAX機能そのものは、すでに入っているMSFAXを利用することになるんで、何から何までコード書きだけで制御できるわけじゃないです。
送信履歴の保存場所なんてのもその一つ。
これは完全にMSFAX側の支配下にあって、こっちからの命令はきいてくれません(たぶん)
あっちの都合にこっちの命令文を合わせるしかない。
合わせるしかないんですが、このMSFAXの送信履歴保存場所ってのは見るも無残な掃き溜めフォルダーで、そのまま利用するのは難しい(データとしてはまるで使い物になりません)
多少の無理をしてでも、こっちの都合にあわせた履歴保存の形式を新たにでっち上げたいところです。
もちろん、新たにでっち上げるにしても、元になるのはその掃き溜めフォルダなんで、とりあえずそれをさがして(またはMSFAX側のUIで設定して)下のコード中の Const MSFAXHAKIDAME = " --- " に突っ込んでください。

送信履歴の管理なんていらない、ただDragDropで送れればいいってことなら Const MSFAXHAKIDAME = は空文字でもデタラメでもいいんですが、そういうことなら、下のような長いコードは不要。これぐらいで充分でしょう。

逆に、これではまだ不満、エクセルやワードやhtmlファイルなんかもDragDrop送信できなきゃダメだ、と思う方はこちらへ。

Option Explicit

Const MSFAXHAKIDAME = "C:\Documents and Settings\All Users\Documents\My Faxes\Sent Faxes"
'↑
'MSFAXの送信履歴保存場所はたぶんマシンによって違う
'(もしかしたらこのどちらでもないかもしれない。分からなかったら適当なデタラメか空文字でも)
'↓
'Const MSFAXHAKIDAME = "C:\Documents and Settings\All Users\Application Data\Microsoft\Windows NT\MSFax\SentItems"

Const CLOOPCNT = 100

Dim MyArgs 'Object
Dim MyStrThisVBSFullPath, MyStrSendFile, MyStrFAXNum '文字列
Dim MyFSO, MyFolder 'Object
Dim MyFSizeBeforeSendFAX '長整数(送信直前の、MSFAX履歴保存フォルダーのサイズ)
Dim MyStrWinVer, MyStrPC '文字列
Dim MyFaxServer, MyFaxDoc 'Object
Dim MyChk 'Boolean 2ヶ所で使いまわし。「履歴管理やる気ありなし」、「送信後の履歴取り込み成功失敗」
Dim MyInc '長整数(ループカウンター)
Dim MyAllFiles, MyFile 'Object
Dim MyDT '日付
Dim MyStrMSFaxLatestFile, MyStrExt, MyStrNewSaveDir, MyStrNewSaveFile '文字列
    
On Error Resume Next 'どんなエラーが出ても前へ前へ、突き進め

Set MyArgs = WScript.Arguments
MyStrSendFile = MyArgs(0) 'DragDropされたファイルのフルパス取得
Set MyArgs = Nothing
If MyStrSendFile = "" Then
    MsgBox "何かファイルをDragDropしろって", vbOKOnly, "ダブルクリックじゃなく"
    WScript.Quit
End If

MyStrThisVBSFullPath = WScript.ScriptFullName
MyStrFAXNum = Left(Right(MyStrThisVBSFullPath, 14), 10)
If IsNumeric(MyStrFAXNum) = False Then
    MsgBox "数字以外の文字が入ったFAXナンバーなんて絶対変"
    WScript.Quit
End If

MyChk = False '履歴管理をする気があるかどうか判定
If MSFAXHAKIDAME <> "" Then '空文字じゃないなら見込みあり
    Set MyFSO = CreateObject("Scripting.FileSystemObject")
    If MyFSO.FolderExists(MSFAXHAKIDAME) = True Then 'それが確かに存在するフォルダなら「やる気あり」で決定
        Set MyFolder = MyFSO.GetFolder(MSFAXHAKIDAME)
        MyFSizeBeforeSendFAX = MyFolder.Size '送信前の、MSFAX掃き溜めフォルダのサイズ
        MyChk = True
    Else
        Set MyFSO = Nothing
    End If
End If

MyStrWinVer = CreateObject("Wscript.Shell").RegRead("HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\CurrentVersion")
MyStrPC = CreateObject("WScript.Network").ComputerName
If MyStrWinVer = "5.0" Then
    Set MyFaxServer = CreateObject("FaxServer.FaxServer")
    MyFaxServer.Connect MyStrPC
    Set MyFaxDoc = MyFaxServer.CreateDocument("FaxDocument")
    MyFaxDoc.filename = MyStrSendFile
    MyFaxDoc.FaxNumber = MyStrFAXNum
    MyFaxDoc.Send
    MyFaxServer.Disconnect
Else
    Set MyFaxServer = CreateObject("FAXCOMEX.FaxServer")
    MyFaxServer.Connect MyStrPC
    Set MyFaxDoc = CreateObject("FAXCOMEX.FaxDocument")
    MyFaxDoc.Recipients.Add MyStrFAXNum
    MyFaxDoc.Body = MyStrSendFile
    MyFaxDoc.ConnectedSubmit MyFaxServer
    MyFaxServer.Disconnect
End If
Set MyFaxDoc = Nothing
Set MyFaxServer = Nothing
'「履歴管理やる気あり」の場合、FAX起動でコケても次のループ処理には入っちゃう(On Error Resume Next)
'どうせ見えないところでこそこそ動いているだけだし、時間がくれば勝手に終わるんだし、放っておいても大した害はないような気がする(たぶん)


If MyChk = False Then
'履歴管理やる気なしならここでおしまい
    WScript.Quit
End If


MyChk = False '送信後の履歴取り込み成功失敗判定
For MyInc = 1 To CLOOPCNT
    WScript.Sleep (5000) '5秒おきにMSFAX掃き溜めフォルダのサイズをはかる
    
    If MyFolder.Size > MyFSizeBeforeSendFAX Then '送信前よりサイズが増えていたらそれは送信完了の証
    
        MyDT = Date - 10000 '←初期値は古ければ何でもいい
        Set MyAllFiles = MyFolder.Files
        For Each MyFile In MyAllFiles
            If MyFile.DateCreated > MyDT Then
                MyDT = MyFile.DateCreated
                MyStrMSFaxLatestFile = MyFile.Path
            End If
        '掃き溜め中いちばん新しいファイルを取得
        Next
        Set MyAllFiles = Nothing
        Set MyFile = Nothing
                 
        MyStrExt = MyFSO.GetExtensionName(MyStrMSFaxLatestFile) '拡張子取得
        
        MyStrNewSaveDir = Left(MyStrThisVBSFullPath, Len(MyStrThisVBSFullPath) - 4)
        If MyFSO.FolderExists(MyStrNewSaveDir) = False Then '履歴保存用として分かりやすい場所を用意
            MyFSO.CreateFolder (MyStrNewSaveDir)
        End If
        
        MyStrNewSaveFile = MyStrNewSaveDir & "\" & _
                            Replace(Replace(Replace(FormatDateTime(Now, 0), "/", "-"), ":", "-"), " ", "-") & _
                            "." & MyStrExt
        '履歴ファイルとして分かりやすい名前をつけたうえ、用意した分かりやすい場所に、MSFAXの掃き溜めからコピー
        MyFSO.CopyFile MyStrMSFaxLatestFile, MyStrNewSaveFile
        MyChk = True '履歴取り込み完了
        Exit For
    End If
Next
Set MyFolder = Nothing
Set MyFSO = Nothing
If MyChk = True Then
    MsgBox "完了"
Else
    'コードのアタマのほうで、CLOOPCNTはとりあえず100にしてある(もちろん設定は自由)
    'フォルダサイズ測定5秒おきに100回やって、それでもTrueが得られなかったら失敗のメッセージ出しちゃっていいんじゃね?
    MsgBox "失敗"
End If

Option Explicit以下↑まで全部コピーしてメモ帳に貼り付けたうえ、"XXXX0123456789.vbs" の形の名前で保存。

さて次に考えるべきは、中身が全部一緒で名前だけが違うファイルばかりがぞろっとあるこの手のソフト(これをソフトと呼ぶか?)で、変更の必要が生じたらどうすればいいのか、ということ。
"C:\Documents and Settings\All Users\Documents\My Faxes\Sent Faxes" を "C:\Documents and Settings\All Users\Application Data\Microsoft\Windows NT\MSFax\SentItems" に書き換えたいとか、擬似タイマーのループカウントを100じゃなく200にしたいとか。

そういう事態が生じると、人間のデキが問われているような気分になりますね。

(1)VBSファイルが何十個あろうが一つずつ地道に書き換える。
(2)自動で一気に書き換える方法を考える。
(3)もう面倒だからFAXなんて使うのやめちゃおうかと考える。

社会人としていちばんまともなのはいうまでもなく(3)のタイプです。
ファックスなんて時代遅れのシステム相手にこれ以上無駄な時間を費やすのは馬鹿げています。
同じ理由で、いちばんダメな人間ってのはたぶん(2)のタイプです。
ファイルが数十個程度で、よほど細かい修正じゃなければ、きっと(1)のほうが速い。

個人的には、何となく(2)を支持したい気分です。

文字列を指定したうえ、この文字列を見つけたら片っ端からこんなふうに書き換えろ、みたいな方法でもいいんですが、場合によっては違うやり方を選んだほうがいいかもしれません。
どのファイルも中身は一緒と考えると、書き換えの繰り返し処理ってのは何だか野暮ったい。
見本となる種ファイル一個用意して、そこからクローン増殖させる、みたいなやり方のほうが気分はいいんじゃないでしょうか。

ただ増殖型の方法だと、プログラムとしては殆ど応用が利きません。
たぶんこのケースでしか使えない。
見つけしだい片っ端から書き換え型のほうは、ちょっと条件を変えればいろんなケースで使えそうです。

あと、処理速度なんてことを問題にする人はそんなにいないと思いますけど、量が膨大になった場合はどう考えてもクローン増殖型のほうが速いはずです(バカバカしくて実験する気にはなれない)
文字列検索なんてしないまま問答無用で種ファイルの中身を押し込んでいくわけですから。

以下、見つけしだい片っ端から書き換え型。
書き換えたいファイル群と同じフォルダ内に置いてダブルクリックすると、「自分以外の」全てのvbsファイルの中身を書き換えます。
BEFORE_RP と AFTER_RP に適当な文字列を突っ込んで使ってください。
If LCase(Right(strFPath, 4)) = ".vbs" Then のところは、".txt" でも ".htm" でも、要はvbsに限らずテキストファイルなら何でもOK。

Option Explicit

Const BEFORE_RP = "この文字列を書き換えたい"
Const AFTER_RP = "こんなふうに書き換えたい"

Dim MyFSO, MyFolder, MyALLFiles, MyFile
Dim MyStrCurrDir, MyStrThisVBSFull, MyStrThisVBSName

MyStrThisVBSFull = WScript.ScriptFullName
MyStrThisVBSName = WScript.ScriptName
MyStrCurrDir = Replace(MyStrThisVBSFull, MyStrThisVBSName, "")
MyStrCurrDir = Left(MyStrCurrDir, Len(MyStrCurrDir) - 1)
Set MyFSO = CreateObject("Scripting.FileSystemObject")
Set MyFolder = MyFSO.GetFolder(MyStrCurrDir)
Set MyALLFiles = MyFolder.Files
For Each MyFile In MyALLFiles
    If MyFile.Path <> MyStrThisVBSFull Then
        Call RpTXT(MyFSO, MyFile.Path, BEFORE_RP, AFTER_RP)
    End If
Next
Set MyFile = Nothing
Set MyALLFiles = Nothing
Set MyFolder = Nothing
Set MyFSO = Nothing
MsgBox "完了"
WScript.Quit

Sub RpTXT(objFSO, strFPath, strBeforeRp, strAfterRp)
    Dim MyTXTFILE
    Dim MyStrALL

    If LCase(Right(strFPath, 4)) = ".vbs" Then
        Set MyTXTFILE = objFSO.OpenTextFile(strFPath, 1)
        MyStrALL = MyTXTFILE.ReadAll
        MyTXTFILE.Close
        Set MyTXTFILE = Nothing
        MyStrALL = Replace(MyStrALL, strBeforeRp, strAfterRp)
        Set MyTXTFILE = objFSO.CreateTextFile(strFPath, True)
        MyTXTFILE.Write MyStrALL
        MyTXTFILE.Close
        Set MyTXTFILE = Nothing
    End If
End Sub

以下、クローン増殖型。
書き換えたいファイル群と同じフォルダ内に置いて、見本となる種ファイルをDragDropしてください(種ファイルはべつに同フォルダ内じゃなくても)

Option Explicit

Dim MyStrSrcFile, MyStrALL, MyStrThisVBSFull, MyStrCurrDir, MyStrFile
Dim MyArgs, MyFSO, MyTXTFILE, MyFolder, MyALLFiles, MyFile

On Error Resume Next

Set MyArgs = WScript.Arguments
MyStrSrcFile = MyArgs(0)
Set MyArgs = Nothing
If MyStrSrcFile = "" Then
    MsgBox "種ファイルをDragDropしろって", vbOKOnly, "ダブルクリックじゃなく"
    WScript.Quit
End If

Set MyFSO = CreateObject("Scripting.FileSystemObject")
Set MyTXTFILE = MyFSO.OpenTextFile(MyStrSrcFile, 1)
MyStrALL = MyTXTFILE.ReadAll
MyTXTFILE.Close
Set MyTXTFILE = Nothing

MyStrThisVBSFull = WScript.ScriptFullName
MyStrCurrDir = Replace(MyStrThisVBSFull, WScript.ScriptName, "")
MyStrCurrDir = Left(MyStrCurrDir, Len(MyStrCurrDir) - 1)
Set MyFolder = MyFSO.GetFolder(MyStrCurrDir)
Set MyALLFiles = MyFolder.Files
For Each MyFile In MyALLFiles
    MyStrFile = MyFile.Path
    If LCase(Right(MyStrFile, 4)) = ".vbs" Then
        If (MyStrFile <> MyStrThisVBSFull) And (MyStrFile <> MyStrSrcFile) Then
            Set MyTXTFILE = MyFSO.CreateTextFile(MyStrFile, True)
            MyTXTFILE.Write MyStrALL
            MyTXTFILE.Close
            Set MyTXTFILE = Nothing
        End If
    End If
Next
Set MyFile = Nothing
Set MyALLFiles = Nothing
Set MyFolder = Nothing
Set MyFSO = Nothing
MsgBox "完了"