form4.frm

来自「用vb编的网络聊天程序」· FRM 代码 · 共 287 行

VERSION 5.00
Begin VB.Form Form4 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "File Transfering"
   ClientHeight    =   1155
   ClientLeft      =   1950
   ClientTop       =   2805
   ClientWidth     =   3780
   Icon            =   "Form4.frx":0000
   LinkTopic       =   "Form4"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   1155
   ScaleWidth      =   3780
   StartUpPosition =   1  '所有者中心
   Begin VB.PictureBox Picture1 
      Height          =   264
      Left            =   252
      ScaleHeight     =   210
      ScaleWidth      =   3300
      TabIndex        =   1
      Top             =   216
      Width           =   3360
      Begin VB.Label Label1 
         Alignment       =   2  'Center
         BackColor       =   &H8000000D&
         Caption         =   "Label1"
         ForeColor       =   &H8000000E&
         Height          =   225
         Left            =   0
         TabIndex        =   2
         Top             =   0
         Width           =   3315
      End
   End
   Begin VB.CommandButton Command1 
      Caption         =   "&Cancel"
      Height          =   336
      Left            =   936
      TabIndex        =   0
      Top             =   684
      Width           =   1560
   End
End
Attribute VB_Name = "Form4"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private lngFile As Long


Private Sub ClearTrans()
    Close #lngFile
    lngFile = 0
    
    Hide
End Sub


Private Sub CancelTrans()
    'tell remote we need cancel
    Form1.SendMessage -1, -1, TM_FILECANCEL, , "Transfering canceled."
    
    ClearTrans
End Sub

Private Sub Command1_Click()
    On Error GoTo ErrorHandle
    CancelTrans
    Exit Sub
    
ErrorHandle:
    ShowErr
End Sub

Private Sub Form_Load()
    On Error GoTo ErrorHandle
    Label1 = vbNullString
    Label1.Width = 0
    Exit Sub
    
ErrorHandle:
    ShowErr
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    On Error GoTo ErrorHandle
    If Button = vbMiddleButton Then Command1.Value = True
    Exit Sub
    
ErrorHandle:
    ShowErr
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    On Error GoTo ErrorHandle

    'if transfering started, stop it
    If lngFile Then CancelTrans
    
    If UnloadMode <> vbFormCode Then
        'avoid user close this window
        PostMessage hwnd, &H208, 0, 0
        Cancel = True
    End If
    Exit Sub
    
ErrorHandle:
    ShowErr
End Sub

Private Sub SetProgress(ByVal Percent As Double)
    Label1.Width = Picture1.Width * Percent
    DoEvents
End Sub


Friend Sub FileTransfer()

    If lngFile Then MsgBox "Transfering already started.", vbExclamation: Exit Sub
    
    'get the file
    Dim s As String
    s = OpenFileDlg(hwnd, 0)
    
    
    'open it
    Dim l As Long
    l = FreeFile()
    Open s For Binary Access Read As #l
    
    lngFile = l
    
    'get it's filename without path
    
    l = InStr(s, ":")
    If l Then s = Mid$(s, l + 1)
    Do
        l = InStr(s, "\")
        If l = 0 Then Exit Do
        s = Mid$(s, l + 1)
    Loop
    
    'tell remote we need start
    Form1.SendMessage -1, -1, TM_FILETRANS, LOF(lngFile), s
    
End Sub


Friend Sub OnMessage(ByVal Address As Long, ByVal Port As Integer, ByVal Handle As Long, ByVal Param As Long, Data As Variant)
    Select Case Handle
        Case TM_FILETRANS
            If lngFile Then
                'we already started a transfering
                Form1.SendMessage -1, -1, TM_FILECANCEL, , "Transfer already started."
                
            ElseIf MsgBox("Accept file: """ & Data & """?", vbQuestion + vbYesNo) <> vbYes Then
                'tell remote we need cancel
                Form1.SendMessage -1, -1, TM_FILECANCEL, , "Transfer canceled by remote."
                
            Else
                
                'get default receive path
                Static s As String
                s = App.Path & "\Received Files\"
                If Len(Dir$(s, vbDirectory)) <= 0 Then MkDir s
                
                'add path to filename
                s = s & Data
                
                'open it
                Dim l As Long
                l = FreeFile()
                
                Dim ls As Long
                If Len(Dir$(s)) > 0 Then
                    'file exists
                    Select Case MsgBox("File """ & s & """ exists, overwrite ?" & vbCrLf & "'Yes' for overwriting, 'No' for appendding", vbYesNoCancel + vbExclamation)
                    Case vbYes
                        Kill s
                        ls = 1
                        
                    Case vbNo
                        ls = FileLen(s) + 1
                        
                    Case Else
                        'we need cancel
                        Form1.SendMessage -1, -1, TM_FILECANCEL, , "Transfer canceled by remote."
                        Exit Sub
                        
                    End Select
                    
                Else
                    ls = 1
                    
                End If
                        
                Open s For Binary Access Write As #l
                lngFile = l
                
                'store the file lengh
                Static lFileLen As Long
                lFileLen = Param
                
                'tell remote we need start on position 1
                Form1.SendMessage -1, -1, TM_FILEBEGIN, -ls
                
                SetProgress 0
                
                'show me
                Show vbModeless, Form1
            
            End If
            
        Case TM_FILEBEGIN
        
            If Param < 0 Then
                Param = -Param
                
                SetProgress 0
                
                'show me
                Show vbModeless, Form1
            End If
        
            l = LOF(lngFile) - Param + 1
            If l <= 0 Then
                
                'at the end of the file
                'stop
                Form1.SendMessage -1, -1, TM_FILEEND
                
                'clear me
                ClearTrans
                
            Else
        
                'max size 1024
                If l > 4096 Then l = 4096
            
                'get data
                Dim bt() As Byte
                ReDim bt(l - 1)
                Get #lngFile, Param, bt
                
                'send to remote
                Form1.SendMessage -1, -1, TM_FILEDATA, Param, bt
                
                'refresh progress bar
                SetProgress (Param + l) / LOF(lngFile)
                
            End If
            
            
        Case TM_FILEDATA
        
            'new data package arrival
            bt = Data
            
            Put #lngFile, Param, bt
            Form1.SendMessage -1, -1, TM_FILEBEGIN, Param + UBound(bt) + 1
            
            'refresh progress bar
            SetProgress Param / lFileLen
        
        Case TM_FILEEND
            'stop it
            ClearTrans
            
            If MsgBox("Open file '" & s & "' ?", vbYesNo + vbQuestion) <> vbYes Then Exit Sub
            
            Shell "explorer """ & s & """", vbNormalFocus
            
            
        Case TM_FILECANCEL
            'cancel it
            
            ClearTrans
            
            'show why canceled.
            If Len(Data) > 0 Then MsgBox Data, vbExclamation
    End Select
End Sub