windproc.bas

运行多用户

        'no existing file
        retf = send_reply("550 RETR command not executed: " & Error$, FTP_Index)
        retf = close_data_connect(FTP_Index)
      Else
        frmFTP.StatusBar.Panels(1) = "Error " & Err.Number & " occurred."
        retf = close_data_connect(FTP_Index)
        retf = logoff(FTP_Index)
      End If
    Else
      retf = send_reply("530 User not logged in.", FTP_Index)
    End If
'MsgBox App.ThreadID & " done his retr duty as " & users(FTP_Index).data_representation
  Case "STOR" 'STOR <pathname>
    If users(FTP_Index).State = 3 Then
      Full_Name = ChkPath(FTP_Index, FTP_Args(0))
      'controls access rights
'      DummyS = UserIDs.No(users(FTP_Index).list_index).Priv(1).Accs
      
      DirFnd = False
      PathName = LCase$(Left(Full_Name, InStrRev(Full_Name, "\")))
      For i = 1 To UserIDs.No(users(FTP_Index).list_index).Pcnt
        If LCase$(UserIDs.No(users(FTP_Index).list_index).Priv(i).Path) = PathName Then
        'To do drive letter permissions use this line
        'If Left(UserIDs.No(users(FTP_Index).list_index).Priv(i).Path, 2) = Drv Then
          DummyS = UserIDs.No(users(FTP_Index).list_index).Priv(i).Accs
          DirFnd = True
          Exit For
        End If
      Next
  
      If InStr(DummyS, "W") And DirFnd Then
        If Not open_file Then
          Open Full_Name For Binary Access Write Lock Read Write As #FTP_Index
          open_file = True
        End If
        retf = open_data_connect(FTP_Index)
        Do
          If users(FTP_Index).data_representation = "A" Then
            retf = receive_data(Buffer, FTP_Index)
            If retf < 0 Then   'SOCKET_ERROR
              retf = WSAGetLastError()
              If retf = WSAEWOULDBLOCK Then   'try_again
              Else       'error on receiving
                error_on_data_cnt = True
                close_data_cnt = True
              End If
            ElseIf retf = 0 Then  'connection closed by peer
              close_data_cnt = True
            Else 'retf > 0  write on file
              Dummy$ = Left$(Buffer, retf)
              Print #FTP_Index, Dummy$
            End If
          Else  'binary transfer
            retf = receive_data(Buffer, FTP_Index)
            If retf < 0 Then
              retf = WSAGetLastError()
              If retf = WSAEWOULDBLOCK Then  'try again
              Else
                error_on_data_cnt = True
                close_data_cnt = True
              End If
            ElseIf retf = 0 Then     'connection closed by peer
              close_data_cnt = True
            Else
              Dummy$ = Left$(Buffer, retf)
              Put #FTP_Index, , Dummy$
            End If
          End If
        Loop Until close_data_cnt
        If close_data_cnt Then   're-initialize files_info record
          'files_info(Index).open_file = False
          'files_info(Index).next_block = 0 'blocks count
          'files_info(Index).next_byte = 0  'pointer to next block
          'files_info(Index).try_again = False
          Close #FTP_Index    'close file
          If error_on_data_cnt Then    'replies to user
            retf = send_reply("550 STOR command not executed.", FTP_Index)
          Else
            retf = send_reply("226 STOR command completed.", FTP_Index)
          End If
          retf = close_data_connect(FTP_Index)     'closes data connection
          
        End If
      Else
        'the user can't stores files
        retf = send_reply("550 You can't take this file action.", FTP_Index)
        retf = close_data_connect(FTP_Index)
      End If
    Else
      retf = send_reply("530 User not logged in.", FTP_Index)
    End If
MsgBox App.ThreadID & " done his stor duty as " & users(FTP_Index).data_representation
  Case "RNFR"  'RNFR <pathname>
    If users(FTP_Index).State = 2 Then
      Full_Name = ChkPath(FTP_Index, FTP_Args(0))
      'file exists?
      i = FileLen(Full_Name)
      If Err.Number = 0 Then 'Yes
        'controls access rights
        DummyS = UserIDs.No(users(FTP_Index).list_index).Priv(1).Accs
        If InStr(DummyS, "M") Then
          'The user can updates files.
          'The name of file to rename is temporarily stored in the user record.
          users(FTP_Index).temp_data = Full_Name
          'next command must be a RNTO
          users(FTP_Index).State = 6
          retf = send_reply("350 ReName command expect further information.", FTP_Index)
        Else
          'the user can't writes on files
          retf = send_reply("550 You can't take this file action.", FTP_Index)
        End If
      ElseIf (Err.Number > 51 And Err.Number < 77) Or (Err.Number > 707 And Err.Number < 732) Then
        'no existing file
        retf = send_reply("550 RNFR command not executed: " & Error$, FTP_Index)
      Else
   '     frmFTP.StatusBar.Panels(1) = "Error " & Err.Number & " occurred."
        retf = logoff(FTP_Index)
        'End
      End If
    Else
      retf = send_reply("530 User not logged in.", FTP_Index)
    End If
  
  Case "RNTO"  'RNTO <pathname>
    If users(FTP_Index).State = 6 Then
      Full_Name = ChkPath(FTP_Index, FTP_Args(0))
      Name users(FTP_Index).temp_data As Full_Name
      If Err.Number = 0 Then
        users(FTP_Index).State = 2
        'file exists
        retf = send_reply("350 ReName command executed.", FTP_Index)
      ElseIf (Err.Number > 51 And Err.Number < 77) Or (Err.Number > 707 And Err.Number < 732) Then
        'no existing file
        retf = send_reply("550 RNTO command not executed: " & Error$, FTP_Index)
      Else
  '      frmFTP.StatusBar.Panels(1) = "Error " & Err.Number & " occurred."
        retf = logoff(FTP_Index)
        'End
      End If
    Else
      retf = send_reply("530 User not logged in.", FTP_Index)
    End If
    
  Case "DELE"  'DELE <pathname>
    If users(FTP_Index).State = 2 Then
      Full_Name = ChkPath(FTP_Index, FTP_Args(0))
      'controls access rights
      'DummyS = UserIDs.No(users(FTP_Index).list_index).Priv(1).Accs
      'If InStr(DummyS, "K") Then
      DirFnd = False
      PathName = Left(Full_Name, InStrRev(Full_Name, "\"))
      For i = 1 To UserIDs.No(users(FTP_Index).list_index).Pcnt
        If UserIDs.No(users(FTP_Index).list_index).Priv(i).Path = PathName Then
        'To do drive letter permissions use this line
        'If Left(UserIDs.No(users(FTP_Index).list_index).Priv(i).Path, 2) = Drv Then
          DummyS = UserIDs.No(users(FTP_Index).list_index).Priv(i).Accs
          DirFnd = True
          Exit For
        End If
      Next
  
      If InStr(DummyS, "K") And DirFnd Then
        'the user can updates files
        Kill Full_Name
        If Err.Number = 0 Then
          'file exists
          retf = send_reply("250 DELE command executed.", FTP_Index)
        ElseIf (Err.Number > 51 And Err.Number < 77) Or (Err.Number > 707 And Err.Number < 732) Then
          'file no exists
          retf = send_reply("550 DELE command not executed: " & Error$, FTP_Index)
        Else
    '      frmFTP.StatusBar.Panels(1) = "Error " & Err.Number & " occurred."
          retf = logoff(FTP_Index)
          'End
        End If
      Else
        'the user can't delete files
        retf = send_reply("550 You can't take this file action.", FTP_Index)
      End If
    Else
      retf = send_reply("530 User not logged in.", FTP_Index)
    End If
    
  Case "RMD", "XRMD" 'RMD <pathname>
    If users(FTP_Index).State = 2 Then
      PathName = ChkPath(FTP_Index, FTP_Args(0))
      'controls access rights
      'DummyS = UserIDs.No(users(FTP_Index).list_index).Priv(1).Accs
      'If InStr(DummyS, "D") Then
      DirFnd = False
      For i = 1 To UserIDs.No(users(FTP_Index).list_index).Pcnt
        If UserIDs.No(users(FTP_Index).list_index).Priv(i).Path = PathName Then
        'To do drive letter permissions use this line
        'If Left(UserIDs.No(users(FTP_Index).list_index).Priv(i).Path, 2) = Drv Then
          DummyS = UserIDs.No(users(FTP_Index).list_index).Priv(i).Accs
          DirFnd = True
          Exit For
        End If
      Next
  
      If InStr(DummyS, "K") And DirFnd Then
        'the user can updates files
        Kill PathName & "\*.*"
        If Err.Number = 53 Or Err.Number = 708 Then Err.Number = 0 'empty directory
        RmDir PathName
        If Err.Number = 0 Then
          'directory exists
          retf = send_reply("250 RMD command executed.", FTP_Index)
        ElseIf (Err.Number > 51 And Err.Number < 77) Or (Err.Number > 707 And Err.Number < 732) Then
          'directory no exists
          retf = send_reply("550 RMD command not executed: " & Error$, FTP_Index)
        Else
   '       frmFTP.StatusBar.Panels(1) = "Error " & Err.Number & " occurred."
          retf = logoff(FTP_Index)
          'End
        End If
      Else
        'the user can't delete files
        retf = send_reply("550 You can't take this file action.", FTP_Index)
      End If
    Else
      retf = send_reply("530 User not logged in.", FTP_Index)
    End If
  
  Case "MKD", "XMKD" 'MKD <pathname>
    If users(FTP_Index).State = 2 Then
      PathName = ChkPath(FTP_Index, FTP_Args(0))
      'controls access rights
      'DummyS = UserIDs.No(users(FTP_Index).list_index).Priv(1).Accs
      'If InStr(DummyS, "M") Then
      DirFnd = False
      For i = 1 To UserIDs.No(users(FTP_Index).list_index).Pcnt
        If UserIDs.No(users(FTP_Index).list_index).Priv(i).Path = PathName Then
        'To do drive letter permissions use this line
        'If Left(UserIDs.No(users(FTP_Index).list_index).Priv(i).Path, 2) = Drv Then
          DummyS = UserIDs.No(users(FTP_Index).list_index).Priv(i).Accs
          DirFnd = True
          Exit For
        End If
      Next
  
      If InStr(DummyS, "M") And DirFnd Then
        'the user can updates files
        MkDir PathName
        If Err.Number = 0 Then
          'the directory is been created
          retf = send_reply("257 " & FTP_Args(0) & " created.", FTP_Index)
        ElseIf (Err.Number > 51 And Err.Number < 77) Or (Err.Number > 707 And Err.Number < 732) Then
          'the directory isn't been created
          retf = send_reply("550 MKD command not executed: " & Error$, FTP_Index)
        Else
     '     frmFTP.StatusBar.Panels(1) = "Error " & Err.Number & " occurred."
          retf = logoff(FTP_Index)
          'End
        End If
      Else
        'the user can't write on files
        retf = send_reply("550 You can't take this file action.", FTP_Index)
      End If
    Else
      retf = send_reply("530 User not logged in.", FTP_Index)
    End If
  
  Case "PWD", "XPWD" 'PWD
    If users(FTP_Index).State = 2 Then
      PathName = users(FTP_Index).cur_dir
      'Who doesn't want to know the the drive they are on?
      'PathName = Right$(PathName, Len(PathName) - 2)
      retf = send_reply("257 """ & PathName & """ is the current directory.", FTP_Index)
    Else
      retf = send_reply("530 User not logged in.", FTP_Index)
    End If
  
  Case "LIST", "NLST"   'LIST <pathname>Or InStr(FTP_Args(0), "-L")
      LIST_NLST FTP_Index, FTP_Command, FTP_Args(0)
    
  Case "STAT"  'STAT <pathname>
      retf = send_reply("200 Not Implemented..", FTP_Index)
  Case "HELP"  'HELP <string>
    DummyS = "214-This is the list of recognized FTP commands:"
    retf = send_reply(DummyS, FTP_Index)
      DummyS = "214-   USER  PASS  CWD   XCWD  CDUP  XCUP  QUIT  PORT" & vbCrLf _
             & "214-   PASV  TYPE  STRU  MODE  RETR  STOR  RNFR  RNTO" & vbCrLf _
             & "214-   DELE  RMD   XRMD  MKD   XMKD  PWD   XPWD" & vbCrLf _
             & "214    LIST  NLST  SYST  STAT  HELP  NOOP"
    retf = send_reply(DummyS, FTP_Index)
  
  Case "NOOP" 'NOOP
    retf = send_reply("200 NOOP command executed.", FTP_Index)
  Case ""
    Thread.SendMessage "error with ftpCommand"
  Case Else
    retf = send_reply("200 Not Implemented.." & FTP_Command, FTP_Index)
  End Select
Exit Function
FileError:
  Close #FTP_Index    'close file
  retf = send_reply("550 RETR command not executed. File Error", FTP_Index)
  retf = close_data_connect(FTP_Index)    'close data connection
End Function

Public Sub StartTimer()
  mlngTimerID = SetTimer(0, 0, 100, AddressOf TimerProc)
End Sub

Private Sub TimerProc(ByVal hWnd As Long, ByVal msg As Long, _
                      ByVal idEvent As Long, ByVal curTime As Long)
'Thread.SendMessage "Timer Fired"
  StopTimer
  FTP_Cmd2
End Sub

Public Sub StopTimer()
  If mlngTimerID > 0 Then
    KillTimer 0, mlngTimerID
    mlngTimerID = 0
  End If
End Sub

Public Sub KillThread()
  Set Thread = Nothing
End Sub