求救～如果用WINSOCK传送文件？

Question

temp是string型的，无法正确保存你GET出的数据，需要用vbByte + vbArray我也在做类似的东西，做好以后帖给你看

Answer 1

这是我写的一段代码，还有的我没贴，可能有点看不明白，但主要的都在这里了：
Option Explicit
Dim Fnum As Integer '文件号
Dim bChunk() As Byte    '文件包
Const cChunkSize = 16384    '文件分组大小
Dim iRemainder As Integer   '不够一个分组数据的字节长度
Private Sub Send(index As Integer)
        '数据发送模块
        Dim RecCount As Integer
        Dim EndTime As Variant
        Dim I As Long
        Dim L As Long
        Dim Tmp As String
        Const ChunkSize = 16384
        On Error Resume Next
                
        Socket(index - 1).LastCmd = "Put"
        Socket(index - 1).Sendcompleted = False
        
        If Dir(Socket(index - 1).RightPath & "send\*.*") <> "" Then
            Socket(index - 1).sFileName = "new.arj"
            
            EndTime = DateAdd("s", 20, Now)
            Do
                Socket(index - 1).lFileLen = FileSystem.FileLen(Socket(index - 1).RightPath & "send\new.arj")
                If Socket(index - 1).lFileLen <> 0 Then Exit Do
                DoEvents
            Loop Until Now > EndTime
            
            'Socket(index - 1).lFileLen = FileSystem.FileLen(Socket(index - 1).RightPath & "send\new.arj")
            RTB.Text = RTB.Text & "发送文件NEW.ARJ(" & Socket(index - 1).lFileLen & ") TO " & Socket(index - 1).LoginName & vbCrLf
            Tmp = Socket(index - 1).lFileLen
            Socket(index - 1).SendReady = False
            Socket(index - 1).bBZ = False
            Winsock1(index).SendData Tmp
            DoEvents
            EndTime = DateAdd("s", 20, Now)
            DoEvents
            Do
                DoEvents
                    If Socket(index - 1).SendReady = True And Socket(index - 1).bBZ = True Then Exit Do
                     DoEvents                    If Now > EndTime Then
                         Exit Do
                    End If
            Loop
            Socket(index - 1).iNUM = FreeFile
                
            Open Socket(index - 1).RightPath & "send\new.arj" For Binary Access Read Lock Read As #Socket(index - 1).iNUM
            Socket(index - 1).lWhole = Socket(index - 1).lFileLen \ 16384
            ReDim Socket(index - 1).bChunk(ChunkSize - 1)
            Socket(index - 1).lRemainder = Socket(index - 1).lFileLen Mod ChunkSize
                Socket(index - 1).bBZ = False
                For L = 1 To Socket(0).lWhole
                    Socket(index - 1).SendReady = False
                    DoEvents
                    Get #Socket(index - 1).iNUM, , Socket(index - 1).bChunk()
                    Winsock1(index).SendData Socket(index - 1).bChunk()
                    DoEvents
                    EndTime = DateAdd("s", 10, Now)
                    Do
                        DoEvents
                        If Socket(index - 1).SendReady = True Then Exit Do
                    Loop Until Now > EndTime
                Next L
                If Socket(index - 1).lRemainder > 0 Then
                    Socket(0).SendReady = False
                    ReDim Chunk(Socket(index - 1).lRemainder - 1)
                    Get #Socket(index - 1).iNUM, , Socket(index - 1).bChunk()
                    Winsock1(index).SendData Socket(index - 1).bChunk()
                    DoEvents
                    EndTime = DateAdd("s", 20, Now)
                    DoEvents
                    Do
                        DoEvents
                    Loop Until Socket(index - 1).SendReady = True Or Now > EndTime
                    
                End If
                DoEvents
                Close #Socket(index - 1).iNUM
              
                DoEvents
                
                EndTime = DateAdd("s", 20, Now)
                Do
                    DoEvents
                    If Socket(index - 1).Sendcompleted = True Then
                        DoEvents
                        Kill Socket(index - 1).RightPath & "send\*.*"
                        DoEvents
                        RTB.Text = RTB.Text & "发送文件(TO " & Socket(index - 1).LoginName & ")成功" & vbCrLf                        Exit Do
                    End If
                Loop Until Now > EndTime
                
        Else
            Winsock1(index).SendData "No"
        End If
        Socket(index - 1).LastCmd = ""End SubPrivate Sub cSysTray1_MouseDown(Button As Integer, ID As Long)
    '显示界面
    If Me.cSysTray1.InTray = True Then
        Me.cSysTray1.InTray = False    End If
    Me.WindowState = 2
    Me.ShowEnd SubPrivate Sub Form_Load()
'完成地址及端口的初始化
'这里取出的是本机的IP地址，如果是拔号上网，则远程端应该填入SERVER端ISP分配的地址
'如果是点对点,则应该填入192.168.55.1
'端口为 8888
'所以该SERVER端的SOCKET套结字(例:192.168.55.1:8888)Winsock1(0).LocalPort = 8888ReDim Socket(0) As SockStatusType   '初始化SOCKET数组
'Socket(0).SendReady = True
'Socket(0).LocalPort = 5001
If Winsock1(0).State <> sckClosed Then
    Winsock1(0).Close
End If
On Error GoTo LWinsock1(0).Listen
GoTo k
L:
    Winsock1(0).LocalPort = Winsock1(0).LocalPort + 1
    Resume
k:
   
sStart.Enabled = False
sStop.Enabled = True
RTB.Text = "WINSOCKET 在地址 " & Winsock1(0).LocalIP & " 端口 " & Winsock1(0).LocalPort & " 上开始侦听" & vbCrLf
Stb.Panels(1).Text = "服务已经启动，等待接入..."mnuHand.Enabled = TrueIf Dir("c:\mis2000\arj.exe") = "" Then
    MsgBox "C:\MIS2000 目录下缺少 ARJ.EXE 文件", vbInformation, "提示信息"
End If
gnNumSockets = 1    '初始化通讯连接SOCKET个数End SubPrivate Sub Form_Resize()
    
    '************* 当界面最小化时,程序放入系统任务栏
    
    If Me.WindowState = 1 Then
        If Me.cSysTray1.InTray = False Then
            Me.cSysTray1.InTray = True
        End If
        
        Me.Hide
    End If
End SubPrivate Sub Form_Unload(Cancel As Integer)
sStop_Click
End
End Sub
Private Sub mnuAuto_Click()
    '******* 自动接收数据
    
    mnuAuto.Checked = Not mnuAuto.Checked
    If mnuAuto.Checked = True Then
        mnuHand.Enabled = True
    Else
        mnuHand.Enabled = True
    End If
End SubPrivate Sub mnuClear_Click()
    '清屏
    
    RTB.Text = ""
    mnuSave.Enabled = False
    mnuClear.Enabled = False
    RTB.Locked = True
End SubPrivate Sub mnuExit_Click()
    '退出
    
    Unload Me
End SubPrivate Sub mnuHand_Click()
    '显示远程管理模块
    
    frmYcgl.Show 1
End SubPrivate Sub mnuOpen_Click()
    '打开历史文件
    
    Dim Log As String
    CDlog.InitDir = App.Path & "\log"
    CDlog.DefaultExt = "*.log"
    CDlog.Filter = "log文件|*.log"
    CDlog.ShowOpen
    
    Log = CDlog.FileName
    RTB.FileName = Log
        
End SubPrivate Sub mnuSave_Click()
    '保存提示信息
    
    Dim sMn As String
    
    sMn = FileSystem.Dir(App.Path & "\log", vbDirectory)
    If sMn = "" Then
        MkDir App.Path & "\log"
    End If
    sMn = Format(Date, "mmdd")
     
    RTB.SaveFile App.Path & "\log\" & sMn & ".log"
    
    
    
End SubPrivate Sub mnuUR_Click()
    '用户与权限管理
    
    frmUR.Show 1
End SubPrivate Sub RTB_Change()
    
If RTB.Text <> "" Then
    mnuSave.Enabled = True
    mnuClear.Enabled = True
End If
End SubPrivate Sub RTB_MouseUp(Button As Integer, Shift As Integer, x As Single, Y As Single)
    '右键弹出菜单
    
    If Button = 2 Then
        If RTB.Text = "" Then
            mnuSave.Enabled = False
            mnuClear.Enabled = False
        Else
            mnuSave.Enabled = True
            mnuClear.Enabled = True
        End If
        PopupMenu mnuFile    End If
End SubPrivate Sub sStart_Click()
'启动服务If Winsock1(0).State <> sckClosed Then
    Winsock1(0).Close
End If
Winsock1(0).Listen
'Socket().SendBZ = 1sStart.Enabled = False
sStop.Enabled = True
End Sub
Private Sub sStop_Click()
'停止服务Dim I As Integer
On Error Resume Nex

Answer 2

Private Sub Winsock1_Close(index As Integer)
'第INDEX个WINSOCK断开
'恢复SOCKET状态
On Error Resume Next
Close #Socket(index - 1).iNUM
RTB.Text = RTB.Text & "用户 " & Socket(index - 1).LoginName & " 已经断开" & vbCrLf
Winsock1(index).Close
Unload Winsock1(index)
Socket(index - 1).Connected = False
Socket(index - 1).LoginName = ""
Socket(index - 1).SendReady = True
Socket(index - 1).SendBZ = 1
Socket(index - 1).LastCmd = ""
Socket(index - 1).lFileLen = 0If index = 0 Then
    sStart.Enabled = True
    sStop.Enabled = False
End IfEnd SubPrivate Sub Winsock1_ConnectionRequest(index As Integer, ByVal requestID As Long)
'收到连接请求Dim I As Integer
Dim k As Long
Dim bBZ As BooleanbBZ = False
'在现有的
For I = 0 To gnNumSockets - 1
    If Socket(I).Connected = False Then
        Load Winsock1(I + 1)
        Winsock1(I + 1).Accept requestID
        Socket(I).Connected = True
        Socket(I).SendBZ = 1
        Socket(I).ErrNum = 0
        Socket(I).LastCmd = ""
        Socket(I).SendReady = True
        bBZ = True
        Exit For
    End If
'    DoEvents
Next I
'DoEvents
If bBZ = False Then
    
    gnNumSockets = gnNumSockets + 1
    ReDim Preserve Socket(gnNumSockets - 1) As SockStatusType
    Load Winsock1(gnNumSockets)
    Winsock1(gnNumSockets).Accept requestID
    Socket(gnNumSockets - 1).Connected = True
    Socket(gnNumSockets - 1).SendReady = True
    Socket(gnNumSockets - 1).LastCmd = ""
    Socket(gnNumSockets - 1).ErrNum = 0
    Socket(gnNumSockets - 1).SendBZ = 1
End IfRTB.Text = RTB.Text & "用户开始连接..." & vbCrLfEnd SubPrivate Sub Winsock1_DataArrival(index As Integer, ByVal bytesTotal As Long)
'数据触发Dim tmpS As String
Dim Cmd As String
Dim data As String
Dim record As String
Dim I As Long
Dim L As Long
Dim k As Integer
Dim MyFile As String
Dim Tmp As String
Dim sDATA As String
Dim EndTime As Variant
Const ChunkSize = 16384Select Case Socket(index - 1).SendBZ
    
    Case 1
                
        MyFile = App.Path & "\misjxc.dat"
        
        Winsock1(index).GetData tmpS
        On Error Resume Next
        Cmd = VBA.Left$(tmpS, 3)
        data = Mid(tmpS, 4, Len(tmpS) - 3)
        If Socket(index - 1).LastCmd = "Put" Then
            Select Case tmpS
                Case "Give me file!"
                    Socket(index - 1).bBZ = True
                    Exit Sub
                Case "Next"
                    Socket(index - 1).Sendcompleted = True
                    Exit Sub
            End Select
            
        End If
        Select Case Cmd
            Case "use"
                I = GetUserPassword(MyFile)
                '检查该用户是否已经登录
                For k = 0 To gnNumSockets - 1
                    If Socket(k).LoginName = data And Socket(k).Connected = True Then
                        Winsock1(index).SendData "no"
                        Exit Sub
                    End If
                Next k
                '****** end check                If I <> 0 Then
                    For L = 1 To I
                        If UserPWD(L - 1).user = data Then
                            Winsock1(index).SendData "ok"
                            
                            
                            Socket(index - 1).LoginName = data
                            
                            Socket(index - 1).PassWord = UserPWD(L - 1).PassWord
                            Socket(index - 1).RightPath = UserPWD(L - 1).Path
                            RTB.Text = RTB.Text & data & "  登录" & vbCrLf
                            Exit Sub
                        End If
                    Next
                    Winsock1(index).SendData "no"
                    Socket(index - 1).ErrNum = Socket(index - 1).ErrNum + 1
                    If Socket(index - 1).ErrNum > 3 Then Winsock1_Close index
                End If
            Case "pwd"
                
                If data = Socket(index - 1).PassWord Then
                    Winsock1(index).SendData "ok"
                    If Dir(Socket(index - 1).RightPath & "send\new.arj") <> "" Then
                        Kill Socket(index - 1).RightPath & "send\new.arj"
                    End If
                    I = Shell("c:\mis2000\arj.exe a " & Socket(index - 1).RightPath & "send\new.arj " & Socket(index - 1).RightPath & "send\*.* -y ", vbHide)
                    RTB.Text = RTB.Text & "登录成功" & vbCrLf                Else
                    Winsock1(index).SendData "no"
                    Socket(index - 1).ErrNum = Socket(index - 1).ErrNum + 1
                    RTB.Text = RTB.Text & "密码错误" & vbCrLf
'                    If Socket(0).ErrNum > 3 Then Winsock1_Close index
                End If
                Exit Sub
            
            Case "Get"
                Call Send(index)
                Exit Sub
                
            Case "Put"              'put
                    
                        Socket(index - 1).sFileName = "new.arj"
                        I = Right(tmpS, Len(tmpS) - 3)
                        If I = 0 Then Exit Sub
                        Socket(index - 1).lFileLen = I
                        Socket(index - 1).iNUM = FreeFile
        
                        Open Socket(index - 1).RightPath & "get\" & Socket(index - 1).sFileName For Binary Access Write As #Socket(index - 1).iNUM
                        Socket(index - 1).SendBZ = 2
                        frmServer.Caption = Socket(index - 1).sFileName & Socket(index - 1).lFileLen
                        RTB.Text = RTB.Text & "接收文件NEW.ARJ(" & Socket(index - 1).lFileLen & ") From " & Socket(index - 1).LoginName & vbCrLf
                        Winsock1(index).SendData "Give me file!"
            End Select
    Case 2
    '接收文件
        ReDim Socket(index - 1).bChunk(bytesTotal - 1)
        Winsock1(index).GetData Socket(index - 1).bChunk(), vbByte
        Put #Socket(index - 1).iNUM, , Socket(index - 1).bChunk()
        Socket(index - 1).lFileLen = Socket(index - 1).lFileLen - bytesTotal
        If Socket(index - 1).lFileLen < 1 Then
            Close #Socket(index - 1).iNUM
            RTB.Text = RTB.Text & "接收文件成功 From " & Socket(index - 1).LoginName & vbCrLf
            Shell "c:\mis2000\arj.exe e " & Socket(index - 1).RightPath & "get\new.arj " & Socket(index - 1).RightPath & "get -y ", vbHide
            Socket(index - 1).SendBZ = 1
            Socket(index - 1).sFileName = ""
            Socket(index - 1).lFileLen = 0
            Winsock1(index).SendData "Next"
        End If
    End SelectEnd SubPrivate Sub Winsock1_SendComplete(index As Integer)
    'SOCKET(INDEX)发送完成
    Socket(index - 1).SendReady = True
End Sub