Option Explicit

Private Const mc_MaxCurrentProcesses As Integer = 150
Private Const mc_Port As Long = 80

Private Sub Form_Load()
  Dim i As Integer

  cmdStopServer.Enabled = False

  For i = 1 To mc_MaxCurrentProcesses
    Load wscSender(i)
  Next
End Sub

Private Sub Form_Unload(Cancel As Integer)
  wscVerteiler.Close
  End
End Sub

Private Sub cmdStartServer_Click()
  On Error GoTo ERR_Catcher

  wscVerteiler.LocalPort = mc_Port
  wscVerteiler.Listen

  lstHistory.Clear
  lstHistory.AddItem "WebServer gestartet (Lokal: http://" & _
       wscVerteiler.LocalIP & ":" & wscVerteiler.LocalPort & _
       "  bzw.  http://" & wscVerteiler.LocalHostName & ":" & _
       wscVerteiler.LocalPort & ")"

  lstHistory.AddItem "Für die Erreichbarkeit im Internet " & _
       "lesen Sie bitte die Readme.txt"

  lstHistory.ListIndex = lstHistory.ListCount - 1

  cmdStartServer.Enabled = False
  cmdStopServer.Enabled = True

  Exit Sub

ERR_Catcher:
  MsgBox "Es ist ein Fehler aufgetreten." & vbCrLf & _
        "Wahrscheinlich läuft auf ihrem PC simultan ein " & _
        "weiterer WebServer der auf Port " & mc_Port & _
        " hört.", vbCritical + vbOKOnly, "Fehler"

  wscVerteiler.Close
  End
End Sub

Private Sub cmdStopServer_Click()
  wscVerteiler.Close

  lstHistory.AddItem "WebServer gestoppt"
  lstHistory.ListIndex = lstHistory.ListCount - 1

  cmdStartServer.Enabled = True
  cmdStopServer.Enabled = False
End Sub

Private Sub wscSender_DataArrival(Index As Integer, _
      ByVal bytesTotal As Long)

  Dim strRequest        As String
  Dim intPosBegin       As Integer
  Dim intPosEnd         As Integer
  Dim strFilePath       As String
  Dim strRequestedPage  As String

  On Error GoTo ERR_Catcher

  wscSender(Index).GetData strRequest

  If Mid(strRequest, 1, 3) = "GET" Then
    intPosBegin = InStr(strRequest, "GET") + Len("GET") + 1
    intPosEnd = InStr(intPosBegin, strRequest, " ")
    strRequestedPage = _
        Mid(strRequest, intPosBegin, intPosEnd - intPosBegin)

    If Left$(strRequestedPage, 1) = "/" Then
        strRequestedPage = _
            Right$(strRequestedPage, Len(strRequestedPage) - 1)
    End If

    If strRequestedPage = "" Or strRequestedPage = "/" Then
      strFilePath = FileWithAppPath("index.htm")
    Else
      strFilePath = FileWithAppPath(strRequestedPage)
    End If

    If optAllButLocal.Value = True And _
          wscSender(Index).RemoteHostIP = _
          wscSender(Index).LocalIP Then
      strFilePath = FileWithAppPath("forbidden.htm")
    End If

    If optLocal.Value = True And _
          wscSender(Index).RemoteHostIP <> _
          wscSender(Index).LocalIP Then
      strFilePath = FileWithAppPath("forbidden.htm")
    End If

    If Dir(strFilePath) = "" Then
      strFilePath = FileWithAppPath("404.htm")
    End If

    lstHistory.AddItem Space(3) & Now() & "  Uhr:  " & _
          "Sendeanfrage (" & wscSender(Index).RemoteHostIP & _
          "): " & strFilePath & "  (" & _
          Format(FileLen(strFilePath), "#,##0") & " Bytes)"
    lstHistory.ListIndex = lstHistory.ListCount - 1

    wscSender(Index).SendData LoadBinary(strFilePath)
  End If

  Exit Sub

ERR_Catcher:
  MsgBox "Beim Senden der Daten ist ein Fehler aufgetreten. " & _
       "Der Vorgang wurde abgebrochen!", vbCritical + vbOKOnly, _
      "Fehler"
  wscSender(Index).Close
End Sub

Private Sub wscSender_SendComplete(Index As Integer)
    wscSender(Index).Close
End Sub

Private Sub wscVerteiler_ConnectionRequest( _
      ByVal requestID As Long)
  Dim i As Integer

  For i = 0 To mc_MaxCurrentProcesses
    If wscSender(i).State = sckClosed Then
      wscSender(i).Close
      wscSender(i).Accept requestID
      Exit For
    End If
  Next
End Sub

Private Function LoadBinary(ByVal strFileName As String) As String
  Dim ff As Integer

  ff = FreeFile
  Open strFileName For Binary As #ff
    LoadBinary = Input(FileLen(strFileName), #ff)
  Close #ff
End Function

Private Sub optAllButLocal_Click()
  AccessTypeChanged 0
End Sub

Private Sub optLocal_Click()
  AccessTypeChanged 1
End Sub

Private Sub optAll_Click()
  AccessTypeChanged 2
End Sub

Private Sub AccessTypeChanged(ByVal i As Integer)
  Dim strMessage As String

  Select Case i
    Case 0
      strMessage = Space(3) & Now() & _
            " Uhr:  Zugriff für alle außer Localhost"
    Case 1
      strMessage = Space(3) & Now() & _
            " Uhr:  Zugriff nur für Localhost"
    Case 2
      strMessage = Space(3) & Now() & _
            " Uhr:  Zugriff für alle"
    Case Else
  End Select

  lstHistory.AddItem strMessage
  lstHistory.ListIndex = lstHistory.ListCount - 1
End Sub

Private Function FileWithAppPath(ByVal vsFileName As String) _
      As String
  Dim strFilePath As String

  strFilePath = App.Path
  If Right$(strFilePath, 1) <> "\" Then
    strFilePath = strFilePath & "\"
  End If
  strFilePath = strFilePath & vsFileName

    FileWithAppPath = strFilePath

End Function