module1.bas

利用Microsoft 现有接口实现简单的传真功能

Attribute VB_Name = "Module1"
Dim strServerName As String
Dim strFilePath As String
Dim strFaxNumber As String
Dim strRecipientName As String

Sub Main()

Dim i As Long
Dim args As Variant         'EXE幚峴僷儔儊乕僞庢摼梡

args = GetCommandLine(4)

strServerName = Trim(args(1))
strFilePath = Trim(args(2))
strFaxNumber = Trim(args(3))
strRecipientName = Trim(args(4))

Call SendDocByFax

End Sub

Public Function GetCommandLine(Optional MaxArgs)
    ' 曄悢傪愰尵偟傑偡丅
    Dim c, CmdLine, CmdLnLen, InArg, i, NumArgs
    ' MaxArgs 偑採嫙偝傟傞偐偳偆偐傪挷傋傑偡丅
    If IsMissing(MaxArgs) Then MaxArgs = 1
    ' 尰嵼偺僒僀僘偺攝楍偵偟傑偡丅
    ReDim ArgArray(MaxArgs)
    
    NumArgs = 0: InArg = False
    ' 僐儅儞僪 儔僀儞偺堷悢傪庢摼偟傑偡丅
    CmdLine = Command()
    CmdLnLen = Len(CmdLine)
    ' 摨帪偵僐儅儞僪 儔僀儞偺堷悢傪庢摼偟傑偡丅

    For i = 1 To CmdLnLen
        c = Mid(CmdLine, i, 1)
        ' 僗儁乕僗傑偨偼僞僽傪挷傋傑偡丅
        If (c <> "," And c <> vbTab) Then
            ' 僗儁乕僗傑偨偼僞僽偺偄偢傟偱傕偁傝傑偣傫丅
            ' 婛偵堷悢偺拞偱偼側偄偐偳偆偐傪挷傋傑偡丅
            If Not InArg Then
            ' 怴偟偄堷悢偑巒傑傝傑偡丅
            ' 堷悢偑懡偡偓側偄偐傪挷傋傑偡丅
                If NumArgs = MaxArgs Then Exit For
                    NumArgs = NumArgs + 1
                    InArg = True
                End If

' 尰嵼偺堷悢偵暥帤傪捛壛偟傑偡丅
            ArgArray(NumArgs) = ArgArray(NumArgs) + c
        Else
            ' 僗儁乕僗傑偨偼僞僽傪尒偮偗傑偟偨丅
            ' InArg 僼儔僌偵 False 傪愝掕偟傑偡丅
            InArg = False
        End If
    Next i
    ' 堷悢偑偡傋偰奿擺偱偒傞傛偆偵攝楍偺僒僀僘傪曄峏偟傑偡丅
    ReDim Preserve ArgArray(NumArgs)
    ' 娭悢柤偵攝楍傪曉偟傑偡丅
    GetCommandLine = ArgArray()
End Function

Sub SendDocByFax()

    Dim FaxServer As Object
    Dim FaxDoc As Object
    Dim strFaxFileName As String
    Dim intPosition As Integer
    Dim writeFile As String
    Dim nowday As String
    
    nowday = FormatDateTime(Now, vbShortDate)
    nowday = Replace(nowday, "/", "")
    
    writeFile = "E:\project\huazhan\code\huazhanApp\WEB-INF\fax\FaxLog" + nowday + ".txt"

    strFaxFileName = getSendedFaxFileName(strFilePath, "\")
    
    On Error GoTo ErrorLine:
    
    'Create FaxServer object...
    Set FaxServer = CreateObject("FaxServer.FaxServer")
    '...and connect to it - no empty name allowed, should be name of your PC or any PC that you gona use to send a fax
    FaxServer.Connect (strServerName)
    'Message1
    Call writeFaxLogFile(writeFile, strFaxFileName, "正在发送中")
    
    'Create document
    Set FaxDoc = FaxServer.CreateDocument(strFilePath)
    
    FaxDoc.FaxNumber = strFaxNumber
    FaxDoc.RecipientName = strRecipientName
    
    'Here I'v got stuck...
    FaxDoc.Send
    
    Set FaxDoc = Nothing
    
    FaxServer.Disconnect
    
    Set FaxServer = Nothing
    
    'Message2
    Call writeFaxLogFile(writeFile, strFaxFileName, "发送成功")
    
    Exit Sub

ErrorLine:
    'Message3
    Call writeFaxLogFile(writeFile, strFaxFileName, "发送失败")
End Sub

Private Sub writeFaxLogFile(ByVal writeFile As String, ByVal writeFileName As String, ByVal writeMessage As String)
'Dim strReadFile As String

'Write File
Open writeFile For Append As #1
Print #1, CStr(Now) + "    " + writeFileName + writeMessage
Close #1
End Sub

Private Function getSendedFaxFileName(ByVal strFilePath As String, ByVal strFlag As String) As String
Dim intPosition, intTempPosition As Integer
Dim strFileName As String

intPosition = 1

Do While intPosition <> 0
intTempPosition = intPosition
intPosition = InStr(intPosition + 1, strFilePath, strFlag)
Loop

getSendedFaxFileName = Mid(strFilePath, intTempPosition + 1)
End Function