frmwsk.frm

尝试做了一个利用WINSOCK控件的自动分包发送机制的东东(VB6.0) 我最终的测试结果如下: 使用约44M的RAR文件(陈辉机器里找的一个什么安装包,不管它...),在陈辉机器上运行客

VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.Form frmWsk 
   BorderStyle     =   0  'None
   ClientHeight    =   1680
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   2085
   LinkTopic       =   "Form1"
   ScaleHeight     =   1680
   ScaleWidth      =   2085
   ShowInTaskbar   =   0   'False
   StartUpPosition =   3  'Windows Default
   Begin VB.Timer timerUnloadWsk 
      Enabled         =   0   'False
      Interval        =   100
      Left            =   720
      Top             =   720
   End
   Begin MSWinsockLib.Winsock wskListen 
      Index           =   0
      Left            =   720
      Top             =   270
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
   End
End
Attribute VB_Name = "frmWsk"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'尝试使用WINSOCK控件的自动分包发送机制来做文件传送
'服务器端,核心通讯窗体
'BY 嗷嗷叫的老马
'2008-07-29
Option Explicit

Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" ( _
     ByVal Destination As Long, _
     ByVal Source As Long, _
     ByVal Length As Long)

Dim MainData() As MyType        '主数据数组
Dim mListenPort As Long         '服务器监听端口

Public Event RecvComplet()
        '一个文件接收完成
        
Public Function SetService(ByVal mListen As Boolean, Optional ByVal mPort As Long = -1) As Long
    '停止或启动服务器
    'mListen - T为启动,F为停止
    'mPort - 启动服务器时所用的端口
    '成功返回1,否则返回0
    Dim I As Long
    
    SetService = 0
    If mPort > 0 Then mListenPort = mPort
    
    If mListen = True Then
        On Error GoTo errHandle
            With wskListen(0)
                .LocalPort = mListenPort
                .Listen
            End With
            SetService = 1
        On Error GoTo 0
    Else
        On Error Resume Next        '卸载过程中可能会有已经被卸载的WINSOCK控件,所以处理之.
            wskListen(0).Close
            For I = 1 To wskListen.UBound
                wskListen(I).Close
                Unload wskListen(I)
            Next I
            SetService = 1
        On Error GoTo 0
    End If
    Exit Function
    
    Exit Function
errHandle:
    Call ShowErr("SetService")
End Function

Private Sub Form_Load()
    On Error GoTo errHandle
    
    ReDim MainData(0)
    mListenPort = 50000
    
    Exit Sub
errHandle:
    Call ShowErr("Form_Load")
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error GoTo errHandle
    
    ReDim MainData(0)
    
    Exit Sub
errHandle:
    Call ShowErr("Form_Unload")
End Sub

Private Sub timerUnloadWsk_Timer()
    '清理已经用完的WINSOCK控件
    Dim I As Long, J As String
    
    On Error Resume Next
    
    timerUnloadWsk.Enabled = False
    For I = 1 To wskListen.UBound
        J = "-1"
        J = wskListen(I).Tag
        If J = "Unload" Then
            wskListen(I).Close
            Unload wskListen(I)
            Debug.Print "                   Unload = " & I
        End If
    Next I
End Sub

Private Sub wskListen_ConnectionRequest(Index As Integer, ByVal requestID As Long)
    On Error GoTo errHandle
    
    If Index = 0 Then
        Dim NewIndex As Long
        
        NewIndex = GetNewIndex              '取一个可用索引
        Load wskListen(NewIndex)            '加载新的WinSock
        Call InitVars(NewIndex)             '初始化变量
        
        With wskListen(NewIndex)
            .Accept requestID               '用新的WinSock应答请求
            .SendData SER_CONNECT_OK        '发送"连接成功"
            MainData(NewIndex).ClientIP = .RemoteHostIP      '记录IP
        End With
    End If
    
    Exit Sub
errHandle:
    Call ShowErr("wskListen_ConnectionRequest")
End Sub

Private Sub wskListen_DataArrival(Index As Integer, ByVal bytesTotal As Long)
    Dim ClientData() As Byte, CommandStr() As String
    
    On Error Resume Next
    
    If Index = 0 Then Exit Sub
    
    With wskListen(Index)
        .GetData ClientData, vbByte         '字节方式取回数据
        
        If bytesTotal < 100 Then             '小于一定长度,就尝试按控制码处理
            CommandStr = Split(StrConv(ClientData, vbUnicode), ",")
            Debug.Print CommandStr(0)
        End If
        
        Select Case CommandStr(0)
            Case CLI_READY_SENDDATA             '客户端返回110(请求发送数据)
                With MainData(Index)
                    .theFileName = CommandStr(1)        '原文件名
                    .theLength = CommandStr(2)          '大小
                    .FileNumber = FreeFile              '申请可用文件号
                    .theSaveName = GetNewFileName(AddStrToStr(App.Path, "\") & "RecvTemp\" & .theFileName)  '生成保存文件名
                    .theState = 1               '接收数据状态
                    
                    Open .theSaveName For Binary As .FileNumber      '先打开文件
                    Debug.Print "       " & .theFileName & "/" & .theLength
                End With
                .SendData SER_READY_RECEIVE_DATA   '返回"准备接收数据"
                DoEvents
                
                Exit Sub
            Case CLI_READY_CLOSE                '客户端请求断开连接
                .SendData SER_ALLOW_CLOSE           '允许断开连接
                .Tag = "Unload"                     '允许卸载
                MainData(Index).theState = 0
                PubMyType = MainData(Index)
                RaiseEvent RecvComplet              '转移数据
                Close MainData(Index).FileNumber    '关闭文件
                DoEvents
                
                timerUnloadWsk = True               '启动定时器,回收当前WINSOCK
                
                Exit Sub
        End Select
        If MainData(Index).theState = 1 Then  '如果是接收数据状态
'            Call AddData(MainData(Index).theData, ClientData)           '在内存里组合数据
            Put MainData(Index).FileNumber, LOF(1) + 1, ClientData                              '直接保存到硬盘
'            If MainData(Index).theLength = UBound(MainData(Index).theData) + 1 Then     '判断是否接收完成
            If MainData(Index).theLength = LOF(1) Then                                  '判断是否接收完成
                .SendData SER_RECEIVE_COMPLET
                DoEvents
            End If
        End If
    End With
End Sub

Private Function AddData(ByRef InData() As Byte, ByRef NewData() As Byte)
    '添加数据
    Dim OldIndex As Long, NewDataLenght As Long
    
    On Error GoTo errHandle
    
    OldIndex = UBound(InData)           '取最后一个索引值
    If OldIndex = 0 Then OldIndex = -1
    NewDataLenght = UBound(NewData) + 1    '取新数据长度
    
    ReDim Preserve InData(OldIndex + NewDataLenght)      '扩充长度
    Call CopyMemory(VarPtr(InData(OldIndex + 1)), VarPtr(NewData(0)), NewDataLenght)  '追加数据
'    Debug.Print "       追加数据,源长度 = " & OldIndex + 1 & ",新长度 = " & UBound(InData) + 1
    
    Exit Function
errHandle:
    Call ShowErr("AddData")
End Function

Private Function GetNewIndex() As Long
    '查询当前WinSock组,找出可用的索引
    '返回值:
    '       返回找到的索引值
    Dim I As Long
    
    On Error GoTo NoDef
    
    For I = 1 To wskListen.UBound
        If wskListen(I).Tag <> "1" Then
            '什么也不做,只是为了触发错误
        End If
    Next I
NoDef:
    GetNewIndex = I
    Debug.Print "NewIndex = " & I
End Function

Private Function InitVars(ByVal NewIndex As Long)
    '初始化指定数组变量
    
    On Error GoTo errHandle
    
    If UBound(MainData) < NewIndex Then ReDim Preserve MainData(NewIndex)
    With MainData(NewIndex)
        ReDim .theData(0)
    End With
    
    Exit Function
errHandle:
    Call ShowErr("InitVars")
End Function

Private Function GetNewFileName(ByVal OldFileName As String) As String
    '返回一个文件名:
    '       如果原文件存在,则自动在文件名后添加(X)这样的字符,与WINDOWS类似.
    '       如果原文件不存在,返回原文件.
    Dim I As Long, FilePath As String, FileExt As String, NewFileName As String
    
    On Error GoTo errHandle
    
    FileExt = GetFileNameInPath(OldFileName)
    FileExt = Mid(FileExt, InStrRev(FileExt, "."), Len(FileExt))
    FilePath = GetDirInPath(OldFileName) & "\" & GetFileNameInPath(OldFileName, True)
    NewFileName = FilePath & FileExt
    I = -1
    
    Do
        If Dir(NewFileName) <> "" Then
            I = I + 1
            NewFileName = FilePath & "(" & I & ")" & FileExt
        Else
            Exit Do
        End If
    Loop
    GetNewFileName = NewFileName
    
    Exit Function
errHandle:
    Call ShowErr("GetNewFileName")
End Function

Public Property Get ListenPort() As Long
    On Error GoTo errHandle
    
    ListenPort = mListenPort
    
    Exit Property
errHandle:
    Call ShowErr("Get_ListenPort")
End Property

Public Property Let ListenPort(ByVal vNewValue As Long)
    On Error GoTo errHandle
    
    If vNewValue < 1 Then
        MsgBox "非法的端口号!", vbOKOnly Or vbInformation
        Exit Property
    End If
    mListenPort = vNewValue
    
    Exit Property
errHandle:
    Call ShowErr("Let_ListenPort")
End Property

Private Function ShowErr(ByVal FunName As String)
    '显示错误内容
    MsgBox "过程名 = """ & FunName & """" & vbCrLf & _
            "错误内容 = """ & Err.Description & """", vbOKOnly Or vbExclamation
End Function