Dim Sockinuse(0 To 32767) As Boolean
Dim SendComplete(0 To 32767) As Boolean
Dim i As Long
Dim Sock As Long
Dim Method As String
Dim URL As String
Dim File_Exists As String
 
Private Sub Form_Load()
 
    Call Open_Port
 
End Sub
 
Private Function Open_Port()
 
  Winsock1.Close
  Winsock1.LocalPort = 80
  Winsock1.Listen
 
  rtfProtokoll.Text = "**** Server läuft..." & vbCrLf
  setColor (42)
 
End Function
 
Private Sub setColor(KeyAscii As Integer)
  Dim nPos As Long
  Dim sPos As Long
 
  With rtfProtokoll
    sPos = .SelStart
    .Visible = False
 
    nPos = -1
    Do
      nPos = .Find(Chr$(KeyAscii), nPos + 1)
      If nPos >= 0 Then
        .SelLength = 1
        .SelColor = vbRed
      End If
    Loop Until nPos < 0
    .Visible = True
 
    .SelStart = sPos
  End With
End Sub
 
Public Function FileExists(ByVal sFile As String) As Boolean
 
  Dim Size As Long
  On Local Error Resume Next
  Size = FileLen(sFile)
  File_Exists = (Err = 0)
  On Local Error GoTo 0
 
End Function
 
Private Sub tmrOnline_Timer(Index As Integer)
 
  If Winsock2(Sock).State = 0 Or Winsock2(Sock).State = 8 Or Winsock2( _
    Sock).State = 9 Then
 
    Unload Winsock2(Sock)
    Unload tmrOnline(Sock)
 
    SendComplete(Sock) = True
    Sockinuse(Port) = False
 
  End If
 
  If SendComplete(Sock) = True Then
    Unload Winsock2(Sock)
    Unload tmrOnline(Sock)
  End If
 
End Sub
 
Private Sub Winsock1_ConnectionRequest(ByVal requestID As Long)
 
  For i = 1 To 32767
 
    If Sockinuse(i) = False Then
 
      Load Winsock2(i)
      Load tmrOnline(i)
      tmrOnline(i).Interval = 100
      tmrOnline(i).Enabled = True
      Winsock2(i).Accept requestID
      SendComplete(i) = True
      Sockinuse(i) = True
      Sock = i
      Exit For
 
    End If
 
  Next
 
  rtfProtokoll.Text = rtfProtokoll.Text & "**** Anfrage erhalten..." & vbCrLf
  rtfProtokoll.Text = rtfProtokoll.Text & "**** Anfrage Akzeptiert..." & vbCrLf
 
End Sub
 
Private Sub Winsock2_DataArrival(Index As Integer, ByVal bytesTotal As Long)
 
  Dim Inc_Data As String
 
  Winsock2(Sock).GetData Inc_Data, vbString
  If Left(Inc_Data, 3) = "GET" Then
    Method = "GET"
    URL = Mid(Inc_Data, 5, InStr(1, Inc_Data, "HTTP/") - 6)
  Else
    Method = "POST"
    URL = Mid(Inc_Data, 5, InStr(1, Inc_Data, "HTTP/") - 7)
  End If
 
  Call FileExists("C:/server/" & URL)
  Call Senddata(URL, File_Exists)
 
End Sub
 
Private Function Senddata(adress As String, exs As String)
 
  SendComplete(Port) = False
 
 
  If URL = "/admin.htm" Or URL = "/admin.html" Then
    data = "Willkommen im Admin Panel!"
  Else
    If exs = "Wahr" Then
      Call Ofnen(URL)
    Else
      Call Error("404", URL)
    End If
  End If
 
    tmrOnline(Sock).Interval = 100
    tmrOnline(Sock).Enabled = True
 
    Winsock2(Sock).Senddata data
 
End Function
 
Private Sub Winsock2_SendComplete(Index As Integer)
SendComplete(Sock) = True
End Sub