hola a todos
aca paso el codigo de una especie de servidor web echo en vb6
lo lindo es que se pueden bajar archivos con el download acelerator (es con el unico que lo prove) y supongo que con otros de su estilo
igual hay que mejorarlo mucho, por ej
cuando se baja un archivo el programa que se queda duro abriendolo
si alguno sabe como arreglar eso que pase la respuesta n_n
aca esta el fuente
disfrutenlo
Dim Dato As String
Dim Requestedpage As String
Dim Fecha As String
Private Function AbrirArchivo(Archivo As String) As String
Dim File As Integer
Dim TextAUX As String
Dim CHAR As String
On Error Resume Next
File = FreeFile
TextAUX = ""
If ExisteArchivo(Archivo) Then
If Len(Archivo) Then
Open Archivo For Input As #File
Do While Not EOF(File)
CHAR = Input(1, #File)
TextAUX = "" & TextAUX & CHAR
Loop
Close #File
End If
AbrirArchivo = TextAUX
Else
AbrirArchivo = ""
End If
End Function
Private Function ExisteArchivo(ByVal Archivo As String) As Integer
Dim I As Integer
On Error Resume Next
I = Len(Dir(Archivo))
If Err Or I = 0 Then
ExisteArchivo = False
Else
ExisteArchivo = True
End If
End Function
Private Function LoadBinary(ByVal strFileName As String) As String
'aca esta el problema, se queda duro hasta que no abre el archivo
Close
Dim ff As Integer
ff = FreeFile
DoEvents
Open strFileName For Binary As #ff
DoEvents
LoadBinary = Input(FileLen(strFileName), #ff)
DoEvents
Close #ff
End Function
Private Function Pagina_Prueba()
Dim x As String
x = ""
x = x & "<html>" & vbCrLf
x = x & " " & vbCrLf
x = x & "<head>" & vbCrLf
x = x & "<meta http-equiv=""Content-Type" & vbCrLf
x = x & "content=""text/html; charset=iso-8859-1"">" & vbCrLf
x = x & "<title>jcq web server</title>" & vbCrLf
x = x & "</head>" & vbCrLf
x = x & " " & vbCrLf
x = x & "<body bgcolor=""#FFFFFF"">" & vbCrLf
x = x & "<div align=""center""><center>" & vbCrLf
x = x & " " & vbCrLf
x = x & "<pre><font color=""#0000FF"" size=""6"" face=""Lucida Sans Unicode"">jcq web server</font></pre>" & vbCrLf
x = x & "</center></div>" & vbCrLf
x = x & " " & vbcrlft
x = x & "<p> </p>" & vbCrLf
x = x & " " & vbcrlft
x = x & "<p><a" & vbCrLf
x = x & "href=""http://jcq.dnsalias.com/Cliente_Jcq_BETA.exe"">http://jcq.dnsalias.com/Cliente_Jcq_BETA.exe</a></p>" & vbCrLf
x = x & "<p><a" & vbCrLf
x = x & "href=""http://jcq.dnsalias.com/prueba.mp3"">http://jcq.dnsalias.com/prueba.mp3</a></p>" & vbCrLf
x = x & "<p><a" & vbCrLf
x = x & "href=""http://jcq.dnsalias.com/download.zip"">http://jcq.dnsalias.com/download.zip</a></p>" & vbCrLf
x = x & "<p><a" & vbCrLf
x = x & "href=""http://jcq.dnsalias.com/default.htm"">http://jcq.dnsalias.com/default.htm</a></p>" & vbCrLf
x = x & "</body>" & vbCrLf
x = x & "</html>" & vbCrLf
Pagina_Prueba = x
End Function
Private Sub Form_Load()
List1.Clear
Winsock1.LocalPort = 80
Winsock1.Listen
End Sub
Private Sub Winsock1_ConnectionRequest(ByVal requestID As Long)
On Error GoTo solucion
Winsock1.Close
Winsock1.LocalPort = 0
Winsock1.Accept requestID
List1.AddItem Winsock1.RemoteHostIP
DoEvents
If Requestedpage = "/" Or Requestedpage = "" Then 'manda la pagina de inicio
Winsock1.SendData Pagina_Prueba
'Requestedpage = "" 'hmm
'Dato = ""
Else
If ExisteArchivo(App.Path + Requestedpage) Then
'Winsock1.SendData LoadBinary(App.Path & "\" & Requestedpage)
DoEvents
Winsock1.SendData Pepe
DoEvents
''Winsock1.SendData AbrirArchivo(App.Path & "\" & Requestedpage)
Requestedpage = ""
Dato = ""
Else
'aca tengo que poner error 404
End If
End If
Exit Sub
'//Envio_Completo
solucion:
'MsgBox Err.Number & " " & Err.Description
Text1.Text = Err.Number & " " & Err.Description
Winsock1.Close
Winsock1.LocalPort = 80
Winsock1.Listen
End Sub
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
'Dim dato As String
Winsock1.GetData Dato
Text2.Text = ""
Text2.Text = Dato
If Mid(Dato, 1, 3) = "GET" Then
findget = InStr(Dato, "GET ")
spc2 = InStr(findget + 5, Dato, " ")
pagetoget = Mid(Dato, findget + 4, spc2 - (findget + 4))
Requestedpage = pagetoget
DoEvents
Form1.Caption = Requestedpage
'List2.AddItem Dato
List2.AddItem Requestedpage
ElseIf Mid(Dato, 1, 4) = "POST" Then
findpost = InStr(Dato, "POST ")
spc2 = InStr(findpost + 5, Dato, " ")
pagetopost = Mid(Dato, findpost + 5, spc2 - (findpost + 5))
Requestedpage = pagetopost
End If
End Sub
Private Sub Winsock1_SendComplete()
'If Requestedpage = "/" Or Requestedpage = "" Then
Envio_Completo
'Else
'End If
End Sub
Sub Envio_Completo()
Winsock1.Close
Winsock1.LocalPort = 80
Winsock1.Listen
End Sub
Sub Fecha_de_Archivo(Direccion As String)
Dim fs, f
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(Direccion)
Fecha = "Creado: " & f.DateCreated
End Sub
Private Function Pepe()
Dim Q As String
Fecha_de_Archivo (App.Path & Requestedpage)
Q = ""
Q = Q & "HTTP/1.0 200 OK" & vbCrLf
Q = Q & "Date: " & Now & vbCrLf '
Q = Q & "Server: Jcq Web Server 0.1" & vbCrLf
Q = Q & "MIME-version: 1.0" & vbCrLf
Q = Q & "Content-type: " & Dir(App.Path & "\" & Requestedpage) & vbCrLf
Q = Q & "Content-length: " & FileLen(App.Path & "\" & Requestedpage) & vbCrLf
Q = Q & "Last-modified: " & Fecha & vbCrLf
Q = Q & "" & vbCrLf
DoEvents
'Q = Q & AbrirArchivo(App.Path & "\" & Requestedpage)
Q = Q & LoadBinary(App.Path & "\" & Requestedpage)
DoEvents
Pepe = Q
End Function
Pd: alguno responda para ver que le parecio :P |
