frmmain.frm

测试软件

Private Sub About_MENU_Click()
frmAbout.Show , Me
End Sub

Private Sub ccommands_MENU_Click()
frmSharedFolders.Show
End Sub

Private Sub CNewUser_MENU_Click()
frmCreateUser.Show
End Sub

Private Sub Config_MENU_Click()
frmOptions.Show vbModal, Me
End Sub

Private Sub CreateNewUser_MENU_Click()
frmCreateUser.Show vbModal, Me
End Sub

Private Sub Disable_MENU_Click()
If sEnabled = False Then MsgBox "Server already stopped.", 16, "Error": Exit Sub
Call EnableServer(False)
End Sub

Private Sub Enable_MENU_Click()
If sEnabled = True Then MsgBox "Server already started.", 16, "Error": Exit Sub
Call EnableServer(True)
End Sub

Private Sub FileTransferHistory_MENU_Click()
DisplayLogFile "FileTransfer"
End Sub

Private Sub Form_Load()

If GetSetting("Andromeda", "Settings", "FirstRun") = "" Then
    'This is the first time the program has been run
    'Save default settings to registry, and inform user
    'that they must specify directories and users before
    'using the server
    SaveSetting "Andromeda", "Settings", "SplashScreen", "1"
    SaveSetting "Andromeda", "Settings", "MinimizeToTray", "0"
    SaveSetting "Andromeda", "Settings", "WriteLog", "1"
    SaveSetting "Andromeda", "Settings", "WriteTransferLog", "1"
    SaveSetting "Andromeda", "Settings", "AllowDelete", "0"
    SaveSetting "Andromeda", "Settings", "AllowMove", "1"
    SaveSetting "Andromeda", "Settings", "AllowRename", "1"
    SaveSetting "Andromeda", "Settings", "StartWithWindows", "0"
    SaveSetting "Andromeda", "Settings", "FirstRun", "1"
    SaveSetting "Andromeda", "Settings", "AllowProcessToggle", "1"
    MsgBox "Welcome to Andromeda RFS v1.0!" & vbCrLf & vbCrLf & "Since this is the first time you have started the server, you must specify shared directories by clicking on the Tools menu, and choosing 'Manage Shared Directories'. This will display the shared folder window. Add the folders you wish to share with Andromeda clients. You will also need to create user accounts for anyone that wishes to connect to your computer. You can do this by clicking on the Users menu, and choosing 'Create New User'." & vbCrLf & vbCrLf & "Thanks for trying Andromeda RFS!" & vbCrLf & "Ryan and Andrew Lederman", 64, "IMPORTANT NOTE"
End If

    If FileLen(App.Path + "\sd.dll") = 0 Then
        RetVal = MsgBox("You do not have any shared directories! Andromeda clients will not be able to access your files. It is suggested that you add some shared directories now. Would you like to add some shared directories?", 36, "No Shared Directories")
        Select Case RetVal
            Case vbYes
                frmSharedFolders.Show , Me
        End Select
    End If
    
    'Initialize the command accepting winsock on port 6969
    Server(0).LocalPort = 6969
    Server(0).Listen
    
    UP(0).LocalPort = 6971
    UP(0).Listen
   
    intMax2 = 0
    Me.Caption = AppName() & "(Enabled)"
    lblServerRunning.Caption = Server(0).LocalIP
    sEnabled = True
    
    With nid
        .cbSize = Len(nid)
        .hwnd = Me.hwnd
        .uId = vbNull
        .szTip = "Andromeda RFS 1.0" & vbNullChar
        .uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
        .uCallBackMessage = WM_MOUSEMOVE
        .hIcon = Image1.Picture
    End With
    
    Shell_NotifyIcon NIM_ADD, nid
    
    KillApp "none", lstProcesses 'Initialize list of processes
End Sub



Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
 'On Error Resume Next
    'This procedure receives the callbacks from the System Tray icon.
    '
    Dim Result As Long
    Dim msg As Long
    'The value of X will vary depending upon the scalemode setting


    If Me.ScaleMode = vbPixels Then
        msg = X
    Else
        msg = X / Screen.TwipsPerPixelX
    End If

    Select Case msg
        Case 517  '517 display popup menu

            Me.PopupMenu MNU
      
        Case 514
        Result = SetForegroundWindow(Me.hwnd)
        Me.WindowState = vbNormal
        Me.Show
    End Select

End Sub

Private Sub Form_Resize()
    On Error Resume Next
    If Me.WindowState = 1 Then
    If GetSetting("Andromeda", "Settings", "MinimizeToTray", "0") = "1" Then
        Me.Hide
    End If
    End If
    
    lstOutput.Width = Me.Width - 320
    lstTransfer.Width = Me.Width - 320
    frameTop.Width = Me.Width + 300
      FrameStatus.Top = Me.Height - FrameStatus.Height - 760
    Frame1.Width = Me.Width - 320
    lstOutput.Height = Me.Height / 2 - 1350
    Frame1.Top = lstOutput.Top + lstOutput.Height + 120
    lblTransfer.Top = Frame1.Top + 80
  
    lstTransfer.Top = lblTransfer.Top + lblTransfer.Height + 20
    lstTransfer.Height = FrameStatus.Top - lstTransfer.Top - 20
    lstConnections.ColumnHeaders(4).Width = lstConnections.Width - lstConnections.ColumnHeaders(1).Width - lstConnections.ColumnHeaders(2).Width - lstConnections.ColumnHeaders(3).Width - 95
    lstOutput.ColumnHeaders(1).Width = lstOutput.Width - 2000
    lstOutput.ColumnHeaders(2).Width = lstOutput.Width - lstOutput.ColumnHeaders(1).Width - 90
    
End Sub


Private Sub lstConnections_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
    lstConnections.SortKey = ColumnHeader.Index - 1
    lstConnections.Sorted = True
End Sub


Private Sub Form_Terminate()
Shell_NotifyIcon NIM_DELETE, nid
End Sub

Private Sub Form_Unload(Cancel As Integer)
Cancel = True
Me.Hide
End Sub

Private Sub LoginHistory_MENU_Click()
Call DisplayLogFile("Login")
End Sub

Private Sub ManageDirs_MENU_Click()
frmSharedFolders.Show vbModal, Me
End Sub

Private Sub ManageUsers_MENU_Click()
frmManageUsers.Show , Me
End Sub

Private Sub MUsers_MENU_Click()
frmManageUsers.Show , Me
End Sub

Private Sub Server_Close(Index As Integer)
    If Index = 0 Then GoTo skip     '关闭0号端口，该端口用于侦听，不能关闭
    If ttlLogins = 0 Then GoTo skip '当前没有用户
    ttlLogins = ttlLogins - 1
    Server(Index).Close
skip:
    
End Sub

Private Sub Server_ConnectionRequest(Index As Integer, ByVal requestID As Long)
    'If Server(Index).State <> sckClosed Then Server(Index).Close
    'Server(Index).Accept (requestID)
    If Index = 0 Then
        '建立一个新Server Winsock
        dcount = Server.Count + 1
        Load Server(dcount)
        Server(dcount).Accept requestID
        '发送LOGIN消息到客户
        Server(dcount).SendData ("LOGIN")
    End If
End Sub

Private Sub Server_DataArrival(Index As Integer, ByVal bytesTotal As Long)
    
    Dim data As String, fileName As String, renameTo As String
    Call Server(Index).GetData(data, vbString, bytesTotal)
    
    '根据接受到的字符串的内容判断客户端的请求
    If Left(data, 6) = "LOGIN=" Then
        '客户端请求登陆
        colon = InStr(data, ":")
        If colon = 0 Then
            frmMain.Server(Index).SendData ("INVALID_LOGIN")
        Exit Sub
        End If
        temp = Right(data, Len(data) - ln - 6)
        colon = InStr(temp, ":")
        
        '初始化用户名及密码
        Login = Left(temp, colon - 1)
        Password = Right(temp, Len(temp) - colon)
    
    '察看相应的用户名文件是否存在
    If Exists(App.Path + "\" + Login + ".alf") = True Then
     
        '读取用户名及密码
        If Password = ReadEncryptedINI("Andromeda", "PW", App.Path + "\" + Login + ".alf") Then
            'Login 被接受，发送欢迎消息
            Call Server(Index).SendData("WELCOME")
            
            '将当前连接用户数目增加一个
            ttlLogins = ttlLogins + 1
            
            '讲登陆信息写入log文件
            Call WriteEncryptedINI("Andromeda", "LastLogin", Format(Now, "MM/DD/YY - HH:MM:SS AM/PM"), App.Path + "\" + Login + ".alf")
            
            If GetSetting("Andromeda", "Settings", "WriteLog") = "1" Then
                WriteLog App.Path + "\Log.txt", "User '" & Login & "' logged in from IP '" & Server(Index).RemoteHostIP & "' Time/Date: '" & Format(Now, "mm/dd/yy - HH:MM:SS AM/PM")
            End If
                
            sOutput "User '" & Login & "' logged in from IP '" & Server(Index).RemoteHostIP & "'"
       Else
            '密码错误
            Call Server(Index).SendData("INVALID_PASSWORD")
            sOutput "Invalid Password for '" & Login & "' : (" & Password & ") from IP '" & Server(Index).RemoteHostIP & "'"
            Login = "": Password = ""
            Exit Sub
        End If
    Else
        '用户名错误
        Call Server(Index).SendData("INVALID_LOGIN")
        Call Server(Index).SendData(InvalidMessage)
        sOutput "Invalid Login received: '" & Login & "' from IP '" & Server(Index).RemoteHostIP & "'"
        Login = "": Password = ""
        Exit Sub
    End If
        Login = "": Password = ""
    Exit Sub
    End If
    
    If data = "BEGIN" Then
        '客户端通知服务器要传输数据
        StartSending = True
    Exit Sub
    End If
    
    If data = "FILEUPPORT" Then
        'Client has asked for a port to upload a file
        'Find an open data port, inform the client that it should
        'send the data to that port, then create a new socket and
        'attach it to that port
        '客户端需要打开端口传输数据，建立一个新的socket对象并
        '连接到该端口
        Dim Piz As Long
            Piz = FindPort
            intMax2 = intMax2 + 1
            Load frmMain.UP(intMax2)
            frmMain.UP(intMax2).LocalPort = Piz
            frmMain.UP(intMax2).Listen
             Do While frmMain.UP(intMax2).State <> 2: DoEvents
            Loop
            frmMain.Server(Index).SendData ("FILEUPPORT=" & Piz)
    Exit Sub
    End If
    
    If data = "FILEPORT" Then
        'Request for open file transfer port
        Dim Piz2 As Long
        Piz2 = FindPort
        frmMain.UDP(Index).LocalPort = Piz2
        frmMain.UDP(Index).Listen
        Do While frmMain.UDP(Index).State <> 2: DoEvents
        Loop
        frmMain.Server(Index).SendData ("FILEPORT=" & Piz2)
    End If
    
     If Left(data, 17) = "GET_DIR_CONTENTS=" Then
        'Request for folder contents to download
        'all files and subdirectories inside a folder
        Dim Col1 As New Collection
        Equals2 = InStr(data, "=")
        whichFolder2$ = Right(data, Len(data) - Equals2)
        Call SendDirectoryContents(whichFolder2$, Col1)
        If Col1.Count = 0 Then
            'Some error must have occurred
            Server(Index).SendData ("ERROR:An error occurred while trying to get the contents of that directory.")
            Exit Sub
        End If
        
        For X2 = 1 To Col1.Count
            temp = temp + Col1(X2) + "|"
        Next X2
       
        Server(Index).SendData ("DIR_CONTENTS->" & temp)
    
        sOutput "Contents of '" & whichFolder2$ & "' sent to IP '" & Server(Index).RemoteHostIP & "'"
        
        Exit Sub
      End If
      
    If Left(data, 12) = "GETPROCESSES" Then
        'Request from client for list of processes
        Call SendProcessesToClient(Server(Index))
        Exit Sub
    End If
    
    If Left(data, 14) = "BEGIN_DOWNLOAD" Then
        'Create new file sending winsock
        newudp = UDP.Count
        Load UDP(newudp)
        UDP(newudp).Close
        Call UDP(newudp).Connect(Server(Index).RemoteHostIP, 109)
        Exit Sub
    End If
    
   
    
        
        
      If Left(data, 7) = "DELETE=" Then
        'Request from client to delete a file
        'check if deletion is allowed in options
        If GetSetting("Andromeda", "Settings", "AllowDelete") = "0" Then
            Server(Index).SendData ("ERROR:Andromeda RFS v1.0" & vbCrLf & "Error: Deletion not allowed!")
            Exit Sub
        End If
            
        'Call DeleteFiles() to delete the potentially large list of files
        Dim dFiles As String, dSuccess As Boolean
        dFiles = Right(data, Len(data) - InStr(data, "DELETE=") - 6)
        
        dSuccess = DeleteFiles(dFiles, Server(Index).RemoteHostIP)
      
        If dSuccess Then
            'Inform client that the file(s) were deleted
            Server(Index).SendData ("DELETED")
        End If
        Exit Sub
      End If
      
      If Left(data, 10) = "NEWFOLDER=" Then
        'Request for creation of new directory
        'Call CreateFolder()
        Dim xFolder As String, EqualIndex As Integer
        EqualIndex = InStr(data, "=")
        xFolder = Right(data, Len(data) - EqualIndex)
        Call CreateFolder(xFolder, Server(Index))
        Exit Sub
      End If
      
      If Left(data, 5) = "MOVE=" Then
        'Request to move a directory or file(s)
      If GetSetting("Andromeda", "Settings", "AllowMove") = "0" Then
            Server(Index).SendData ("ERROR:Andromeda RFS v1.0" & vbCrLf & "Error: Moving not allowed!")
            Exit Sub
      End If
        
        Dim Equals As Integer, Pipe As Integer, ExistingFile As String, NewLocation As String
        Equals = InStr(data, "=")
        data = Right(data, Len(data) - Equals)
        Pipe = InStr(data, "|")