mainfrm.frm

基于VB实现局域网内的文件传输

VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "mscomctl.ocx"
Begin VB.Form MainFrm 
   Caption         =   "Winsock传输文件示例"
   ClientHeight    =   4095
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4680
   Icon            =   "MainFrm.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   4095
   ScaleWidth      =   4680
   StartUpPosition =   3  '窗口缺省
   Begin MSComctlLib.ProgressBar ProgressBar1 
      Align           =   2  'Align Bottom
      Height          =   495
      Left            =   0
      TabIndex        =   5
      Top             =   3600
      Width           =   4680
      _ExtentX        =   8255
      _ExtentY        =   873
      _Version        =   393216
      Appearance      =   1
   End
   Begin VB.Timer Timer2 
      Enabled         =   0   'False
      Interval        =   100
      Left            =   4080
      Top             =   600
   End
   Begin VB.CommandButton cmdConnect 
      Caption         =   "连接"
      Height          =   375
      Left            =   360
      TabIndex        =   4
      Top             =   840
      Width           =   1215
   End
   Begin MSWinsockLib.Winsock WinsockSend 
      Left            =   3600
      Top             =   120
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
   End
   Begin VB.CommandButton cmdSend 
      Caption         =   "发送"
      Height          =   375
      Left            =   360
      TabIndex        =   3
      Top             =   1560
      Width           =   1215
   End
   Begin VB.TextBox txtHost 
      Height          =   375
      Left            =   1560
      TabIndex        =   1
      Text            =   "192.168.10.32"
      Top             =   0
      Width           =   1575
   End
   Begin MSComDlg.CommonDialog CommonDialog1 
      Left            =   2880
      Top             =   600
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin MSWinsockLib.Winsock WinsockReceive 
      Left            =   4080
      Top             =   120
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
   End
   Begin VB.Timer Timer1 
      Enabled         =   0   'False
      Interval        =   100
      Left            =   3600
      Top             =   600
   End
   Begin VB.Label Label2 
      Caption         =   "IP地址："
      Height          =   375
      Left            =   0
      TabIndex        =   2
      Top             =   0
      Width           =   1335
   End
   Begin VB.Label Label1 
      Height          =   375
      Left            =   0
      TabIndex        =   0
      Top             =   3120
      Width           =   4575
   End
End
Attribute VB_Name = "MainFrm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'下面的代码既是服务器又是客户端
'采用应答式发送方式
'自动拆分文件，包括2进制

Option Explicit
'Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Dim mybyte() As Byte '发送方数组

Const filecomesMSG = "a file is coming " '有文件到来
Const RemoteIsReadyMSG = "sender is ready " '准备好了
Const FileisOverMSG = "the file is ended" '文件完毕
Const RemoteDenyMSG = "the user canceled" '用户取消
Const filecountMSG = "the file lengh is" '文件长度
Const RecevieIsReadyMSG = "Receiver is ready " '准备接收

Dim arrdata() As Byte '收到的信息
Dim filesave As Integer '保存文件的句柄
Dim filehandle As Integer '发送方文件的句柄
Dim FileSize As Double '文件的大小

Dim Sendbyte As Long
Dim Receivebyte As Long

Dim MyLocation As Double
Dim myMSG As String '消息
Dim FileisOver As Boolean '文件是否已经完毕

Const ReceivePort = 7905
Const BUFFER_SIZE = 5734

Private Sub cmdConnect_Click()
    Timer2.Enabled = True
End Sub

Private Sub cmdsend_Click()

    On Error GoTo errorhandle

    With CommonDialog1
        .CancelError = True
        .DialogTitle = "选择您要传送的文件"
        .Filter = "All Files (*.*)|*.*"
        .ShowOpen
    End With

    filehandle = FreeFile
    Open CommonDialog1.FileName For Binary Access Read As #filehandle

    cmdSend.Enabled = False
    
    FileSize = CDbl(FileLen(CommonDialog1.FileName))
    
    Label1.Caption = "等待回应>>>"
    MsgBox ("选择的文件大小为 " & LOF(filehandle) & " 字节")
    
    If WinsockSend.State = sckConnected Then
        WinsockSend.SendData filecomesMSG & CommonDialog1.FileName '发送发出文件信息
    End If
    
    Exit Sub
    
errorhandle:
cmdSend.Enabled = True
MsgBox ("你没有选择一个文件！")

End Sub


Private Sub Form_Load()
    
    WinsockReceive.LocalPort = ReceivePort
    WinsockReceive.Listen
           
    FileisOver = True

    Label1.Caption = "准备传输>>>"
    
End Sub

Public Function SendChunk()

Dim mybytesize As Long

    If WinsockSend.State <> sckConnected Then Exit Function
    
    mybytesize = BUFFER_SIZE
    
    If LOF(filehandle) - Loc(filehandle) < BUFFER_SIZE Then mybytesize = (LOF(filehandle) - Loc(filehandle))
    
    ReDim mybyte(0 To mybytesize - 1)
    
    Get #filehandle, , mybyte
    
    WinsockSend.SendData mybyte
    
    Sendbyte = Sendbyte + mybytesize
    
    ProgressBar1.Value = Int((100 / FileSize) * Sendbyte)
    
    If Sendbyte >= FileSize Then
        FileisOver = True
        WinsockSend.SendData FileisOverMSG
    End If

End Function

Private Sub Timer2_Timer()
    If WinsockSend.State = sckConnected Then
    
        Timer2.Enabled = False
        
        cmdConnect.Enabled = False
        
    ElseIf WinsockSend.State <> 1 And WinsockSend.State <> 6 And WinsockSend.State <> 7 And WinsockSend.State <> 8 And WinsockSend.State <> 9 Then
    
        WinsockSend.Connect txtHost.Text, ReceivePort
        
    ElseIf WinsockSend.State = 8 Or WinsockSend.State = 9 Then
    
        WinsockSend.Close
    End If
    
    
End Sub

Private Sub WinsockReceive_ConnectionRequest(ByVal requestID As Long)

    If WinsockReceive.State <> sckClosed Then WinsockReceive.Close
    
    WinsockReceive.Accept requestID
    
    
End Sub

Private Sub WinsockReceive_DataArrival(ByVal bytesTotal As Long)
    
    ReDim arrdata(0 To bytesTotal - 1)
    
    WinsockReceive.GetData arrdata, vbByte + vbArray
    
    myMSG = StrConv(arrdata, vbUnicode)        '二进制转为字符串
    
    Select Case Mid(myMSG, 1, 17)
    
    Case filecomesMSG '这些消息发送方和接受方都可收到
        '显示保存对话框
        On Error GoTo errorhandle
        CommonDialog1.FileName = Mid(myMSG, 17, Len(myMSG))
        CommonDialog1.DialogTitle = "选择保存文件的路径"
        CommonDialog1.ShowSave
        filesave = FreeFile
        
        Receivebyte = 0
        cmdSend.Enabled = False
        WinsockReceive.SendData RecevieIsReadyMSG
    Case FileisOverMSG
        Close #filesave
        
        MsgBox ("文件传输成功！") '大家一起处理
        
        cmdConnect.Enabled = True
        
        cmdSend.Enabled = True
        
        Label1.Caption = "准备传输>>>"
        
        ProgressBar1.Value = 0
        
        WinsockReceive.SendData FileisOverMSG
        
        WinsockReceive.Close
        
        WinsockReceive.Listen
        
    Case filecountMSG
        FileSize = Mid(myMSG, 18, Len(myMSG))
        Open CommonDialog1.FileName For Binary Access Write As #filesave
        WinsockReceive.SendData RemoteIsReadyMSG
        Label1.Caption = "文件准备传输！"
        FileisOver = False
        
    Case Else
        If Receivebyte < FileSize Then
            Receivebyte = Receivebyte + bytesTotal
            Put #filesave, , arrdata
            WinsockReceive.SendData RemoteIsReadyMSG
            ProgressBar1.Value = Int((100 / FileSize) * Receivebyte)
        End If
    End Select
    Exit Sub
errorhandle:
    WinsockReceive.SendData RemoteDenyMSG
    cmdConnect.Enabled = True
    
End Sub

Private Sub WinsockSend_DataArrival(ByVal bytesTotal As Long)
    WinsockSend.GetData myMSG
    Select Case myMSG
    
    Case RecevieIsReadyMSG
        WinsockSend.SendData filecountMSG & FileSize
        FileisOver = False
        Sendbyte = 0
        
    Case RemoteIsReadyMSG
        '如果文件还没有结束，继续传输
        If Not FileisOver Then
            Label1.Caption = "文件正在被传输>>>"
            SendChunk
        Else
            WinsockSend.SendData FileisOverMSG
        End If
    Case FileisOverMSG
        '主机处理
        Close #filehandle
        
        MsgBox ("文件传输成功！") '大家一起处理
        
        WinsockSend.SendData FileisOverMSG
        
        WinsockSend.Close
        
        cmdConnect.Enabled = True
        
        ProgressBar1.Value = 0
        
        cmdSend.Enabled = True
        Label1.Caption = "准备传输>>>"
    Case RemoteDenyMSG
        MsgBox ("用户终止了传输！")
        cmdSend.Enabled = True
        Label1.Caption = "准备传输>>>"
        Close #filehandle
    End Select
    Exit Sub

End Sub