saschart
Dec 18th, 2005, 03:04 AM
I need a very simple server which can put in the internet one image when receive a code in get request. I try some code which work but stoping in 15-30 minutes, who know why?
The code is here:
Dim webID As Integer
Dim maxUsers As Integer
Private Sub Form_Load()
Dim active As Integer
If App.PrevInstance = True Then
End
Else
webID = 0
maxUsers = 2
For active = 1 To maxUsers
Load webServer(active)
Next active
StartServer
End If
End Sub
Public Sub StartServer()
On Error GoTo MyWebError
webServer(0).Disconnect
webServer(0).LocalPort = 88
webServer(0).Listen
Exit Sub
MyWebError:
MsgBox "Web Server cannot be start! Port " & webServer(0).LocalPort & " may be in use by another application.", vbExclamation
End Sub
Private Sub webServer_Accept(Index As Integer, SocketId As Integer)
On Error GoTo MyReset
Label1 = "accept connect"
webID = webID + 1
If webID = maxUsers Then webID = 1
If webServer(webID).Connected = False Then
webServer(webID).Accept = SocketId
Else
GoTo MyReset
End If
Label2 = webID
Exit Sub
MyReset:
webServer(webID).Disconnect
Exit Sub
End Sub
Private Sub webServer_Read(Index As Integer, DataLength As Integer, IsUrgent As Integer)
Dim nPos As Integer
Dim strGet As String
Dim fileBuffer As String
Dim strHeader As String
Dim fileserver As String
Dim getBuffer As String
Dim readBuffer As Integer
Dim lenBuffer As Integer
Dim BytesWrite As Integer
Dim f As Integer
f = FreeFile
fileBuffer = ""
readBuffer = webServer(Index).Read(getBuffer, 2048)
nPos = InStr(5, getBuffer, " ")
strGet = Mid(getBuffer, 5, nPos - 5)
nPos = InStr(getBuffer, Chr(10))
strHeader = getBuffer
If Left(strGet, 22) = "/U2FzY2hBcnRtZXJnZXRi?" Then
fileserver = App.Path & "\imagetoshow.jpg"
If Len(Dir$(fileserver)) > 0 Then
lenBuffer = FileLen(fileserver)
Open fileserver For Binary As #f
fileBuffer = Input(lenBuffer, #f)
Close #f
Else
fileBuffer = "#"
End If
'back headers
strHeader = "HTTP/1.1 200 OK" & Chr(13) & Chr(10)
strHeader = strHeader & "Server: SaServer" & Chr(13) & Chr(10)
strHeader = strHeader & "Cache-Control: no-store, no-cache, must-revalidate, post-check=0, pre-check=0" & Chr(13) & Chr(10)
strHeader = strHeader & "Pragma: no-cache" & Chr(13) & Chr(10)
strHeader = strHeader & "Connection: close" & Chr(13) & Chr(10)
strHeader = strHeader & "Content-Type: image/jpeg" & Chr(13) & Chr(10)
strHeader = strHeader & Chr(13) & Chr(10)
BytesWrite = webServer(Index).Write(strHeader, Len(strHeader))
BytesWrite = webServer(Index).Write(fileBuffer, Len(fileBuffer))
End If
If webServer(Index).Connected Then
webServer(Index).Disconnect
End If
End Sub
Private Sub webServer_Disconnect(Index As Integer)
webServer(Index).Disconnect
End Sub
Private Sub Label2_Click()
Shell ("Explorer " & Label2), vbNormalNoFocus
End Sub
I use SocketWrench Freeware Edition from Catalyst.
The code is here:
Dim webID As Integer
Dim maxUsers As Integer
Private Sub Form_Load()
Dim active As Integer
If App.PrevInstance = True Then
End
Else
webID = 0
maxUsers = 2
For active = 1 To maxUsers
Load webServer(active)
Next active
StartServer
End If
End Sub
Public Sub StartServer()
On Error GoTo MyWebError
webServer(0).Disconnect
webServer(0).LocalPort = 88
webServer(0).Listen
Exit Sub
MyWebError:
MsgBox "Web Server cannot be start! Port " & webServer(0).LocalPort & " may be in use by another application.", vbExclamation
End Sub
Private Sub webServer_Accept(Index As Integer, SocketId As Integer)
On Error GoTo MyReset
Label1 = "accept connect"
webID = webID + 1
If webID = maxUsers Then webID = 1
If webServer(webID).Connected = False Then
webServer(webID).Accept = SocketId
Else
GoTo MyReset
End If
Label2 = webID
Exit Sub
MyReset:
webServer(webID).Disconnect
Exit Sub
End Sub
Private Sub webServer_Read(Index As Integer, DataLength As Integer, IsUrgent As Integer)
Dim nPos As Integer
Dim strGet As String
Dim fileBuffer As String
Dim strHeader As String
Dim fileserver As String
Dim getBuffer As String
Dim readBuffer As Integer
Dim lenBuffer As Integer
Dim BytesWrite As Integer
Dim f As Integer
f = FreeFile
fileBuffer = ""
readBuffer = webServer(Index).Read(getBuffer, 2048)
nPos = InStr(5, getBuffer, " ")
strGet = Mid(getBuffer, 5, nPos - 5)
nPos = InStr(getBuffer, Chr(10))
strHeader = getBuffer
If Left(strGet, 22) = "/U2FzY2hBcnRtZXJnZXRi?" Then
fileserver = App.Path & "\imagetoshow.jpg"
If Len(Dir$(fileserver)) > 0 Then
lenBuffer = FileLen(fileserver)
Open fileserver For Binary As #f
fileBuffer = Input(lenBuffer, #f)
Close #f
Else
fileBuffer = "#"
End If
'back headers
strHeader = "HTTP/1.1 200 OK" & Chr(13) & Chr(10)
strHeader = strHeader & "Server: SaServer" & Chr(13) & Chr(10)
strHeader = strHeader & "Cache-Control: no-store, no-cache, must-revalidate, post-check=0, pre-check=0" & Chr(13) & Chr(10)
strHeader = strHeader & "Pragma: no-cache" & Chr(13) & Chr(10)
strHeader = strHeader & "Connection: close" & Chr(13) & Chr(10)
strHeader = strHeader & "Content-Type: image/jpeg" & Chr(13) & Chr(10)
strHeader = strHeader & Chr(13) & Chr(10)
BytesWrite = webServer(Index).Write(strHeader, Len(strHeader))
BytesWrite = webServer(Index).Write(fileBuffer, Len(fileBuffer))
End If
If webServer(Index).Connected Then
webServer(Index).Disconnect
End If
End Sub
Private Sub webServer_Disconnect(Index As Integer)
webServer(Index).Disconnect
End Sub
Private Sub Label2_Click()
Shell ("Explorer " & Label2), vbNormalNoFocus
End Sub
I use SocketWrench Freeware Edition from Catalyst.