clsclient.cls

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

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "ClsClient"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'记录客户端请求的类

Public ClientIP As String '客户端的ip地址
Public WinsockIndex As Integer 'winsock的序号
Public RequestUrl As String '请求的地址(资源)
Public ReceiveData As String '接收到的数据(字符串类型)
Public StartTime As Date '连接的开始时间
Private SendDataB() As Byte '发送给客户端的数据

Public Sub SaveData(ByteNum As Long, Bytedata() As Byte)
Dim Tfile As String
Dim Fnum As Integer
'如果没有临时目录，创建一个
If Dir(RootPath & "\temp", vbDirectory) = "" Then
    MkDir (RootPath & "\temp")
End If
Tfile = RootPath & "\temp\" & WinsockIndex & ".tmp"
Fnum = FreeFile()
'向临时文件中加入二进制的数据
Open Tfile For Binary As #Fnum
If LOF(Fnum) > 0 Then
    Seek #Fnum, LOF(Fnum) + 1
End If
Put #Fnum, , Bytedata()
Close #Fnum
'将接到的数据转换成String类型的数据
ReceiveData = ReceiveData & StrConv(Bytedata(), vbUnicode)
End Sub

Public Sub ClearData()
Dim Tfile As String
ReceiveData = ""
Tfile = RootPath & "\temp\" & WinsockIndex & ".tmp"
If Dir(Tfile) <> "" Then
    '删除临时文件
    Kill (RootPath & "\temp\" & WinsockIndex & ".tmp")
End If
End Sub

'处理接收到的数据,从中提取信息
Public Sub HandleData()
Dim pos1, pos2 As Integer
Dim StrTemp As String
If ReceiveData = "" Or RequestUrl <> "" Then Exit Sub
'分析取得的字符串,得到浏览器请求的信息
If InStr(1, ReceiveData, "GET", vbTextCompare) > 0 Then
    '浏览器以GET方式请求响应
    pos1 = InStr(1, ReceiveData, "GET", vbTextCompare)
    pos2 = InStr(pos1 + 4, ReceiveData, " ")
    If pos2 > pos1 Then
        '取得资源定位的字符串（相对URL)
        RequestUrl = Mid(ReceiveData, pos1 + 4, pos2 - pos1 - 4)
        ServerInfoStr = ClientIP & "请求(GET)" & RequestUrl & vbCrLf & ServerInfoStr
        '响应浏览器的请求
        Call ResponseUrl
        ReceiveData = ""
    End If
ElseIf InStr(1, ReceiveData, "POST", vbTextCompare) > 0 Then
    '浏览器以POST方式请求响应
    pos1 = InStr(1, ReceiveData, "POST", vbTextCompare)
    pos2 = InStr(pos1 + 5, ReceiveData, " ")
    If pos2 > pos1 Then
        '取得资源定位的字符串（相对URL)
        RequestUrl = Mid(ReceiveData, pos1 + 5, pos2 - pos1 - 5)
        ServerInfoStr = ClientIP & "请求(POST)" & RequestUrl & ServerInfoStr
        '处理浏览器提交数据
        Call HandlePost
        '响应请求
        Call ResponseUrl
        ReceiveData = ""
    End If
End If
End Sub

'根据url响应请求的过程
Private Sub ResponseUrl()
If RequestUrl = "" Then
    Exit Sub
End If
Dim FileContent As String '文件数据(字符型)
Dim ByteContent() As Byte '文件数据(二进制字节型)
Dim FileSize As Long '文件大小
Dim FileName As String '返回的文件名
Dim FileType As String '文件类型
'Dim ReadSuccess As Boolean'读取文件是否成功
Dim FileTime As String '文件的创建或修改时间

If Right(RequestUrl, 1) = "/" Then
    '请求目录浏览
    If bDir = False Or RequestUrl = "/" Then
        '禁止目录浏览
        FileName = "\"
        FileType = "text/html"
    Else
        '允许目录浏览
        FileType = "text/html"
        FileName = RootPath & RequestUrl
    End If
Else
    '请求返回文件
    FileName = RootPath & RequestUrl
    '根据文件扩展名设置文件类型
    If InStr(1, RequestUrl, ".htm", vbTextCompare) > 0 Or InStr(1, RequestUrl, ".html", vbTextCompare) > 0 Then
        FileType = "text/html"
    ElseIf InStr(1, RequestUrl, ".jpg", vbTextCompare) > 0 Or InStr(1, RequestUrl, ".jpeg", vbTextCompare) > 0 Then
        FileType = "image/jpeg"
    ElseIf InStr(1, RequestUrl, "gif", vbTextCompare) > 0 Then
        FileType = "image/gif"
    Else
        FileType = "application/" & Right(RequestUrl, 3)
    End If
End If

If FileName = "\" Then
    '显示进站画面
    FileContent = AddLogoHtml()
    FileContent = AddHeader("200", FileType, , FileTime) & vbCrLf & FileContent
    frmServer.Winsock1(WinsockIndex).SendData FileContent
    Exit Sub
End If

'如果需要用户输入密码及帐号进行认证
If NeedPass = True Then
        Dim bPass As Boolean
        '验证密码
        bPass = CheckPass()
        If bPass = False Then
            If ReadTxtFile(RootPath & "\pass.htm", FileContent, FileSize, FileTime) = True Then
                FileContent = AddHeader("401", FileType, FileSize, FileTime) & vbCrLf & FileContent
                frmServer.Winsock1(WinsockIndex).SendData FileContent
            Else
                '这个信息具体要编写404响应信息
                frmServer.Winsock1(WinsockIndex).SendData AddHeader("404")
            End If
            Exit Sub
        End If
End If

If InStr(1, FileType, "text") > 0 Then
    '处理文本数据类型
    If Right(FileName, 1) <> "/" Then
        If ReadTxtFile(FileName, FileContent, FileSize, FileTime) = True Then
            FileContent = AddHeader("200", FileType, FileSize, FileTime) & vbCrLf & FileContent
            frmServer.Winsock1(WinsockIndex).SendData FileContent
        Else
            '这个信息具体要编写404响应信息
            frmServer.Winsock1(WinsockIndex).SendData AddHeader("404")
        End If
    Else
        '目录浏览
        FileContent = myDir(FileName)
        FileContent = AddHeader("200", FileType, , Format(Now(), "ddd,yyyy-mm-dd hh:mm:ss")) & FileContent
        frmServer.Winsock1(WinsockIndex).SendData FileContent
    End If
ElseIf InStr(1, FileType, "image", vbTextCompare) > 0 Then
    '二进制数据文件
    If ReadBinFile(FileName, ByteContent, FileSize, FileTime) = True Then
        frmServer.Winsock1(WinsockIndex).SendData AddHeader("200", FileType, FileSize, FileTime)
        frmServer.Winsock1(WinsockIndex).SendData SendDataB()
    Else
        '这个信息具体要编写404响应信息
        frmServer.Winsock1(WinsockIndex).SendData AddHeader("404")
    End If
Else
    If ReadBinFile(FileName, ByteContent, FileSize, FileTime) = True Then
        frmServer.Winsock1(WinsockIndex).SendData AddHeader("200", FileType, FileSize, FileTime)
        frmServer.Winsock1(WinsockIndex).SendData SendDataB()
    Else
        '这个信息具体要编写404响应信息
        frmServer.Winsock1(WinsockIndex).SendData AddHeader("404")
    End If
End If
End Sub

Private Function myDir(FileName As String) As String
Dim RetStr As String
Dim Tstr As String
'返回目录及文件
RetStr = "<html><head>"
RetStr = RetStr & "<STYLE type=text/css>"
RetStr = RetStr & ".td1 {FONT-FAMILY: 宋体, Arial, Times New Roman; FONT-SIZE: 9pt; FONT-WEIGHT: strong;COLOR: red}" & vbCrLf
RetStr = RetStr & ".td2 {FONT-FAMILY: 宋体, Arial, Times New Roman; FONT-SIZE: 9pt; FONT-WEIGHT: normal}" & vbCrLf
RetStr = RetStr & ".A:link {FONT-SIZE: 9pt; TEXT-DECORATION: none}" & vbCrLf
RetStr = RetStr & ".A:visited {COLOR: #0000ff; FONT-SIZE: 9pt; TEXT-DECORATION: none}" & vbCrLf
RetStr = RetStr & ".A:active {COLOR: #0000ff; FONT-SIZE: 9pt; TEXT-DECORATION: none}" & vbCrLf
RetStr = RetStr & ".A:hover {COLOR: red; TEXT-DECORATION: none}" & vbCrLf
RetStr = RetStr & "</STYLE></head><body bgcolor=AntiqueWhite>" & vbCrLf
RetStr = RetStr & "<p><font size=3 face=幼圆>BigFox Web Server V1.0（大尾狐Web服务器）管理者：busyzhong</font></p>"
RetStr = RetStr & "<table border=0 width=500 cellPadding=0.5 cellSpacing=0>" & vbCrLf
RetStr = RetStr & "<tr><td></td><td>文件名</td><td>属性</td><td>创建时间</td><td>大小</td>"
RetStr = RetStr & "<tr bgcolor=blue><td height=5 colspan=5><td></tr>"
Tstr = Dir(FileName, vbDirectory)
If Len(FileName) <> Len(RootPath) + 1 Then
    RetStr = RetStr & "<tr class=td1><td><img src=/./new.gif></td><td><a href=/>根目录</a></td>" & vbCrLf
    RetStr = RetStr & "<td><目录></td>" & vbCrLf
    RetStr = RetStr & "<tr class=td1><td><img src=/./new.gif></td><td><a href=" & RequestUrl & "../>上一个目录</a></td>" & vbCrLf
    RetStr = RetStr & "<td><目录></td>" & vbCrLf
End If
While Tstr <> ""
    '文件名
    If Tstr <> "." And Tstr <> ".." Then
        If (GetAttr(FileName & Tstr) And vbDirectory) = vbDirectory Then
            '判断是否目录
            RetStr = RetStr & "<tr class=td1><td><img src=/./new.gif></td><td><a href=""" & RequestUrl & Tstr & "/"">" & Tstr & "</a></td>" & vbCrLf
            RetStr = RetStr & "<td><目录></td>" & vbCrLf
        Else
            '文件
            RetStr = RetStr & "<tr class=td2><td><img src=/./note.gif></td><td><a href=""" & RequestUrl & Tstr & """>" & Tstr & "</a></td>"
            RetStr = RetStr & "<td><文件></td>" & vbCrLf
        End If
        RetStr = RetStr & "<td>" & FileDateTime(FileName & Tstr) & "</td>" & vbCrLf
        RetStr = RetStr & "<td>" & FileLen(FileName & Tstr) & "</td></tr>" & vbCrLf
    End If
    Tstr = Dir()
Wend
RetStr = RetStr & "<tr bgcolor=blue><td height=5 colspan=5><td></tr>"
RetStr = RetStr & "<tr><td height=5 colspan=5><td></tr>"
RetStr = RetStr & "<tr><td><img src=/up.gif></td><td class=td1 colspan=4><a href=/upload.htm>上传文件>>>></a><td></tr>"
RetStr = RetStr & "</table></body></html>"
myDir = RetStr
End Function

'增加响应头信息
Private Function AddHeader(ResponseCode As String, Optional MimeType As String, Optional FileSize As Long, Optional FileTime As String) As String
Dim Tstr As String
Dim ResponseLine As String
Select Case ResponseCode
    Case "200"
        '200请求正确响应标题
        ResponseLine = "HTTP/1.1 200 OK"
        Tstr = ResponseLine
        Tstr = Tstr & vbCrLf & "Server: BigFox Server1.0"