clsclient.cls

本书源码主要针对目前流行的FTP、HTTP、E-mail、Telnet、ICMP、Modem串口通信编程、拨号网络编程等内容进行详细的讲解

        Tstr = Tstr & vbCrLf & "Connection: close"
        Tstr = Tstr & vbCrLf & "Date: " & Format(Now, "ddd, yyyy-mm-dd hh:mm:ss GMT")
        Tstr = Tstr & vbCrLf & "Content-Type: " & MimeType
        Tstr = Tstr & vbCrLf & "Accept-Ranges: bytes"
        Tstr = Tstr & vbCrLf & "Last-Modified: " & FileTime
        If FileSize <> 0 Then
            Tstr = Tstr & vbCrLf & "Content-Length: " & FileSize
        End If
        Tstr = Tstr & vbCrLf & vbCrLf
    Case "404"
        '404文件未找到响应标题
        ResponseLine = "HTTP/1.1 404 Not Found"
        Tstr = ResponseLine
        Tstr = Tstr & vbCrLf & "Server: BigFox Server1.0"
        Tstr = Tstr & vbCrLf & "Connection: close"
        Tstr = Tstr & vbCrLf & "Date: " & Format(Now, "ddd, yyyy-mm-dd hh:mm:ss GMT")
        Tstr = Tstr & vbCrLf & "Content-Type: text/html"
        Tstr = Tstr & vbCrLf & vbCrLf
        Dim ErrorInfo As String
        If ReadTxtFile(RootPath & "\Nofound.htm", ErrorInfo) = True Then
            Tstr = Tstr & ErrorInfo
        Else
            Tstr = Tstr & "Sorry!请求的文件不存在" & vbCrLf
        End If
    Case "401"
        '401需要身份验证响应标题
        ResponseLine = "HTTP/1.1 401 Unauthorized"
        Tstr = ResponseLine
        Tstr = Tstr & vbCrLf & "Server: BigFox Server1.0"
        Tstr = Tstr & vbCrLf & "Connection: close"
        Tstr = Tstr & vbCrLf & "Date: " & Format(Now, "ddd, yyyy-mm-dd hh:mm:ss GMT")
        Tstr = Tstr & vbCrLf & "WWW-authenticate: basic realm=""Busyzhong's BigFox Server1.0"""
        Tstr = Tstr & vbCrLf & "Content-Type: " & MimeType
        If FileSize <> 0 Then
            Tstr = Tstr & vbCrLf & "Content-Length: " & FileSize
        End If
        Tstr = Tstr & vbCrLf & vbCrLf
End Select
AddHeader = Tstr
End Function

'读入文本文件
Public Function ReadTxtFile(FileName As String, FileContent As String, Optional FileSize As Long, Optional FileTime As String) As Boolean
If Len(Dir(FileName)) = 0 Then
    ReadTxtFile = False
    Exit Function
End If
FileTime = Format(FileDateTime(FileName), "ddd, yyyy-mm-dd hh:mm:ss")
Dim Fnum As Integer
Fnum = FreeFile()
Open FileName For Input As #Fnum
FileSize = LOF(Fnum)
FileContent = StrConv(InputB(LOF(Fnum), #Fnum), vbUnicode)
Close Fnum
ReadTxtFile = True
End Function

'读入二进制文件
Public Function ReadBinFile(FileName As String, ByteContent() As Byte, FileSize As Long, FileTime As String) As Boolean
If Len(Dir(FileName)) = 0 Then
    ReadBinFile = False
    Exit Function
End If
FileTime = Format(FileDateTime(FileName), "ddd, yyyy-mm-dd hh:mm:ss")
Dim Fnum As Integer
Fnum = FreeFile()
Open FileName For Binary As #Fnum
FileSize = LOF(Fnum)
ReDim SendDataB(FileSize)
Get #Fnum, , SendDataB()
Close Fnum
ReadBinFile = True
End Function

'处理POST数据内容的文件
Public Sub HandlePost()
Dim pos1, pos2 As Integer
Dim Boundary As String
Dim ContentType As String
Dim Tstr As String
While Boundary = "" And Abs(DateDiff("s", Time(), StartTime)) < MaxTime
    DoEvents: DoEvents: DoEvents
    If pos1 = 0 Then
        pos1 = InStr(1, ReceiveData, "Content-Type", vbTextCompare)
    End If
    If pos1 > 0 Then
        pos2 = InStr(pos1 + 1, ReceiveData, vbCrLf, vbTextCompare)
    End If
    If pos1 > 0 And pos2 > 0 Then
        Tstr = Mid(ReceiveData, pos1, pos2 - pos1)
        If InStr(1, Tstr, "multipart") > 0 Then
            pos1 = InStr(1, Tstr, "boundary=")
            '将boundary的内容取出来
            If pos1 > 0 Then
                pos2 = InStr(pos1, Tstr, " ")
                If pos2 = 0 Then
                    pos2 = InStr(pos1, Tstr, vbCrLf)
                End If
                If pos2 > 0 Then
                    Boundary = Mid(Tstr, pos1 + Len("boundary="), pos2 - pos1 - Len("boundary="))
                Else
                    Boundary = Mid(Tstr, pos1 + Len("boundary="))
                End If
                If Boundary <> "" Then
                    Boundary = Replace(Boundary, """", "")
                End If
            End If
        End If
    End If
Wend
'等待数据传送完毕
Do While True And Abs(DateDiff("s", Time(), StartTime)) < MaxTime
    DoEvents: DoEvents: DoEvents
    If InStr(1, ReceiveData, Boundary & "--") > 0 Then
        Exit Do
    End If
Loop
'数据传送完毕,从保存的临时文件中取出Browser提交的信息进行分析
Dim Tfile As String
Dim Fnum As Integer
Dim i As Integer
Dim myByte As Byte
Dim OutArray() As Byte
Dim LineStr As String
Dim SectData As String
Dim PostName As String, PostResume As String
Dim StPos As Long, EndPos As Long
Dim FileExtN As String
Dim TmpStr As String
Tfile = RootPath & "\temp\" & WinsockIndex & ".tmp"
Fnum = FreeFile()
If Dir(Tfile) <> "" Then
    Open Tfile For Input As #Fnum
    While Not EOF(Fnum)
        Line Input #Fnum, LineStr
        LineStr = LineStr & vbCrLf
        '遇到分隔字符串
        If LineStr = vbCrLf Then
            If SectData <> "" Then
                If InStr(1, SectData, "newfile") > 0 Then
                '得出当前文件的位置
                    If InStr(1, SectData, "filename=") > 0 Then
                        '下面是提取文件名
                        pos1 = InStr(1, SectData, "filename=")
                        pos2 = InStr(pos1 + 10, SectData, """")
                        If pos2 = 0 Then
                            pos2 = InStr(pos1 + 10, SectData, vbCrLf)
                        End If
                        If pos2 > pos1 Then
                            TmpStr = Mid(SectData, pos1 + 10, pos2 - pos1 - 10)
                        Else
                            TmpStr = Mid(SectData, pos1 + 10)
                        End If
                        pos1 = InStrRev(TmpStr, "\")
                        If pos1 > 0 Then
                            TmpStr = Mid(TmpStr, pos1 + 1)
                        End If
                    End If
                    StPos = Seek(Fnum)
                    EndPos = LOF(Fnum) - Len("--" & Boundary & "--") - 3
                End If
            End If
        End If
        
        If InStr(1, LineStr, "--" & Boundary) > 0 Then
            If SectData <> "" Then
                If InStr(1, SectData, "txtname") > 0 Then
                    pos1 = InStr(1, SectData, "txtname")
                    pos2 = InStr(pos1, SectData, vbCrLf & vbCrLf)
                    If pos2 > 0 Then
                        PostName = Mid(SectData, pos2 + 4)
                        PostName = Left(PostName, Len(PostName) - 2)
                    End If
                End If
                If InStr(1, SectData, "txtresume") > 0 Then
                    pos1 = InStr(1, SectData, "txtresume")
                    '找出数据与字段的分界
                    pos2 = InStr(pos1, SectData, vbCrLf & vbCrLf)
                    If pos2 > 0 Then
                        PostResume = Mid(SectData, pos2 + 4)
                        '删除vbcrlf
                        PostResume = Left(PostResume, Len(PostResume) - 2)
                    End If
                End If
            End If
            SectData = ""
        Else
            SectData = SectData & LineStr
        End If
    Wend
    Close (Fnum)
    '将上载的文件写到Uploadfile目录中
    If EndPos > StPos Then
        ReDim OutArray(EndPos - StPos - 2) As Byte
        Open Tfile For Binary As #Fnum
            Seek #Fnum, StPos
            Get #Fnum, , OutArray()
        Close (Fnum)
        Open RootPath & "\uploadfile\" & TmpStr For Binary As #Fnum
            Put #Fnum, , OutArray()
        Close (Fnum)
    End If
End If
End Sub

'验证身份
Private Function CheckPass() As Boolean
If InStr(1, ReceiveData, "Authorization:") > 0 And _
   InStr(1, ReceiveData, PassStr) > 0 Then
        CheckPass = True
Else
    CheckPass = False
End If
End Function

'生成进站时的html字符串
Private Function AddLogoHtml() As String
Dim RetStr1 As String
RetStr1 = RetStr1 & "<html><head><STYLE type=text/css>.td1 {FONT-FAMILY: 宋体, Arial, Times New Roman; FONT-SIZE: 9pt; FONT-WEIGHT: strong;COLOR: red}"
RetStr1 = RetStr1 & ".td2 {FONT-FAMILY: 宋体, Arial, Times New Roman; FONT-SIZE: 9pt; FONT-WEIGHT: normal}"
RetStr1 = RetStr1 & ".A:link {FONT-SIZE: 9pt; TEXT-DECORATION: none}"
RetStr1 = RetStr1 & ".A:visited {COLOR: #0000ff; FONT-SIZE: 9pt; TEXT-DECORATION: none}"
RetStr1 = RetStr1 & ".A:active {COLOR: #0000ff; FONT-SIZE: 9pt; TEXT-DECORATION: none}"
RetStr1 = RetStr1 & ".A:hover {COLOR: red; TEXT-DECORATION: none}"
RetStr1 = RetStr1 & "</STYLE></head><body bgcolor=AntiqueWhite>"
RetStr1 = RetStr1 & "<p><font size=3 face=幼圆>BigFox Web Server V1.0（大尾狐Web服务器）</font></p>"
RetStr1 = RetStr1 & "<table border=0 width=500 cellPadding=1 cellSpacing=1>"
RetStr1 = RetStr1 & "<tr bgcolor=blue><td height=5><td></tr>"
RetStr1 = RetStr1 & "<tr><td><div align=center><b class=td1>Welcome to BigFox Server</b></div></td></tr>"
RetStr1 = RetStr1 & "<tr><td class=td2>目前提供的服务：</td></tr>"
RetStr1 = RetStr1 & "<tr><td class=td2>1.<a href=/upload.htm>软件/文件上载</a></td></tr>"
RetStr1 = RetStr1 & "<tr><td class=td2>2.<a href=/uploadfile/>软件/文件下载</a></td></tr>"
RetStr1 = RetStr1 & "<tr><td class=td2>3.<a href=/html/index.htm>网页浏览</a></td></tr><tr bgcolor=blue>"
RetStr1 = RetStr1 & "<td height=5><td></tr><tr><td class=td2><p></td></tr>"
RetStr1 = RetStr1 & "<tr><td class=td1>注：有时对中文的连接不太支持</td></tr>"
RetStr1 = RetStr1 & "<tr><td class=td1><div align=right class=td1>"
If NeedPass = True Then
    RetStr1 = RetStr1 & "（需要密码）"
Else
    RetStr1 = RetStr1 & "（不需要密码）"
End If
RetStr1 = RetStr1 & "管理员：busyzhong</div></td></tr></table></body></html>"
AddLogoHtml = RetStr1
End Function