Tipp 0398 Webserver erstellen
Autor/Einsender:
Datum:
  Markus Schutz
19.05.2004
Entwicklungsumgebung:   VB 6
Dieser Tipp demonstriert, wie sich in wenigen Schritten ein eigener Webserver erstellen lässt.
Der Webserver wartet auf dem definierten Port bis eine Instanz eine Anfrage an ihn sendet. Wird die Anfrage nicht schon dort beispielsweise durch einen IP-Blocker abgewehrt, so wird die Anfrage an einen freien Sender weitergeleitet. Die Anzahl der Sender ist in diesem Beispiel definiert als mc_MaxCurrentProcesses. Sollte diese Konstante z.B. den Wert 2 besitzen, so können gleichzeitig maximal 3 Anfragen bearbeitet werden.
Wird eine Anfrage von einem freien Sender aufgenommen, so wird zunächst überprüft, ob die andere Instanz überhaupt eine GET-Anfrage gesendet hat. Ist dies nicht der Fall, so ist die Arbeit des Senders bereits hier beendet. Sollte es sich jedoch um eine GET-Anfrage handeln, so wird aus ihr die gewünschte Seite durch String-Operationen herausgeschnitten. Existiert die gewünschte Datei, so wird sie binär an die Instanz geschickt. Die gewünschte Datei ist nun im Browser zu sehen.
Es ist ebenfalls möglich die Anfrage umzuleiten, d.h., wenn die IP der Instanz geblockt wird, wird in diesem Beispiel die Datei forbidden.htm binär an die Instanz geschickt.
Konfiguration:
- Maximale Zahl gleichzeitiger Operationen definieren
- Port für Anfragen definieren
Hinweis
Dieser Tipp benötigt die Datei MSWINSCK.OCX als Komponente. Zusätzlich werden die Dateien index.htm, (linkpage.htm,) forbidden.htm und 404.htm im Anwendungspfad benötigt.
 
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
 

Windows-Version
95
98/SE
ME
NT
2000
XP
Vista
Win 7
VB-Version
VBA 5
VBA 6
VB 4/16
VB 4/32
VB 5
VB 6


Download  (24,1 kB) Downloads bisher: [ 2631 ]

Vorheriger Tipp Zum Seitenanfang Nächster Tipp

Startseite | Projekte | Tutorials | API-Referenz | VB-/VBA-Tipps | Komponenten | Bücherecke | VB/VBA-Forum | VB.Net-Forum | DirectX-Forum | Foren-Archiv | DirectX | VB.Net-Tipps | Chat | Spielplatz | Links | Suchen | Stichwortverzeichnis | Feedback | Impressum

Seite empfehlen Bug-Report
Letzte Aktualisierung: Montag, 5. September 2011