Några sidor - Winsock (Microsoft Winsock Control)

För att köra lite mer "low level" nätverk kan man använda Winsock komponenten i VB.

Bästa stället att börja leta efter exempel är i VB hjälpen under Office 97 development, kapitel 15.

Programmet förutsätter en TextBox med namnet txtOutput samt två Winsock kontroller med namnen httpListen och httpServer

Option Base 1
Option Explicit
' kanske inte ASP men lite åt det hållet!
Const cTemplate = "<html><title>#TITLE#</title><body>#BODY#</body></html>"

' en liten array som exempel
Dim testArray As Variant

Private Sub Form_Load()
    ' initiera arrayen
    testArray = Array("EN ETTA", "EN TVÅ", "EN TREA", "O FYRA", "KANSKE FEM")

    ' vi använder port 1002
    ' exempel URL (lokal) http://127.0.0.1:1002/1
    httpListen.LocalPort = 1002

    On Error Resume Next
    httpListen.Listen
    OutputString "NOT Listening "
    On Error GoTo 0

    If httpListen.State = sckListening Then
        ClearOutputString
        OutputString "Listening "
    End If
End Sub

Private Sub httpServer_Close()
    If httpServer.State <> 0 Then
        httpServer.Close
    End If
    OutputString " Close "
End Sub

Private Sub httpServer_Connect()
OutputString "Connect "
End Sub

Private Sub httpListen_ConnectionRequest(ByVal requestID As Long)
    If httpServer.State <> sckClosed Then httpServer.Close
    OutputString "Connecting "
    httpServer.Accept requestID
End Sub

Private Sub httpServer_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
OutputString "SERVER: " & Number & vbCrLf & Description
End Sub

Private Sub httpListen_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
OutputString "LISTEN" & vbCrLf & Number & vbCrLf & Description
End Sub

' Sänta datat färdigt
Private Sub httpServer_SendComplete()
    OutputString vbCrLf & "Send OK"
    ' Vi är väl klara med sändningen och kan stänga förbindelsen
    httpServer.Close
End Sub

' någon frågar någonting

Private Sub httpServer_DataArrival(ByVal bytesTotal As Long)
    Dim strData As String
    Dim strResponse As String
    Dim strTemp As String
    Dim whatItem As Integer

    ' tag emot datat (förfrågan i HTTP sammanhang)
    httpServer.GetData strData
    OutputString "Getting Data: "
    OutputString strData

strTemp = ExtractGetRequest(strData)

    ' i detta exempel returnerar vi bara ett värde från arrayen
    If IsNumeric(strTemp) Then
        whatItem = CInt(ExtractGetRequest(strData))
    Else
        whatItem = 9999 ' dumt men detta är bara ett exempel...
    End If

OutputString "Sending: "

    If whatItem <= UBound(testArray) And whatItem > 0 Then
        strResponse = MakeResponse(testArray(whatItem), _
                                   "Super Delux Nonsens Server")
    Else
        strResponse = MakeResponse("<p>Sorry...</p>" & _
                                    "<p>Finns ingenting att säga om " & _
                                    strTemp & "</p>")
    End If

OutputString strResponse

' sänd det formatterade datat
httpServer.SendData strResponse
End Sub

Private Function MakeHeader(ByVal Data As String) As String
    Dim strHeader As String
    Dim dateNow As Date
    dateNow = Now

    strHeader = "HTTP/1.0 200 OK" & vbCrLf
    strHeader = strHeader & "Date: " & GMTformat(dateNow) & vbCrLf
    strHeader = strHeader & "Server: NonsenseServer/1.0" & vbCrLf
    strHeader = strHeader & "Content-Type: text/html" & vbCrLf
    strHeader = strHeader & "Last-Modified: " & GMTformat(dateNow) & vbCrLf
    ' observera att headern måste sluta med två CRLF
    strHeader = strHeader & "Content-Length: " & Len(Data) & vbCrLf & vbCrLf
    MakeHeader = strHeader
End Function

Private Function MakeResponse(ByVal Data As String, Optional Title As String) As String
    Dim strHeader As String
    Dim strTemplate As String
    Dim dateNow As Date
    If IsMissing(Title) Then
        Title = "MinSpecialServer"
    End If

dateNow = Now
strTemplate = cTemplate

' byt ut #TITLE# i mallen till den verkliga titeln
strTemplate = Replace(cTemplate, "#TITLE#", Title)

' byt ut #BODY# i mallen till den verkliga texten
strTemplate = Replace(strTemplate, "#BODY#", Data)

strHeader = MakeHeader(strTemplate)
MakeResponse = strHeader & strTemplate
End Function

' formaterar datum som t.ex. Tue, 12 Sep 2000 22:18:26 GMT
Private Function GMTformat(ByVal theDate As Date) As String
    Dim Days As Variant
    Dim Months As Variant
    Days = Array("Sun", "Mon", "Tue", "Wed", "Thur", "Fri", "Sat")
    Months = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
    GMTformat = Days(Weekday(theDate, vbSunday)) & _
                Format(theDate, ", d ") & _
                Months(Month(theDate)) & _
                Format(theDate, " yyyy Hh:Nn:Ss G\MT")
End Function

' HTTP förfrågan börjar alltid med GET /xxx HTTP/1.x
' där x kan vara 0 eller 1 beroende på vilken
' protokoll standard som browsern stöder (oftast 1.1)
' om man använt http://www.sajt.com:1002/xxx
' plocka ut det som kommer efter GET men före HTTP i denna sträng
Private Function ExtractGetRequest(ByVal theString As String) As String
    Dim indStart As Long
    Dim indEnd As Long
    indStart = InStr(theString, "GET ") + 5
    indEnd = InStr(theString, " HTTP") - 5
    ExtractGetRequest = Mid(theString, indStart, indEnd)
End Function

' hjälpfunktioner för hantering av textboxen
Private Sub OutputString(ByVal theString As String)
    If Len(txtOutput.Text) > 32000 Then
        ClearOutputString
    End If
    txtOutput.Text = txtOutput.Text & vbCrLf & theString & vbCrLf
End Sub

Private Sub ClearOutputString()
txtOutput.Text = ""
End Sub