关闭

VB 局域网传输工具(发送端)

3819人阅读 评论(2) 收藏 举报

VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.Form frmMain
   BorderStyle     =   1  'Fixed Single
   Caption         =   "程序之家局域网文件传输器发送端 V1.0"
   ClientHeight    =   3000
   ClientLeft      =   45
   ClientTop       =   435
   ClientWidth     =   5565
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   ScaleHeight     =   3000
   ScaleWidth      =   5565
   StartUpPosition =   1  '所有者中心
   Begin VB.CommandButton cmdCancel
      Cancel          =   -1  'True
      Caption         =   "退出(&C)"
      Height          =   315
      Left            =   4600
      TabIndex        =   5
      Top             =   895
      Width           =   855
   End
   Begin VB.TextBox textPort
      Height          =   270
      Left            =   3800
      TabIndex        =   1
      Text            =   "5300"
      Top             =   120
      Width           =   735
   End
   Begin SendFile.ProgressBar proBar
      Height          =   255
      Left            =   120
      TabIndex        =   8
      Top             =   925
      Width           =   4405
      _ExtentX        =   7779
      _ExtentY        =   450
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Value           =   0
   End
   Begin VB.ListBox lstMsg
      Height          =   1680
      Left            =   -10
      TabIndex        =   6
      Top             =   1320
      Width           =   5595
   End
   Begin SendFile.IPEditControl iPEdit
      Height          =   255
      Left            =   1320
      TabIndex        =   0
      Top             =   140
      Width           =   1645
      _extentx        =   2910
      _extenty        =   450
      backcolor       =   16777215
      font            =   "frmMain.frx":0000
   End
   Begin MSWinsockLib.Winsock wskSend
      Left            =   600
      Top             =   0
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
   End
   Begin VB.TextBox textPath
      Height          =   270
      Left            =   120
      TabIndex        =   2
      Top             =   520
      Width           =   4405
   End
   Begin VB.CommandButton cmdBrowse
      Caption         =   "浏览(&B)"
      Height          =   315
      Left            =   4600
      TabIndex        =   3
      Top             =   495
      Width           =   855
   End
   Begin VB.CommandButton cmdSend
      Caption         =   "传送(&S)"
      Height          =   315
      Left            =   4600
      TabIndex        =   4
      Top             =   95
      Width           =   855
   End
   Begin VB.Label lPort
      Caption         =   "端口号:"
      Height          =   255
      Left            =   3120
      TabIndex        =   9
      Top             =   160
      Width           =   635
   End
   Begin VB.Label lMessage
      Caption         =   "请输入IP地址:"
      Height          =   255
      Left            =   120
      TabIndex        =   7
      Top             =   160
      Width           =   1335
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'文件大小
Private fileSize As Long
'目前传送的字节总数
Private sendBytes As Long
'打开的文件句柄(如果要支持同时传送多个文件这里需要使用数组)或者自定义结构来完成,这样的话也就需要把WINSCOK定义成控件数组了。
Private hFile As Integer
'文件是否处于传送中
Private isOnSend As Boolean
'消息对话框
Private Declare Function MessageBox Lib "user32" Alias "MessageBoxA" (ByVal hWnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long
'调整LISTBOX水平滚动条的宽度的常数
Private Const LB_SETHORIZONTALEXTENT = &H194
'发送消息函数
Private Declare Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Any) As Long
'**********************************************************
'获取LISTBOX中最长字符串的宽度需要的结构和函数
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type POINTAPI
    y As Long
    x As Long
End Type
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
'**********************************************************
Private Declare Sub InitCommonControls Lib "comctl32.dll" ()
'不知道为什么一定得在UNLOAD事件或者在结束程序前运行一个中的到出函数才不会出错,不知道是不是微软的问题,我估计可能是资源文件的问题
Private Declare Function GetFileTitle Lib "comdlg32.dll" Alias "GetFileTitleA" (ByVal lpszFile As String, ByVal lpszTitle As String, ByVal cbBuf As Integer) As Integer

Private Sub Form_Initialize()
    InitCommonControls
End Sub

Private Sub cmdBrowse_Click()
    Dim strFile As String
    '打开浏览对话框
    strFile = ShowDialogFile(Me.hWnd, 1, "请选择需要传送的文件...", "", "文件 (*.*)" & Chr(0) & "*.*", "", "")
    '当用户选择了某个文件后
    If strFile <> "" Then
        textPath.Text = strFile
    End If
End Sub

Private Sub cmdCancel_Click()
    If cmdCancel.Caption = "退出(&C)" Then
        If isOnSend Then
            If MessageBox(0, "目前正在传送文件中,是否退出??", "提示", vbQuestion + vbYesNo) = vbYes Then
                wskSend.Close
                Unload Me: End
            End If
        Else
            Unload Me: End
        End If
    Else
        isOnSend = False
        wskSend.Close
        SetAppState True
        '恢复进度条默认进度为0
        Me.proBar.Value = 0
        sendBytes = 0
        lstMsg.AddItem "你已经取消了对IP为: " & iPEdit.IPAsString & " 文件传输。"
        SendMessage lstMsg.hWnd, LB_SETHORIZONTALEXTENT, ListTextWidth(lstMsg, "你已经取消了对IP为: " & iPEdit.IPAsString & " 文件传输。"), ByVal 0&
    End If
End Sub

Private Sub cmdSend_Click()
    '检测路径、IP地址、端口号的合法性
    If Me.iPEdit.IPAsString = "0.0.0.0" Then
        MsgBox "IP地址不能为空!!", vbInformation, "提示"
        iPEdit.SetFocus
        Exit Sub
    End If
    If Trim(textPort.Text) = "" Then
        MsgBox "端口号不能为空!!", vbInformation, "提示"
        textPort.SetFocus
        Exit Sub
    End If
    If Not IsNumeric(textPort.Text) Then
        MsgBox "端口号只能为1--65536之间的数字!!", , vbInformation, "提示"
        textPort.SetFocus
        Exit Sub
    Else
        If CLng(textPort.Text) > 65536 Then
            MsgBox "端口号不能大于65536", vbInformation, "提示"
            textPort.SetFocus
            Exit Sub
        End If
    End If
    If Trim(textPath.Text) = "" Then
        MsgBox "文件路径不能为空!!", vbInformation, "提示"
        Me.cmdBrowse.SetFocus
        Exit Sub
    End If
    If Dir(textPath.Text, 1 Or 2 Or 4) = "" Then
        MsgBox "传送的文件不存在!!", vbInformation, "提示"
        Me.cmdBrowse.SetFocus
        Exit Sub
    Else
        If FileLen(textPath.Text) < 1 Then
            MsgBox "传送的文件不能为0长度!!", vbInformation, "提示"
            Me.cmdBrowse.SetFocus
            Exit Sub
        End If
    End If
   
    If Me.wskSend.state = 0 Then
        '连接计算机
        ConnectUser
    Else
        On Error GoTo errLine
        Me.wskSend.SendData "SendFile**^_^**" & textPath.Text & "**^_^**" & iPEdit.IPAsString & "**^_^**" & CStr(FileLen(textPath.Text))
    End If
    Exit Sub
errLine:
    wskSend.Close
    lstMsg.AddItem "与对方中断了连接或者是对方退出了程序"
    SendMessage lstMsg.hWnd, LB_SETHORIZONTALEXTENT, ListTextWidth(lstMsg, "与对方中断了连接或者是对方退出了程序"), ByVal 0&
    SetAppState True
    '恢复进度条默认进度为0
    Me.proBar.Value = 0
End Sub

Private Sub Form_Load()
    lstMsg.AddItem "已经做好文件传输的准备了!!"
    SendMessage lstMsg.hWnd, LB_SETHORIZONTALEXTENT, ListTextWidth(lstMsg, "已经做好文件传输的准备了!!"), ByVal 0&
    Me.iPEdit.IPAsString = Me.wskSend.LocalIP
End Sub

Private Function ConnectUser() As Boolean
    '连接计算机
    If Me.wskSend.state = 0 Then
        Me.wskSend.RemotePort = Me.textPort.Text
        Me.wskSend.RemoteHost = Me.iPEdit.IPAsString
        Me.wskSend.Connect
    Else
        Me.wskSend.Close
        Me.wskSend.RemotePort = Me.textPort.Text
        Me.wskSend.RemoteHost = Me.iPEdit.IPAsString
        Me.wskSend.Connect
    End If
End Function

Private Sub Form_Unload(Cancel As Integer)
    '不知道为什么一定得在UNLOAD事件或者在结束程序前运行一个中的到出函数才不会出错,不知道是不是微软的问题,我估计可能是资源文件的问题
    Call GetFileTitle(vbNullString, vbNullString, 0)
    If isOnSend Then
        If MsgBox("程序正在发送文件中,是否退出?", vbQuestion + vbYesNo, "提示") = vbYes Then
            If MsgBox("是否访问作者论坛??", vbQuestion + vbYesNo, "提示") = vbYes Then Call ShowOemHttp
            Unload Me: End
        Else
            Cancel = 1
        End If
    End If
    If MsgBox("是否访问作者论坛??", vbQuestion + vbYesNo, "提示") = vbYes Then Call ShowOemHttp
End Sub

Private Sub ShowOemHttp()
    Shell "Explorer.exe /s,http://www.chenhui530.com"
End Sub

Private Sub textPort_GotFocus()
    textPort.SelStart = 0
    textPort.SelLength = Len(textPort.Text)
End Sub

Private Sub textPath_GotFocus()
    textPath.SelStart = 0
    textPath.SelLength = Len(textPath.Text)
End Sub

Private Sub wskSend_Connect()
    '设置传送浏览按钮和路径不能更改
    Call SetAppState(False)
    '自定义协议分段符号为"**^_^**"这个大家可以自己定义,但是最好定义不容易使用到的。其中第一段为消息名,后面是附加消息大家可以自己灵活使用
    Me.lstMsg.AddItem "已经连接上了IP为: " & iPEdit.IPAsString & " 的计算机了。"
    SendMessage lstMsg.hWnd, LB_SETHORIZONTALEXTENT, ListTextWidth(lstMsg, "已经连接上了IP为: " & iPEdit.IPAsString & " 的计算机了。"), ByVal 0&
    Me.wskSend.SendData "SendFile**^_^**" & textPath.Text & "**^_^**" & iPEdit.IPAsString & "**^_^**" & CStr(FileLen(textPath.Text))
End Sub

Private Sub wskSend_DataArrival(ByVal bytesTotal As Long)
    Dim strMessage As String
    Me.wskSend.GetData strMessage, vbString
    '过滤消息
    '如果对方返回同意消息则开始文件的传输
    If strMessage = "Agree" Then
        '纪录下文件的大小
        fileSize = FileLen(textPath.Text)
        '设置进度条的最大值
        Me.proBar.Max = fileSize
        '纪录文件号
        hFile = FreeFile
        '设置文件处于传输状态
        isOnSend = True
        Me.lstMsg.AddItem "正在给IP为: " & iPEdit.IPAsString & " 传送文件: " & textPath.Text
        '以二进制方式打开文件
        Open textPath.Text For Binary Shared As #hFile
        '开始传输文件
        Call SendTCPFile(wskSend)
    ElseIf strMessage = "ShutConnect" Then
        '对方中断了连接
        isOnSend = False
        wskSend.Close
        MessageBox 0, "IP为: " & iPEdit.IPAsString & " 中断了文件的传输", "提示", vbCritical
        lstMsg.AddItem "IP为: " & iPEdit.IPAsString & " 中断了文件的传输"
        SendMessage lstMsg.hWnd, LB_SETHORIZONTALEXTENT, ListTextWidth(lstMsg, "IP为: " & iPEdit.IPAsString & " 中断了文件的传输"), ByVal 0&
        SetAppState True
        '恢复进度条默认进度为0
        Me.proBar.Value = 0
        sendBytes = 0
    ElseIf strMessage = "DisAgree" Then
        '对方不同意
        MessageBox 0, "IP为: " & iPEdit.IPAsString & " 拒绝了你的请求", "提示", vbCritical
        lstMsg.AddItem "IP为: " & iPEdit.IPAsString & " 拒绝了你的请求"
        SendMessage lstMsg.hWnd, LB_SETHORIZONTALEXTENT, ListTextWidth(lstMsg, "IP为: " & iPEdit.IPAsString & " 拒绝了你的请求"), ByVal 0&
        SetAppState True
        '恢复进度条默认进度为0
        Me.proBar.Value = 0
        sendBytes = 0
    End If
End Sub

'设置窗体状态
Private Sub SetAppState(ByVal state As Boolean)
    If state Then
        cmdSend.Enabled = True
        cmdBrowse.Enabled = True
        iPEdit.Enabled = True
        textPort.Enabled = True
        cmdCancel.Caption = "退出(&C)"
        textPath.Enabled = True
        textPath.Text = ""
    Else
        cmdSend.Enabled = False
        cmdBrowse.Enabled = False
        iPEdit.Enabled = False
        textPort.Enabled = False
        cmdCancel.Caption = "取消(&C)"
        textPath.Enabled = False
    End If
End Sub

'当和对方失去连接等产生的事件
Private Sub wskSend_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)
    wskSend.Close
    lstMsg.AddItem "与IP为: " & iPEdit.IPAsString & " 中断了连接或者是对方退出了程序或者对方还没打开连接"
    SendMessage lstMsg.hWnd, LB_SETHORIZONTALEXTENT, ListTextWidth(lstMsg, "与IP为: " & iPEdit.IPAsString & " 中断了连接或者是对方退出了程序或者对方还没打开连接"), ByVal 0&
    SetAppState True
    '恢复进度条默认进度为0
    Me.proBar.Value = 0
    isOnSend = False
End Sub

'当完成一次发送产生的时间
Private Sub wskSend_SendComplete()
    '当处于文件传送中
    If isOnSend Then
        '当文件传输完毕时
        If sendBytes >= fileSize Then
            '显示完成消息
            lstMsg.AddItem "对IP为: " & iPEdit.IPAsString & " 的计算机文件传输完成!!"
            SendMessage lstMsg.hWnd, LB_SETHORIZONTALEXTENT, ListTextWidth(lstMsg, "对IP为: " & iPEdit.IPAsString & " 的计算机文件传输完成!!"), ByVal 0&
            MessageBox 0, "对IP为: " & iPEdit.IPAsString & " 的计算机文件传输完成!!", "提示", vbInformation
            '重新初始化计数
            sendBytes = 0
            Close #hFile
            isOnSend = False
            wskSend.Close
            '恢复传送浏览按钮和路径可用
            SetAppState True
            '恢复进度条默认进度为0
            Me.proBar.Value = 0
'            lstMsg.AddItem "已经做好文件传输的准备了!!"
        Else
            '当文件没传输完则继续传输
            SendTCPFile wskSend
        End If
    End If
End Sub

'文件传输函数
Private Sub SendTCPFile(wsk As Winsock)
    Dim bytes() As Byte
    '我设置的默认传输一次只传输64K大家可以适当的修改此值可以使速度大大提供
    If isOnSend Then
        If sendBytes = fileSize Then
            Exit Sub
        ElseIf sendBytes + 65536 > fileSize Then
            ReDim bytes(fileSize - sendBytes - 1)
            sendBytes = fileSize
        Else
            ReDim bytes(65535)
            sendBytes = sendBytes + 65536
        End If
        Get #hFile, , bytes
        On Error GoTo errLine
        DoEvents
        wsk.SendData bytes
        Me.proBar.Value = sendBytes
    End If
errLine:
End Sub

'获取LISTBOX的宽度
Private Function ListTextWidth(lstThis As ListBox, ByVal strMessage As String) As Long
    If lstThis.ListCount = 1 Then
        If strMessage <> "" Then
            If frmMain.ScaleX(lstThis.Width, vbTwips, vbPixels) < frmMain.ScaleX(frmMain.TextWidth(strMessage), vbTwips, vbPixels) Then
                ListTextWidth = frmMain.ScaleX(frmMain.TextWidth(strMessage), vbTwips, vbPixels) + 6
                Exit Function
            End If
        Else
            ListTextWidth = frmMain.ScaleX(lstThis.Width, vbTwips, vbPixels)
        End If
    End If
    Dim i As Long
    Dim tR As RECT
    Dim lW As Long
    Dim lWidth As Long
    Dim lHDC As Long

    With lstThis.Parent.Font
        .Name = lstThis.Font.Name
        .Size = lstThis.Font.Size
        .Bold = lstThis.Font.Bold
        .Italic = lstThis.Font.Italic
    End With
   
    lHDC = lstThis.Parent.hdc
   
    '遍历所有的列表项以找到最长的项
    For i = 0 To lstThis.ListCount - 1
        DrawText lHDC, lstThis.List(i), -1, tR, &H400
        lW = tR.Right - tR.Left + 8
        If (lW > lWidth) Then
            lWidth = lW
        End If
    Next i
       
    '返回最长列表项的长度(像素)
    ListTextWidth = lWidth
End Function

 

Attribute VB_Name = "modBrowsePath"
Option Explicit

Private Const BIF_RETURNONLYFSDIRS = 1

Private Const BIF_DONTGOBELOWDOMAIN = 2

Private Const OFN_HIDEREADONLY = &H4

Private Const OFN_PATHMUSTEXIST = &H800

Private Const OFN_FILEMUSTEXIST = &H1000

Private Const OFN_OVERWRITEPROMPT = &H2

Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long

Private Type OPENFILENAME
    lStructSize As Long
    hWnd As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    Flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type

'调用GetOpenFileName/GetSaveFileName函数打开浏览话框,当wMode值为1是打开浏览对话框当为其他值是保存文件对话框
Public Function ShowDialogFile(hWnd As Long, wMode As Integer, szDialogTitle As String, szFilename As String, szFilter As String, szDefDir As String, szDefExt As String) As String
    Dim x As Long, OFN As OPENFILENAME, szFile As String, szFileTitle As String
   
    OFN.lStructSize = Len(OFN)
    OFN.hWnd = hWnd
    OFN.lpstrTitle = szDialogTitle
    OFN.lpstrFile = szFilename & String$(250 - Len(szFilename), 0)
    OFN.nMaxFile = 255
    OFN.lpstrFileTitle = String$(255, 0)
    OFN.nMaxFileTitle = 255
    OFN.lpstrFilter = szFilter
    OFN.nFilterIndex = 1
    OFN.lpstrInitialDir = szDefDir
    OFN.lpstrDefExt = szDefExt

    If wMode = 1 Then
        OFN.Flags = OFN_HIDEREADONLY Or OFN_PATHMUSTEXIST Or OFN_FILEMUSTEXIST
        x = GetOpenFileName(OFN)
    Else
        OFN.Flags = OFN_HIDEREADONLY Or OFN_OVERWRITEPROMPT Or OFN_PATHMUSTEXIST
        x = GetSaveFileName(OFN)
    End If
   
    If x <> 0 Then
        If InStr(OFN.lpstrFile, Chr$(0)) > 0 Then
            szFile = Left$(OFN.lpstrFile, InStr(OFN.lpstrFile, Chr$(0)) - 1)
        End If
        ShowDialogFile = szFile
    Else
        ShowDialogFile = ""
    End If
   
End Function


 

0
0

查看评论
* 以上用户言论只代表其个人观点,不代表CSDN网站的观点或立场
    个人资料
    • 访问:326825次
    • 积分:4463
    • 等级:
    • 排名:第7122名
    • 原创:81篇
    • 转载:0篇
    • 译文:2篇
    • 评论:434条
    文章分类
    最新评论
    chenhui530新浪博客