'Visual Basic 6 example of secure file sharing server
'To keep this VB6 example simple, we are going to implement
'only the main file operations and one predefined user account


Const MyUsername = "test"
Const MyPassword = "test"



' *** General ***


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

Private Sub ShowMessage(ByVal aText As String, ByVal aCaption As String)
  Call MessageBox(0&, aText, aCaption, &H1000&)
End Sub





'Insert a leading slash
Private Function PreSlash(aPath As String) As String
  If Left$(aPath, 1) = "\" Then
    PreSlash = aPath
  Else
    PreSlash = "\" + aPath
  End If
End Function




Private Function GetUsername(ByVal aHandle As Long) As String
  GetUsername = FileSrv.GetUsername(aHandle)
  If GetUsername = "" Then
    GetUsername = "Default"
  End If
  GetUsername = "User " + GetUsername
End Function






' *** Working ***




'Initializations
Private Sub Form_Load()
  SetProperties
  UpdateStatus
  'Call btnStart_Click
End Sub




'A list view item is clicked
Private Sub lvPeers_ItemClick(ByVal Item As MSComctlLib.ListItem)
  UpdateStatus
End Sub




'Terminate the application
Private Sub btnExit_Click()
  End
End Sub



'Update the status text
Private Sub UpdateStatus()
  
  If FileSrv.Running Then
    StatusBar.Panels.Item(1).Text = "Started"
    btnStart.Enabled = False
    btnStop.Enabled = True
  Else
    StatusBar.Panels.Item(1).Text = "Stopped"
    btnStart.Enabled = True
    btnStop.Enabled = False
  End If

  If lvClients.ListItems.Count = 0 Then
    StatusBar.Panels.Item(2).Text = "No active connection"
  Else
    StatusBar.Panels.Item(2).Text = Str(lvClients.ListItems.Count) + " connection(s)"
  End If
  
  btnRemove.Enabled = Not (lvClients.SelectedItem Is Nothing)
End Sub



'Set the component properties
Private Sub SetProperties()
  FileSrv.ListeningPort = fSettings.txtPort
  FileSrv.CryptoKey = fSettings.txtKey.Text
  FileSrv.UseCompression = fSettings.chkCompress.Value
End Sub



'Add an error message to the log
Private Sub LogMsg(ByVal aMsg As String)
  Dim Line As String
  If txtLog.Text > "" Then
    Line = Chr(13) + Chr(10)
  End If
  Line = Line + "[" + Format(Now, "hh:mm:ss") + "]: "
  Line = Line + aMsg
  txtLog.SelStart = Len(txtLog.Text)
  txtLog.SelText = Line
End Sub


Private Function ItemFromHandle(ByVal aHandle As Long) As ListItem
  'iterate on the list
  For i = 1 To lvClients.ListItems.Count
    If lvClients.ListItems.Item(i).Tag = aHandle Then
      Set ItemFromHandle = lvClients.ListItems.Item(i)
      Exit Function
    End If
  Next i
  Set ItemFromHandle = Nothing
End Function


'Clear the log
Private Sub btnClear_Click()
  txtLog.Text = ""
End Sub



'Show my IP address
Private Sub btnIP_Click()
  Call ShowMessage(FileSrv.LocalIP, "My IP address")
End Sub


'Remove a client connection
Private Sub btnRemove_Click()
  If lvClients.SelectedItem Is Nothing Then Exit Sub
  FileSrv.RemoveClient (lvClients.SelectedItem.Tag)
  lvClients.ListItems.Remove (lvClients.SelectedItem.Index)
  UpdateStatus
End Sub



'Modify the settings
Private Sub btnSettings_Click()
  fSettings.Show 1, Me
  If fSettings.Canceled Then Exit Sub
  SetProperties
  UpdateStatus
End Sub



'Start the server
Private Sub btnStart_Click()
  If FileSrv.Start Then
    LogMsg ("Server started")
  Else
    Call ShowMessage("Cannot start the server!", "Error")
  End If
  UpdateStatus
End Sub



'Stop the server
Private Sub btnStop_Click()
  Dim LI As ListItem
  Dim i As Long
  
  FileSrv.Stop
  
  For i = lvClients.ListItems.Count To 1 Step -1
    FileSrv.RemoveClient (lvClients.ListItems.Item(i).Tag)
    lvClients.ListItems.Remove (i)
  Next i
  
  UpdateStatus
  LogMsg ("Server stopped")
End Sub







' *** FileSrv events ***



'A new connection is available
Private Sub FileSrv_OnNewClient(ByVal aHandle As Long)
  Dim LI As ListItem
  
  Set LI = lvClients.ListItems.Add(, , "Not signed in")
  LI.Tag = aHandle
  LI.SubItems(1) = FileSrv.GetClientAddress(aHandle)
  LI.SubItems(2) = FileSrv.GetClientPort(aHandle)
  LI.SubItems(3) = Format(Now, "hh:mm:ss")
  LI.SubItems(4) = "Connected"
  
  UpdateStatus
  LogMsg ("New connection from " + LI.SubItems(1) + ":" + LI.SubItems(2))
End Sub



'A connection is broken
Private Sub FileSrv_OnClientDisconnected(ByVal aHandle As Long)
  Dim LI As ListItem
  Set LI = ItemFromHandle(aHandle)
  If LI Is Nothing Then Exit Sub
  LogMsg ("Disconnected " + LI.Text + " " + FileSrv.GetClientAddress(aHandle) + ":" + FileSrv.GetClientPort(aHandle))
  lvClients.ListItems.Remove (LI.Index)
End Sub



'The key matching is changed
Private Sub FileSrv_OnKeyChanged(ByVal aHandle As Long)
  Dim S As String
  Dim LI As ListItem
  
  Set LI = ItemFromHandle(aHandle)
  If LI Is Nothing Then Exit Sub
  LogMsg ("Key changed for " + GetUsername(aHandle) + " " + FileSrv.GetClientAddress(aHandle) + ":" + FileSrv.GetClientPort(aHandle))
  If FileSrv.WrongKey(aHandle) Then
    LI.SubItems(3) = "Wrong key"
  Else
    LI.SubItems(3) = "Connected"
  End If
End Sub




'A request for a password
Private Sub FileSrv_OnNeedPassword(ByVal aHandle As Long, ByVal aUsername As String, aOkay As Boolean, aPassword As String)
  If aUsername = MyUsername Then
    'this is our user
    aOkay = True
    aPassword = MyPassword
  Else
    'Unknown user
    aOkay = False
  End If
End Sub


'An user is signed-in
Private Sub FileSrv_OnSignin(ByVal aHandle As Long, ByVal aCode As Long)
  Dim S As String
  Dim LI As ListItem
  
  S = GetUsername(aHandle)
  Set LI = ItemFromHandle(aHandle)
  If Not (LI Is Nothing) Then
    LI.Text = S
  End If
  
  S = S + " " + FileSrv.GetClientAddress(aHandle) + ":" + FileSrv.GetClientPort(aHandle)
  If aCode = 0 Then
    S = S + " signed in successfully"
  Else
    S = S + " failed sign-in"
  End If
  
  LogMsg (S)
End Sub




'A request to list the folder contents
Private Sub FileSrv_OnNeedListFolder(ByVal aHandle As Long, ByVal aPath As String, aOkay As Boolean, aRoot As String)
  aOkay = True
  aRoot = App.Path
  LogMsg (GetUsername(aHandle) + ": list folder " + PreSlash(aPath))
End Sub



'A request to create a folder
Private Sub FileSrv_OnNeedCreateFolder(ByVal aHandle As Long, ByVal aPath As String, aOkay As Boolean, aRoot As String)
  aOkay = True
  aRoot = App.Path
  LogMsg (GetUsername(aHandle) + ": create folder " + aPath)
End Sub


'A request to rename a folder
Private Sub FileSrv_OnNeedRenameFolder(ByVal aHandle As Long, ByVal aPath As String, aOkay As Boolean, aRoot As String)
  aOkay = True
  aRoot = App.Path
  LogMsg (GetUsername(aHandle) + ": rename folder " + aPath)
End Sub


'A request to rename a file
Private Sub FileSrv_OnNeedRenameFile(ByVal aHandle As Long, ByVal aPath As String, aOkay As Boolean, aRoot As String)
  aOkay = True
  aRoot = App.Path
  LogMsg (GetUsername(aHandle) + ": rename file " + aPath)
End Sub



'A request to delete a folder
Private Sub FileSrv_OnNeedDeleteFolder(ByVal aHandle As Long, ByVal aPath As String, aOkay As Boolean, aRoot As String)
  aOkay = True
  aRoot = App.Path
  LogMsg (GetUsername(aHandle) + ": delete folder " + aPath)
End Sub


'A request to delete a file
Private Sub FileSrv_OnNeedDeleteFile(ByVal aHandle As Long, ByVal aPath As String, aOkay As Boolean, aRoot As String)
  aOkay = True
  aRoot = App.Path
  LogMsg (GetUsername(aHandle) + ": delete file " + aPath)
End Sub


'A request to download
Private Sub FileSrv_OnNeedDownload(ByVal aHandle As Long, ByVal aPath As String, aOkay As Boolean, aRoot As String)
  aOkay = True
  aRoot = App.Path
  LogMsg (GetUsername(aHandle) + ": starting download " + aPath)
End Sub


'The download operation is completed
Private Sub FileSrv_OnDownloadDone(ByVal aHandle As Long, ByVal aCode As Long)
  LogMsg (GetUsername(aHandle) + ": finishing download ")
End Sub



'A request to upload
Private Sub FileSrv_OnNeedUpload(ByVal aHandle As Long, ByVal aPath As String, aOkay As Boolean, aRoot As String)
  aOkay = True
  aRoot = App.Path
  LogMsg (GetUsername(aHandle) + ": start uploading " + aPath)
End Sub



'The upload operation is completed
Private Sub FileSrv_OnUploadDone(ByVal aHandle As Long, ByVal aCode As Long)
  LogMsg (GetUsername(aHandle) + ": finish uploading " + aPath)
End Sub