Option Explicit

Const MSFAXHAKIDAME = "C:\Documents and Settings\All Users\Documents\My Faxes\Sent Faxes"
'↑はっきり分からない場合はへたにもっともらしいディレクトリ入れるより空文字""にしちゃったほうがいいかも

Const CLOOPCNT = 100

Dim MyArgs
Dim MyStrThisVBSFullPath, MyStrSendFile, MyStrFAXNum
Dim MyFSO, MyFolder
Dim MyFSizeBeforeSendFAX
Dim MyStrWinVer, MyStrPC
Dim MyFaxServer, MyFaxDoc
Dim MyChk
Dim MyInc
Dim MyAllFiles, MyFile
Dim MyDT
Dim MyStrMSFaxLatestFile, MyStrExt, MyStrNewSaveDir, MyStrNewSaveFile
    
On Error Resume Next

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

MyStrSendFile = GetStrFileAfterDD(MyStrSendFile)
'↑これによって doc(Word), xls(Excel), html などのファイルをテキストに変換
'(混雑緩和のため処理は下のほうに隔離)

If MyStrSendFile = "" Then
    MsgBox "このファイルはたぶんダメ"
    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
        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

If MyChk = False Then
    WScript.Quit
End If

MyChk = False
For MyInc = 1 To CLOOPCNT
    WScript.Sleep (5000)    
    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
        MyFSO.CopyFile MyStrMSFaxLatestFile, MyStrNewSaveFile
        MyChk = True
        Exit For
    End If
Next
Set MyFolder = Nothing
Set MyFSO = Nothing
If MyChk = True Then
    MsgBox "完了"
Else
    MsgBox "失敗"
End If
WScript.Quit

'以下、混雑緩和のために隔離した関数いくつか

Function GetStrFileAfterDD(strFile)
'テキストとみなすことが出来そうだったらtxtファイルに変換
'処理の過程でダメなものは蹴っていく(ファイルパスとして空文字列が返る)
'テキストじゃないファイルもこの関数を通るけど、こちらは素通り。元と同じファイルパスが返る
    Dim MyStrTmpTextFile, MyStrExt, MyStrFromTextFile
    Dim MyFSO, MyFile
    Dim MyChkTXT
    
    On Error Resume Next
    
    GetStrFileAfterDD = "" '返り値の初期値。途中で蹴られてExitしたものはすべてこの空文字になる
    
    MyStrTmpTextFile = Replace(WScript.ScriptFullName, WScript.ScriptName, "") & "tmp0.txt"
    'うまいことtxtファイルに変換できたら、一時ファイルとして、このパス名で保存
    '送信されるファイルもこれになる
    
    Set MyFSO = CreateObject("Scripting.FileSystemObject")
    MyStrExt = LCase(MyFSO.GetExtensionName(strFile)) 'ファイル名から拡張子取得
    If MyStrExt = "" Then
        '拡張子がついていないものは初めから問題にならないので蹴る。
        Set MyFSO = Nothing
        Exit Function
    End If
    If (MyStrExt = "doc") Or (MyStrExt = "xls") Or (MyStrExt = "htm") Or _
        (MyStrExt = "html") Or (MyStrExt = "vbs") Or (MyStrExt = "js") Or (MyStrExt = "txt") Then
        'テキストとみなすことができそうかどうか
        '他にもあるかもしれないけど、そもそもの目的がFAX送信と考えると、これだってやり過ぎ
        'vbsファイルやjsファイルをFAXで送ろうとする馬鹿がいるか?
        'といったようなこととは別に、
        'IsASCII(strFile)みたいな感じの一発ジャッジ関数があるならそのほうがいいような気もするけど
        '探すのも面倒だし、とりあえずこんなもんで
        MyChkTXT = True
    Else
        MyChkTXT = False
    End If
    If MyChkTXT = True Then
        Set MyFile = MyFSO.GetFile(strFile)
        If MyFile.Size > 100000 Then
            'テキストとみなすことができそうなファイルで100KBを超えるものは、この先が恐ろしいので蹴る。
            Set MyFile = Nothing
            Set MyFSO = Nothing
            Exit Function
        End If
        Set MyFile = Nothing
        If MyFSO.FileExists(MyStrTmpTextFile) = True Then
            MyFSO.DeleteFile MyStrTmpTextFile
        End If
    End If
    Set MyFSO = Nothing
    If MyChkTXT = True Then
        If (MyStrExt = "doc") Or (MyStrExt = "xls") Then
            If MyStrExt = "doc" Then
                Call TextFromWordDoc(strFile, MyStrTmpTextFile)
            Else
                Call TextFromExcelBook(strFile, MyStrTmpTextFile)
            End If
            If ReadALFromTextFile(MyStrTmpTextFile) = "" Then
                'doc,xls → txt の過程で何かエラーがあればここに落ち着くはず(たぶん)
                Exit Function
            End If
        Else
            If (MyStrExt = "htm") Or (MyStrExt = "html") Then
                MyStrFromTextFile = GetStrFromHtmlFile(strFile)
            Else
                MyStrFromTextFile = ReadALFromTextFile(strFile)
            End If
            If MyStrFromTextFile = "" Then
                Exit Function
            End If
            Set MyFSO = CreateObject("Scripting.FileSystemObject")
            Set MyFile = MyFSO.CreateTextFile(MyStrTmpTextFile, True)
            MyFile.Write MyStrFromTextFile
            MyFile.Close
            Set MyFile = Nothing
            Set MyFSO = Nothing
        End If
        GetStrFileAfterDD = MyStrTmpTextFile
    Else
        GetStrFileAfterDD = strFile
    End If
End Function

Function GetStrFromHtmlFile(strFile)
    Dim MyRegExp, MyMatch
    Dim MyRepBefore, MyRepAfter
    Dim MyInc, MyCnt
    Dim MyStrRtn
    
    On Error Resume Next
    MyStrRtn = ""
    Set MyRegExp = CreateObject("VBScript.RegExp")
    MyRegExp.Pattern = ">[^<>]+<"
    MyRegExp.Global = True
    MyRegExp.IgnoreCase = True
    Set MyMatch = MyRegExp.Execute(ReadALFromTextFile(strFile))
    MyCnt = MyMatch.Count
    For MyInc = 0 To MyCnt - 1
        MyStrRtn = MyStrRtn & MyMatch.Item(MyInc)
    Next
    Set MyMatch = Nothing    
    MyRepBefore = Array("<>", "<", ">", "&" & "nbsp;", "&" & "lt;", "&" & "gt;", "&" & "amp;")
    MyRepAfter = Array("", "", "", " ", "<", ">", "&")
    For MyInc = 0 To 6
        MyRegExp.Pattern = MyRepBefore(MyInc)
        MyStrRtn = MyRegExp.Replace(MyStrRtn, MyRepAfter(MyInc))
    Next
    Set MyRegExp = Nothing
    GetStrFromHtmlFile = MyStrRtn
End Function

Function ReadALFromTextFile(strFile)
    Dim MyFSO, MyTextFile
    Dim MyStrALL
    
    On Error Resume Next
    MyStrALL = ""
    Set MyFSO = CreateObject("Scripting.FileSystemObject")
    If MyFSO.FileExists(strFile) = True Then
        Set MyTextFile = MyFSO.OpenTextFile(strFile, 1)
        MyStrALL = MyTextFile.ReadAll
        MyTextFile.Close
        Set MyTextFile = Nothing
    End If
    Set MyFSO = Nothing
    ReadALFromTextFile = MyStrALL
End Function

Sub TextFromWordDoc(strWordDocFile, strTmpTextFile)
    Dim MyWordApp, MyWordDoc
   
    On Error Resume Next
    Set MyWordApp = CreateObject("Word.Application")
    Set MyWordDoc = MyWordApp.Documents.Open(strWordDocFile)
    MyWordDoc.SaveAs strTmpTextFile, 2
    MyWordDoc.Close
    MyWordApp.Quit
    Set MyWordApp = Nothing
    Set MyWordDoc = Nothing
End Sub

Sub TextFromExcelBook(strExcelBookFile, strTmpTextFile)
    Dim MyExcelApp, MyExcelBook
    
    On Error Resume Next
    Set MyExcelApp = CreateObject("Excel.Application")
    Set MyExcelBook = MyExcelApp.WorkBooks.Open(strExcelBookFile, 1)
    MyExcelBook.SaveAs strTmpTextFile, 36
    MyExcelBook.Close (False)
    MyExcelApp.Quit
    Set MyExcelApp = Nothing
    Set MyExcelBook = Nothing
End Sub