frmsend.frm

类似QQ的即时聊天系统,支持用户注册,源码分为客户端和服务器端。

VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX"
Begin VB.Form frmSend 
   BorderStyle     =   4  'Fixed ToolWindow
   Caption         =   "文件发送中"
   ClientHeight    =   1665
   ClientLeft      =   45
   ClientTop       =   285
   ClientWidth     =   4980
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   1665
   ScaleWidth      =   4980
   ShowInTaskbar   =   0   'False
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton Command1 
      Caption         =   "开始(&S)"
      Height          =   435
      Left            =   720
      TabIndex        =   3
      Top             =   1140
      Width           =   1335
   End
   Begin ComctlLib.ProgressBar ProgressBar1 
      Height          =   435
      Left            =   300
      TabIndex        =   1
      Top             =   240
      Width           =   4395
      _ExtentX        =   7752
      _ExtentY        =   767
      _Version        =   327682
      Appearance      =   1
   End
   Begin VB.CommandButton cancel 
      Caption         =   "取消(&C)"
      Enabled         =   0   'False
      Height          =   435
      Left            =   2520
      TabIndex        =   0
      Top             =   1140
      Width           =   1335
   End
   Begin MSWinsockLib.Winsock sckSystem 
      Left            =   120
      Top             =   600
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
      Protocol        =   1
   End
   Begin MSWinsockLib.Winsock sckSend 
      Left            =   120
      Top             =   120
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
   End
   Begin VB.Label compLabel 
      Height          =   255
      Left            =   300
      TabIndex        =   2
      Top             =   780
      Width           =   4395
   End
End
Attribute VB_Name = "frmSend"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'================
'发送信息窗体
'处理信息的发送
'================

'公有变量
Public hIn, fileLength, ret
Public Temp As String
Public blockSize As Long

Public sizeOfFile As Double     '文件大小
Public sizeOfFileSent As Double '发送文件大小
Public nameOfFile As String     '文件名
Public pathToFile As String     '文件路径
Public userName As String       '用户名

Public hostIP As String         '主机IP
Public hostPort As Double       '主机端口

'私有变量
Private quitNow As Boolean

'==============
'取消
'==============
Private Sub cancel_Click()

If cancel.Caption = "取消" Then
sckSystem.Close
sckSystem.Bind
sckSystem.SendData CANCEL_TRANSFER
Unload Me
quitNow = True
ElseIf cancel.Caption = "关闭" Then
'关闭SOCKET连接
sckSend.Close
Close hIn
Unload Me
End If

End Sub

'============
'开始发送请求
'============
Private Sub Command1_Click()
compLabel.Caption = "等待用户接受连接..."
sckSystem.SendData FILE_NAME & nameOfFile
sckSystem.SendData FILE_SIZE & sizeOfFile
sckSystem.SendData USER_NAME & userName
cancel.Enabled = True
Command1.Enabled = False
End Sub

'==============
'窗体初使化
'==============
Private Sub Form_Load()

'设置默认端口
If hostPort = 0 Then
    hostPort = 43597
End If

Me.Caption = "准备发送 " & nameOfFile

'数据连接
sizeOfFile = FileLen(pathToFile)

'设置进度条
ProgressBar1.Max = sizeOfFile
ProgressBar1.Min = 0
ProgressBar1.value = ProgressBar1.Min
ProgressBar1.Visible = True

'设置SOCKET信息
sckSystem.Close
sckSystem.RemoteHost = hostIP
sckSystem.LocalPort = hostPort
sckSystem.RemotePort = hostPort
sckSystem.Bind 1983

'this one is tcp/ip
sckSend.RemoteHost = hostIP
sckSend.RemotePort = hostPort + 5 ' Port to connect to.
'sckSend.Bind hostPort + 4
'MsgBox "hostPort = " & hostPort + 5
'MsgBox "Binding on " & hostPort + 4

'send initialization information
'sckSystem.SendData FILE_NAME & nameOfFile
'sckSystem.SendData FILE_SIZE & sizeOfFile
'sckSystem.SendData USER_NAME & userName

End Sub

Private Sub Form_Unload(cancel As Integer)
MyIM.BuddyUpdater.Enabled = True
End Sub

'=================
'SOCKET数据接收过程
'=================
Private Sub sckSystem_DataArrival(ByVal bytesTotal As Long)

blockSize = 2048

Dim tempComData As String
sckSystem.GetData tempComData, vbString

Dim Command As String
Command = Mid(tempComData, 1, 1)

'接收到取消传送命令，停止发送数据
If Command = CANCEL_TRANSFER Then
    stopSending
End If

'接收到拒绝发送命令
If Command = ENABLE_START Then Command1.Enabled = True
'接收到同意传输命令
If Command = ACCEPT_TRANSFER Then
        DoEvents
        sckSend.Connect
        Do Until sckSend.State = sckConnected   '等待，直至连接
            DoEvents
        Loop
        GoTo BeginTransfer
End If

'接收到继续传送命令
If Command = CONTINUE_TRANSFER Then
'On Error GoTo ErrorHandler
        '调整发送块大小
        If fileLength - Loc(hIn) <= blockSize Then
            blockSize = fileLength - Loc(hIn) + 1
        End If
        Temp = Space$(blockSize)        '分配块空间
        Get hIn, , Temp                 '从文件中读数据到块
        ret = DoEvents()
        If quitNow Then GoTo endIt
        sckSend.SendData Temp           '发送
        
        '进度条变化
        sizeOfFileSent = sizeOfFileSent + blockSize
        'On Error GoTo endIt
        On Error Resume Next
        ProgressBar1.value = sizeOfFileSent
        '显示发送文件信息
        compLabel.Caption = sizeOfFileSent & "/" & sizeOfFile & " 已发送. " & Int(sizeOfFileSent / sizeOfFile * 100) & "%"
        DoEvents
        
        '如果已发送文件超过文件大小，停止发送
        If sizeOfFileSent >= sizeOfFile Then
            cancel.Caption = "关闭"
            sckSystem.SendData CLOSE_TRANSFER
        End If
        Exit Sub
End If
'接收到关闭连接命令 半闭连接
If Command = CLOSE_TRANSFER Then GoTo endIt
Exit Sub
BeginTransfer:

    hIn = FreeFile
    Open pathToFile For Binary Access Read As hIn
    fileLength = LOF(hIn)
            '调整发送块大小
            If fileLength - Loc(hIn) <= blockSize Then
                    blockSize = fileLength - Loc(hIn) '+ 1
            End If
            Temp = Space$(blockSize)        '分配块空间
            Get hIn, , Temp                 '从文件中读数据到块
            ret = DoEvents()
            If quitNow Then GoTo endIt
            sckSend.SendData Temp           '发送
            
            '进度条变化
            sizeOfFileSent = sizeOfFileSent + blockSize
            ProgressBar1.value = sizeOfFileSent
            '显示发送文件信息
            compLabel.Caption = sizeOfFileSent & " / " & sizeOfFile & " 已发送. " & Int(sizeOfFileSent / sizeOfFile * 100) & "%"
        
        '如果已发送文件超过文件大小，停止发送
        If sizeOfFileSent >= sizeOfFile Then
            cancel.Caption = "关闭"
            sckSystem.SendData CLOSE_TRANSFER
        End If
        Exit Sub
ErrorHandler:                                           '关闭文件
        Close hIn
        'SendFile = False
endIt:
        sckSend.Close   '
        Close hIn
        MsgBox "Transfer Complete"
        Unload Me
End Sub

'===============
'停止发送过程
'===============
Private Sub stopSending()
    
    quitNow = True
    MsgBox "用户取消文件传送.", vbOKOnly, "文件传送"
    Unload Me

End Sub