windproc.bas

运行多用户

Attribute VB_Name = "WindProc"
Option Explicit

Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
  (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" _
  (ByVal wndrpcPrev As Long, ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const GWL_WNDPROC = (-4)

Public intSocket As Integer
Public OldWndProc As Long
Public IPDot As String

' Root value for hidden window caption
Public Const PROC_CAPTION = "ApartmentDemoProcessWindow"

Public Const ERR_InternalStartup = &H600
Public Const ERR_NoAutomation = &H601

Public Const ENUM_STOP = 0
Public Const ENUM_CONTINUE = 1

Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
   (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Declare Function GetWindowThreadProcessId Lib "user32" _
   (ByVal hWnd As Long, lpdwProcessId As Long) As Long

Declare Function EnumThreadWindows Lib "user32" _
   (ByVal dwThreadId As Long, ByVal lpfn As Long, ByVal lParam As Long) _
   As Long

Private mhwndVB As Long
' Window handle retrieved by EnumThreadWindows.
Private mfrmProcess As New frmProcess
' Hidden form used to id main thread.
Private mlngProcessID As Long
' Process ID.

Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long

Private MainApp As MainApp
Private Thread As Balk

Private mlngTimerID As Long

Sub Main()
  Dim ma As MainApp

  ' Borrow a window handle to use to obtain the process
  '   ID (see EnumThreadWndMain call-back, below).
  Call EnumThreadWindows(App.ThreadID, AddressOf EnumThreadWndMain, 0&)
  If mhwndVB = 0 Then
    Err.Raise ERR_InternalStartup + vbObjectError, , _
             "Internal error starting thread"
  Else
    GetWindowThreadProcessId mhwndVB, mlngProcessID
    ' The process ID makes the hidden window caption unique.
    If 0 = FindWindow(vbNullString, PROC_CAPTION & CStr(mlngProcessID)) Then
      ' The window wasn't found, so this is the first thread.
      If App.StartMode = vbSModeStandalone Then
        ' Create hidden form with unique caption.
        mfrmProcess.Caption = PROC_CAPTION & CStr(mlngProcessID)
        ' The Initialize event of MainApp (Instancing =
        '   PublicNotCreatable) shows the main user interface.
        Set ma = New MainApp
        ' (Application shutdown is simpler if there is no
        '   global reference to MainApp; instead, MainApp
        '   should pass Me to the main user form, so that
        '   the form keeps MainApp from terminating.)
      Else
        Err.Raise ERR_NoAutomation + vbObjectError, , _
             "Application can't be started with Automation"
      End If
    End If
  End If
End Sub

Public Sub SetThread(lThread As Balk)
  Set Thread = lThread
End Sub

' Call-back function used by EnumThreadWindows.
Public Function EnumThreadWndMain(ByVal hWnd As Long, ByVal _
                                  lParam As Long) As Long
  ' Save the window handle.
  mhwndVB = hWnd
  ' The first window is the only one required.
  ' Stop the iteration as soon as a window has been found.
  EnumThreadWndMain = ENUM_STOP
End Function

' MainApp calls this Sub in its Terminate event;
'   otherwise the hidden form will keep the
'   application from closing.
Public Sub FreeProcessWindow()
  SetWindowLong mhwndVB, GWL_WNDPROC, OldWndProc
  vbWSACleanup
  Unload mfrmProcess
  Set mfrmProcess = Nothing
End Sub

Public Sub FTP_Init(lMainApp As MainApp)
  Dim i As Integer
  Dim hdr As String, item As String
  
  '--- Initialization
  'an FTP command is terminated by Carriage_Return & Line_Feed
  'possible sintax errors in FTP commands
  sintax_error_list(0) = "200 Command Ok."
  sintax_error_list(1) = "202 Command not implemented, superfluous at this site."
  sintax_error_list(2) = "500 Sintax error, command unrecognized."
  sintax_error_list(3) = "501 Sintax error in parameters or arguments."
  sintax_error_list(4) = "502 Command not implemented."
  sintax_error_list(6) = "504 Command not implemented for that parameter."
  'initializes the list which contains the names,
  'passwords, access rights and default directory
  'recognized by the server
  If LoadProfile(App.Path & "\Burro.ini") Then
    '
  Else
    'frmFTP.StatusBar.Panels(1) = "Error Loading Ini File!"
  End If
  
  'initializes the records which contain the
  'informations on the connected users
  For i = 1 To MAX_N_USERS
    users(i).list_index = 0
 '   users(i).control_slot = INVALID_SLOT
 '   users(i).data_slot = INVALID_SLOT
    users(i).IP_Address = ""
    users(i).Port = 0
    users(i).data_representation = "A"
    users(i).data_format_ctrls = "N"
    users(i).data_structure = "F"
    users(i).data_tx_mode = "S"
    users(i).cur_dir = ""
    users(i).State = Log_In_Out '0
    users(i).full = False
  Next
 
  OldWndProc = SetWindowLong(mhwndVB, GWL_WNDPROC, AddressOf WindowProc)
  
  Set MainApp = lMainApp
 
  vbWSAStartup
  
  'begins SERVER mode on port 21
  ServerSlot = ListenForConnect(21, mhwndVB)
  
  If ServerSlot > 0 Then
   ' frmFTP.StatusBar.Panels(1) = Description
  Else
  '  frmFTP.StatusBar.Panels(1) = "Error Creating Listening Socket"
  End If
End Sub

Private Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, _
                            ByVal wParam As Long, ByVal lParam As Long) As Long

  Dim retf As Long
  Dim SendBuffer As String, msg$
  Dim lenBuffer As Integer 'send-buffer lenght
  Dim RecvBuffer As String
  Dim BytesRead As Integer 'receive-buffer lenght
  Dim i As Integer, GoAhead As Boolean
  Dim fixstr As String * 1024
  Dim lct As String
  Dim lcv As Integer
  Dim WSAEvent As Long
  Dim WSAError As Long
  Dim Valid_Slot As Boolean
  
  Valid_Slot = False
  GoAhead = True
  
  Select Case uMsg
  Case 5150
    
    'ServerLog "NOTIFICATION - " & wParam & " - " & lParam & "> " & Format$(Date$, "dd/mm/yy ") & Format$(Time$, "hh:mm - ")
    MainApp.SvrLogToScreen "NOTIFICATION - " & wParam & " - " & lParam & "> " & Format$(Date$, "dd/mm/yy ") & Format$(Time$, "hh:mm - ")
    For i = 1 To MAX_N_USERS       'registers the slot number in the first free user record
      If wParam = users(i).control_slot And users(i).full Then
        Valid_Slot = True
        Exit For
      End If
    Next
    If (wParam = ServerSlot) Or (wParam = NewSlot) Or Valid_Slot Then 'event on server slot
   '   frmFTP.StatusBar.Panels(1) = CStr(wParam)
      WSAEvent = WSAGetSelectEvent(lParam)
      WSAError = WSAGetAsyncError(lParam)
      'Debug.Print "Retf = "; WSAEvent; WSAError
      Select Case WSAEvent
        'FD_READ    = &H1    = 1
        'FD_WRITE   = &H2    = 2
        'FD_OOB     = &H4    = 4
        'FD_ACCEPT  = &H8    = 8
        'FD_CONNECT = &H10   = 16
        'FD_CLOSE   = &H20   = 32
      Case FD_CONNECT
        Debug.Print "FD_Connect " & wParam; lParam
   '     retf = getpeername(NewSlot, SockAddr, SockAddr_Size)
   '     Debug.Print "Peername = " & retf
   '     Debug.Print "IPAddr1 =" & SockAddr.sin_addr
   '     Debug.Print "IPPort1 =" & SockAddr.sin_port
      Case FD_ACCEPT
        Debug.Print "Doing FD_Accept"

        SockAddr.sin_family = AF_INET
        SockAddr.sin_port = 0
        'SockAddr.sin_addr = 0
        NewSlot = accept(ServerSlot, SockAddr, SockAddr_Size) 'try to accept new TCP connection
        If NewSlot = INVALID_SOCKET Then
          msg$ = "Can't accept new socket."
      '    frmFTP.StatusBar.Panels(1) = msg$ & CStr(NewSlot)
 
        Else
          Debug.Print "NewSlot OK "; NewSlot; num_users; MAX_N_USERS
   '       retf = getpeername(NewSlot, SockAddr, SockAddr_Size)
          IPDot = GetAscIP(SockAddr.sin_addr)
'Had to comment out the GetHostByAddress thing cause we don't do dns
      '    frmFTP.StatusBar.Panels(1) = IPDot & "<>" '& vbGetHostByAddress(IPDot)
          'Debug.Print "Peername = " & retf
          'Debug.Print "IPAddr2 =" & SockAddr.sin_addr & " IPdot=" & IPDot
          'Debug.Print "IPPort2 =" & SockAddr.sin_port & " Port:" & ntohs(SockAddr.sin_port)
          If num_users >= MAX_N_USERS Then        'new service request
            'the number of users exceeds the maximum allowed
            SendBuffer = "421 Service not available at this time, closing control connection." & vbCrLf
            lenBuffer = Len(SendBuffer)
            retf = send(NewSlot, SendBuffer, lenBuffer, 0)
            retf = closesocket(NewSlot)           'close connection
          Else
            SendBuffer = "220-Welcome to my demo Server v0.0.1!" & vbCrLf _
                       & "220 This program is written in VB 5.0" & vbCrLf
            lenBuffer = Len(SendBuffer)
            retf = send(NewSlot, SendBuffer, lenBuffer, 0)          'send welcome message
            Debug.Print "Send = " & retf
            num_users = num_users + 1      'increases the number of connected users
            For i = 1 To MAX_N_USERS       'registers the slot number in the first free user record
              If Not users(i).full Then
                users(i).control_slot = NewSlot
                users(i).full = True
                Exit For
              End If
            Next
          End If  'If num_users
        End If  'If NewSlot
      Case FD_READ
        Debug.Print "Doing FD_Read"
        BytesRead = recv(wParam, fixstr, 1024, 0) 'store read bytes in RecvBuffer
        RecvBuffer = Left$(fixstr, BytesRead)

        If InStr(RecvBuffer, vbCrLf) > 0 Then     'if received string is a command then executes it
          For i = 1 To MAX_N_USERS                'event on control slots
            If (wParam = users(i).control_slot) Then
              retf = FTP_Cmd(i, RecvBuffer)          'tr
              Exit For
            End If
          Next
        End If
      Case FD_CLOSE
        Debug.Print "Doing FD_Close"
        For i = 1 To MAX_N_USERS  'event on control slots
          If (wParam = users(i).control_slot) Then
            retf = closesocket(wParam)        'connection closed by client
            users(i).control_slot = INVALID_SOCKET        'frees the user record
            
            Set users(i).Jenny = Nothing
            users(i).full = False
            'ServerLog "<" & Format$(i, "000") & "> " & Format$(Date$, "dd/mm/yy ") & Format$(Time$, "hh:mm") & " - Logged Off"
            MainApp.SvrLogToScreen "<" & Format$(i, "000") & "> " & Format$(Date$, "dd/mm/yy ") & Format$(Time$, "hh:mm") & " - Logged Off"
            num_users = num_users - 1
            Exit For
          ElseIf (wParam = users(i).data_slot) Then
            retf = closesocket(wParam)        'connection closed by client
            users(i).data_slot = INVALID_SOCKET   'reinitilizes data slot
            users(i).State = Service_Commands '  2
            Exit For
          End If
       Next
      Case FD_WRITE
        Debug.Print "Doing FD_Write"
        'enables sending
      End Select
    End If
    'Debug.Print GetWSAErrorString(WSAGetLastError)
    MainApp.UsrCnt num_users
  End Select
  retf = CallWindowProc(OldWndProc, hWnd, uMsg, wParam, ByVal lParam)
  WindowProc = retf
End Function

Public Function FTP_Cmd(ID_User As Integer, cmd As String) As Integer
  
  Dim Kwrd As String 'keyword
  Dim argument(5) As String 'arguments
  Dim ArgN As Long
  Dim FTP_Err As Integer 'error
  Dim PathName As String, Drv As String
  
  Dim Full_Name As String 'pathname & file name
  Dim File_Len As Long 'file lenght in bytes
  Dim i As Long
  
  Dim Ok As Integer
  Dim Buffer As String
  Dim DummyS As String
  
  'variables used during the data exchange
  Dim ExecSlot As Integer
  Dim NewSockAddr As SockAddr
  
  On Error Resume Next 'routine for error interception
  
  FTP_Err = sintax_ctrl(cmd, Kwrd, argument())
  'log commands
  'ServerLog "<" & Format$(ID_User, "000") & "> " & Format$(Date$, "dd/mm/yy ") & Format$(Time$, "hh:mm - ") & cmd
  MainApp.SvrLogToScreen "<" & Format$(ID_User, "000") & "> " & Format$(Date$, "dd/mm/yy ") & Format$(Time$, "hh:mm - ") & cmd
  If FTP_Err <> 0 Then
    retf = send_reply(sintax_error_list(FTP_Err), ID_User)
    Exit Function
  End If