frmsending.frm

本地文件传输器 本地文件传输器

VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmSending 
   BorderStyle     =   4  'Fixed ToolWindow
   Caption         =   "等待传送 %TO%"
   ClientHeight    =   1560
   ClientLeft      =   45
   ClientTop       =   285
   ClientWidth     =   5145
   Icon            =   "frmSending.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   1560
   ScaleWidth      =   5145
   StartUpPosition =   2  '屏幕中心
   Begin VB.Timer tmrSpeed 
      Interval        =   1000
      Left            =   1680
      Top             =   0
   End
   Begin MSWinsockLib.Winsock wsSend 
      Left            =   1200
      Top             =   0
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
   End
   Begin VB.CommandButton cmdCancelClose 
      Caption         =   "取消传送(&C)"
      Default         =   -1  'True
      Height          =   285
      Left            =   3720
      TabIndex        =   1
      Top             =   1080
      Width           =   1215
   End
   Begin VB.CheckBox chkClose 
      Caption         =   "传送完毕自动关闭"
      Height          =   255
      Left            =   120
      TabIndex        =   0
      Top             =   1200
      Width           =   1815
   End
   Begin MSComctlLib.ProgressBar pgPercent 
      Height          =   255
      Left            =   120
      TabIndex        =   2
      Top             =   600
      Width           =   4935
      _ExtentX        =   8705
      _ExtentY        =   450
      _Version        =   393216
      Appearance      =   1
   End
   Begin VB.Label lblSending 
      AutoSize        =   -1  'True
      Caption         =   "等待传送:"
      Height          =   180
      Left            =   120
      TabIndex        =   5
      Top             =   120
      Width           =   810
   End
   Begin VB.Label lblInfo 
      AutoSize        =   -1  'True
      Caption         =   "%FILENAME% 到 %TO%"
      Height          =   180
      Left            =   120
      TabIndex        =   4
      Top             =   360
      Width           =   1620
   End
   Begin VB.Label lblSent 
      AutoSize        =   -1  'True
      Caption         =   "已传送 %PERCENT%k 传速 %SPEED%"
      Height          =   180
      Left            =   120
      TabIndex        =   3
      Top             =   960
      Width           =   2700
   End
End
Attribute VB_Name = "frmSending"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim MyID As Long
Dim FileNum As Long
Dim FileName As String
Dim RCVAccept As Boolean
Dim Sentbyt As Long
Dim ByteSec As Long, Speed As Long
Dim Complete As Boolean

Public Function InitTransfer(ByVal id As Long)
  MyID = id
  FileName = Mid(ftSend(MyID).FileToSend, InStrRev(ftSend(MyID).FileToSend, "\") + 1)
  Caption = "等待回应:" & ftSend(MyID).To & " 文件传输"
  lblInfo = FileName & " to " & ftSend(MyID).To
  'Attempt to connect to the Destination
  wsSend.Connect ftSend(MyID).To, FT_USE_PORT
  Me.Visible = True
End Function

Private Sub cmdCancel_Click()
On Error Resume Next
  Complete = True
  Close #FileNum
  If chkClose.Value = vbUnchecked Then Unload Me
End Sub

Private Sub aniTransfer_Click()

End Sub

Private Sub cmdCancelClose_Click()
  On Error Resume Next
  'Close the connection to stop
  Complete = True
  wsSend.Close
  Close #FileNum
  Unload Me
End Sub

Private Sub Form_Load()
  'aniTransfer.Open App.Path & "\media\filemove.avi"
  If Int(pgPercent.Value) = 0 Then
  Me.Height = 900
  Else
  Me.Height = 1890
  End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
  'Remove the form from memory
  Set ftSend(MyID).frmSend = Nothing
End Sub





Private Sub tmrSpeed_Timer()
  Speed = Format(ByteSec / 1024, "0.0")
  ByteSec = 0
End Sub

Private Sub wsSend_Close()
  On Error Resume Next
  If Not Complete Then
    MsgBox "发生意外,对方终止传送或网络连接失败!", vbCritical + vbOKOnly, "Error"
    Close #FileNum
    Unload Me
  End If
End Sub

Private Sub wsSend_Connect()
  'Send Information regarding the file
  wsSend.SendData "FILE:" & FileName & ":" & ftSend(MyID).FileSize & ":" & ftSend(MyID).Comment
End Sub

Private Sub wsSend_DataArrival(ByVal bytesTotal As Long)

    Dim Dat As String
    wsSend.GetData Dat, vbString
    If Trim$(Dat$) = "ACCEPT" Then
      Call SendChunk
    ElseIf Trim$(Dat$) = "DENIED" Then
     ' MsgBox "The file was rejected by the Remote Host!", vbInformation + vbOKOnly, "File Rejected"
      'Close the connection
      wsSend.Close
      'unload the form
      Unload Me
    End If
    
End Sub

Private Sub wsSend_Error(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)
  Select Case Number
    Case sckConnectionRefused, sckHostNotFound, sckHostNotFoundTryAgain
      'couldnt connect
      MsgBox "无法建立连接,请检查IP是否正确!", vbCritical + vbOKOnly, _
             "Error " & Number
      'Close the form
      Unload Me
  End Select
End Sub

Public Function SendChunk()
  'This is where we send the file data
  Dim ChunkSize As Long
  Dim Chunk() As Byte
  Dim arrHash() As Byte
  If wsSend.State <> sckConnected Then Exit Function
  
  ChunkSize = FT_BUFFER_SIZE
  If FileNum = 0 Then 'No data has been sent yet, open the file
    FileNum = FreeFile
    Open ftSend(MyID).FileToSend For Binary As #FileNum
  End If
  
  'determine chunk size
  If (LOF(FileNum) - Loc(FileNum)) < FT_BUFFER_SIZE Then _
     ChunkSize = (LOF(FileNum) - Loc(FileNum))
  'set array size to fit chunk
  ReDim Chunk(0 To ChunkSize - 1)
  'read the chunk
  Get #FileNum, , Chunk
  'Send the data
  wsSend.SendData Chunk
  Sentbyt = Sentbyt + ChunkSize
  ByteSec = ByteSec + ChunkSize
  pgPercent.Value = (100 / ftSend(MyID).FileSize) * Sentbyt
  lblSent = "已传送 " & Int(pgPercent.Value) & "% " & _
            "传速 " & Speed & " Kb\秒"
            '大小 " & ftSend(MyID).FileSize / 1024
            
  If Int(pgPercent.Value) = 100 Then
    lblSending.Caption = "文件传送完毕!"
    Me.Caption = "文件传送完毕!"
    Me.Height = 900
  Else
    lblSending.Caption = "正在传送: "
    Me.Caption = "正在传送:" & ftSend(MyID).To
    Me.Height = 1890
  End If
  
  'See if file is sent
  If Sentbyt = ftSend(MyID).FileSize Then
    Complete = True
    Close #FileNum
    cmdCancelClose.Caption = "关闭窗口(&C)"
  End If
End Function

Private Sub wsSend_SendComplete()
  DoEvents
  If FileNum > 0 Then
      If Not Complete Then
      SendChunk
    Else
      If chkClose.Value = Checked Then
        wsSend.Close
        Unload Me
      End If
    End If
  End If
End Sub