frmserver.frm

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

VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.Form frmServer 
   BackColor       =   &H00C0C0C0&
   Caption         =   "Form1"
   ClientHeight    =   4284
   ClientLeft      =   48
   ClientTop       =   336
   ClientWidth     =   6600
   LinkTopic       =   "Form1"
   ScaleHeight     =   4284
   ScaleWidth      =   6600
   StartUpPosition =   3  'Windows Default
   Begin MSWinsockLib.Winsock Winsock1 
      Index           =   0
      Left            =   0
      Top             =   0
      _ExtentX        =   593
      _ExtentY        =   593
      _Version        =   393216
   End
   Begin VB.Frame Frame2 
      Caption         =   "服务器信息显示"
      BeginProperty Font 
         Name            =   "幼圆"
         Size            =   7.8
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   2715
      Left            =   60
      TabIndex        =   2
      Top             =   1560
      Width           =   6528
      Begin VB.TextBox txtInfo 
         Height          =   2268
         Left            =   60
         MultiLine       =   -1  'True
         ScrollBars      =   2  'Vertical
         TabIndex        =   3
         Top             =   360
         Width           =   6336
      End
   End
   Begin VB.Frame Frame1 
      Caption         =   "一般设置"
      BeginProperty Font 
         Name            =   "幼圆"
         Size            =   7.8
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   1356
      Left            =   60
      TabIndex        =   0
      Top             =   60
      Width           =   6492
      Begin VB.PictureBox Pic 
         Appearance      =   0  'Flat
         AutoRedraw      =   -1  'True
         BackColor       =   &H00C0C0C0&
         BorderStyle     =   0  'None
         ForeColor       =   &H80000008&
         Height          =   252
         Left            =   120
         ScaleHeight     =   252
         ScaleWidth      =   6192
         TabIndex        =   6
         Top             =   960
         Width           =   6192
      End
      Begin VB.CommandButton cmdSet 
         Caption         =   "设置"
         BeginProperty Font 
            Name            =   "幼圆"
            Size            =   9
            Charset         =   134
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   375
         Left            =   5160
         TabIndex        =   5
         Top             =   300
         Width           =   1230
      End
      Begin VB.CommandButton cmdStart 
         Caption         =   "停止"
         Enabled         =   0   'False
         BeginProperty Font 
            Name            =   "幼圆"
            Size            =   9
            Charset         =   134
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   612
         Index           =   1
         Left            =   1200
         Picture         =   "frmServer.frx":0000
         Style           =   1  'Graphical
         TabIndex        =   4
         Top             =   180
         Width           =   936
      End
      Begin VB.CommandButton cmdStart 
         Caption         =   "启动"
         BeginProperty Font 
            Name            =   "幼圆"
            Size            =   9
            Charset         =   134
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   612
         Index           =   0
         Left            =   135
         Picture         =   "frmServer.frx":0442
         Style           =   1  'Graphical
         TabIndex        =   1
         Top             =   180
         Width           =   936
      End
      Begin VB.Line Line1 
         X1              =   60
         X2              =   6360
         Y1              =   1260
         Y2              =   1260
      End
   End
End
Attribute VB_Name = "frmServer"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'加载的Winsock个数
Dim SockNum As Integer

Private Sub cmdSet_Click()
frmSet.Show vbModal
End Sub

Private Sub cmdStart_Click(Index As Integer)
If Index = 0 Then
    '服务器启动
    If Winsock1(0).State = sckClosed Then
        '服务器侦听客户端请求
        Winsock1(0).LocalPort = ServerPort
        Winsock1(0).Listen
    End If
    cmdStart(0).Enabled = False
    cmdStart(1).Enabled = True
    ServerInfoStr = "服务器于" & Format(Time, "hh:mm:ss") & "开始运行" & vbCrLf & ServerInfoStr
Else
    '服务器停止
    If Winsock1(0).State <> sckClosed Then
        Winsock1(0).Close
    End If
    cmdStart(1).Enabled = False
    cmdStart(0).Enabled = True
    ServerInfoStr = "服务器于" & Format(Time, "hh:mm:ss") & "停止服务" & vbCrLf & ServerInfoStr
End If
DrawSocket
txtInfo.Text = ServerInfoStr
End Sub


Private Sub Form_Load()
Dim RetStr As String * 50
Dim RetInt As Long
'从配置文件中读取根目录的值
RetInt = GetPrivateProfileString("Busyzhong's BigFox Server", "根目录", App.Path, RetStr, 50, App.Path & "\bigfox.ini")
RootPath = RetStr
If RetInt > 0 Then
    RootPath = Mid(RootPath, 1, RetInt)
End If
'读取服务器侦听端口的值
GetPrivateProfileString "Busyzhong's BigFox Server", "端口", "80", RetStr, 50, App.Path & "\bigfox.ini"
ServerPort = Val(RetStr)
'读取验证帐号
RetInt = GetPrivateProfileString("Busyzhong's BigFox Server", "用户名", "zhong", RetStr, 50, App.Path & "\bigfox.ini")
UserName = RetStr
If RetInt > 0 Then
    UserName = Mid(UserName, 1, RetInt)
End If
'读取验证密码
RetInt = GetPrivateProfileString("Busyzhong's BigFox Server", "密码", "1", RetStr, 50, App.Path & "\bigfox.ini")
UserPass = RetStr
If RetInt > 0 Then
    UserPass = Mid(UserPass, 1, RetInt)
End If
'是否允许目录浏览
RetInt = GetPrivateProfileString("Busyzhong's BigFox Server", "允许目录浏览", "1", RetStr, 50, App.Path & "\bigfox.ini")
If Val(RetStr) = 1 Then
    bDir = True
Else
    bDir = False
End If
'是否需要密码
RetInt = GetPrivateProfileString("Busyzhong's BigFox Server", "需要认证", "1", RetStr, 50, App.Path & "\bigfox.ini")
If Val(RetStr) = 1 Then
    NeedPass = True
Else
    NeedPass = False
End If
RootPath = App.Path & "\file"
MaxTime = 40
Call DrawSocket
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
'将设置保存到配置文件中
Dim iii As String
iii = Str(ServerPort)
WritePrivateProfileString "Busyzhong's BigFox Server", "根目录", RootPath, App.Path & "\bigfox.ini"
WritePrivateProfileString "Busyzhong's BigFox Server", "端口", iii, App.Path & "\bigfox.ini"
WritePrivateProfileString "Busyzhong's BigFox Server", "用户名", UserName, App.Path & "\bigfox.ini"
WritePrivateProfileString "Busyzhong's BigFox Server", "密码", UserPass, App.Path & "\bigfox.ini"
If bDir = True Then
    iii = "1"
Else
    iii = "0"
End If
WritePrivateProfileString "Busyzhong's BigFox Server", "允许目录浏览", iii, App.Path & "\bigfox.ini"
If NeedPass = True Then
    iii = "1"
Else
    iii = "0"
End If
WritePrivateProfileString "Busyzhong's BigFox Server", "需要认证", iii, App.Path & "\bigfox.ini"
End Sub



Private Sub Winsock1_ConnectionRequest(Index As Integer, ByVal requestID As Long)
Dim i As Integer
Dim WhichSocket As Integer
If Index <> 0 Then Exit Sub
For i = 1 To SockNum
'检查已经加载的winscok是否有未连接的
   If Winsock1(i).State = sckClosed Then
       WhichSocket = i
       Exit For
    End If
Next i
If WhichSocket = 0 Then
'连接的客户数大于socket个数,加载socket
    SockNum = SockNum + 1
    Load Winsock1(SockNum)
    WhichSocket = SockNum
End If

Winsock1(WhichSocket).Accept requestID
Set ClientInfo(WhichSocket) = New ClsClient
ClientInfo(WhichSocket).WinsockIndex = WhichSocket
'开始时间
ClientInfo(WhichSocket).StartTime = Time()
'清除该client的临时文件
ClientInfo(WhichSocket).ClearData
'客户端的ip
ClientInfo(WhichSocket).ClientIP = Winsock1(WhichSocket).RemoteHostIP
ServerInfoStr = Winsock1(WhichSocket).RemoteHostIP & "Socket:" & WhichSocket & "请求Web Server" & vbCrLf & ServerInfoStr
txtInfo.Text = ServerInfoStr
Call DrawSocket
End Sub

Private Sub Winsock1_DataArrival(Index As Integer, ByVal bytesTotal As Long)
Dim strData As String
Dim Bytedata() As Byte
'接收来自客户端的数据
Winsock1(Index).GetData Bytedata(), vbByte
'类对象保存数据
ClientInfo(Index).SaveData bytesTotal, Bytedata()
ClientInfo(Index).ReceiveData = ClientInfo(Index).ReceiveData & strData
'类对象处理数据
ClientInfo(Index).HandleData
txtInfo.Text = ServerInfoStr
End Sub

Private Sub Winsock1_Error(Index As Integer, ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
Winsock1(Index).Close
End Sub

Private Sub Winsock1_SendComplete(Index As Integer)
'发送数据完毕，关闭TCP连接
Winsock1(Index).Close
ServerInfoStr = ClientInfo(Index).ClientIP & "关闭连接" & vbCrLf & ServerInfoStr
txtInfo.Text = ServerInfoStr
Call DrawSocket
End Sub

'根据Winsock的State属性描绘其工作状态
Private Sub DrawSocket()
Dim i As Integer
Dim intR As Integer
intR = 80
Pic.FillStyle = vbFSSolid
If Winsock1(0).State <> sckClosed Then
    Pic.FillColor = vbGreen
Else
    Pic.FillColor = vbYellow
End If
Pic.Circle (1 * 6 * intR / 2, 3 * intR / 2), intR * 5 / 4, vbBlack
For i = 1 To MaxConnect
    If i > Winsock1.Count - 1 Then
        Pic.FillColor = vbBlue
    Else
        If Winsock1(i).State <> sckClosed Then
            Pic.FillColor = vbRed
        Else
            Pic.FillColor = vbBlue
        End If
    End If
    Pic.Circle ((i + 1.5) * 6 * intR / 2, 3 * intR / 2), intR, vbBlack
Next i
End Sub

'对Url解码
Public Function DecodeUrl(ByVal mUrl As String) As String
Dim RetUrl As String
Dim pos1 As Integer
Dim mByte As Byte
Dim tByte() As Byte
Dim TmpStr As String
Dim i As Integer, k As Integer
RetUrl = mUrl
pos1 = InStr(1, RetUrl, "%")
For i = 0 To Len(mUrl) - 1
    If Mid(mUrl, i + 1, 1) = "%" Then
        TmpStr = Mid(mUrl, i + 2, 2)
        mByte = CInt("&H" & TmpStr)
        i = i + 2
    Else
        TmpStr = Mid(mUrl, i + 1, 1)
        mByte = Asc(TmpStr)
    End If
    ReDim Preserve tByte(k + 1)
    tByte(k) = mByte
    k = k + 1
Next i
RetUrl = "" & StrConv(tByte(), vbUnicode)
DecodeUrl = RetUrl
End Function