hasht.rood
دوشنبه 14 آذر 1390, 19:23 عصر
سلام دوستان گل من
برنامه زير يك http server هست كه يك فايل html رو از كنار پروژه لود ميكنه.
من ميخوام كه فايل html رو از روي سايت (http://sitename.com/dir) بخونه. يعني نياز نباشه كه فايل html كنار پروژه باشه
عكس برنامه:
78770
سورس برنامه:
form1
Dim Users As Integer
Dim ResData As String
Sub CGI(Data, Index As Integer)
Dim StrBuff As String
Dim StrBuffer As String
Dim mStart, mEnd As Integer
mEnd = Len(Data)
mStart = InStr(Data, "Name")
If mStart Then
StrBuffer = Mid(Data, mStart, mEnd)
End If
'
StrBuffer = Replace(StrBuffer, "=", "")
StrBuffer = Replace(StrBuffer, "Name", "")
StrBuffer = Replace(StrBuffer, "Message", "")
StrBuffer = Replace(StrBuffer, "Comments", "")
StrBuffer = Replace(StrBuffer, "Send", "")
StrBuffer = Replace(StrBuffer, "Submit", "")
StrBuffer = Replace(StrBuffer, "+", " ")
StrBuffer = Replace(StrBuffer, "&", vbNewLine)
StrBuffer = Replace(StrBuffer, "%0D", "")
StrBuffer = Replace(StrBuffer, "%0A", vbNewLine)
StrBuffer = Trim(StrBuffer)
If Len(StrBuffer) > 8 Then
StrBuffer = Replace(StrBuffer, " ", " ")
StrBuffer = Replace(StrBuffer, Chr(13), "<p>")
Open App.Path & "\Board.htm" For Append As #1
Print #1, StrBuffer & "<br>"
Print #1, Date & Space(5) & Time
Print #1, "<hr>"
Close #1
Winsock1(Index).SendData "<p><b>Thank you for your feed back</b></p>"
Winsock1(Index).SendData "<p> Return back to <a href=" & Chr(34) & Chr(34) & ">" & Winsock1(0).LocalHostName & "</a> </p>"
End If
b1 = InStr(Data, "TSerach")
If b1 Then
StrBuff = Mid(Data, b1 + 8, Len(Data))
StrBuff = Replace(StrBuff, "Submit", "")
StrBuff = Replace(StrBuff, "&", "")
StrBuff = Replace(StrBuff, "=", "")
StrBuff = Replace(StrBuff, "+", " ")
StrBuff = Replace(StrBuff, Chr(10), "")
StrBuff = Replace(StrBuff, Chr(13), "")
StrBuff = Trim(StrBuff)
LoadSerachData StrBuff, Index
End If
End Sub
Sub LoadSerachData(FindWhat As String, Index As Integer)
Dim Filenum As Integer
Dim A1, A2 As Integer
Dim K As Integer
Filenum = FreeFile
Img = Replace("<h3><font face=ےCopperplate Gothic Boldے color=ے#FF0000ے>Hound Search</font></h3><p align=ےcenterے><img border=ے0ے src=ےbulldog.gifے width=ے456ے height=ے70ے></p><p align=ےrightے><font color=ے#0000FFے>Your number one search place</font></p><hr>", Chr(255), Chr(34))
Winsock1(Index).SendData Img
Open App.Path & "\Serach.txt" For Input As #Filenum
Do While Not EOF(Filenum)
Input #Filenum, StrBuffer
A1 = InStr(StrBuffer, FindWhat)
A2 = InStr(StrBuffer, "|")
Href = Trim(Mid(StrBuffer, A2 + 1, Len(StrBuffer)))
If A1 Then
K = K + 1
Winsock1(Index).SendData StrConv(Href & "<hr>", vbProperCase)
Else
End If
Loop
Close #Filenum
Winsock1(Index).SendData StrConv("<b>Found " & K & " Results for " & FindWhat & "</b>", vbProperCase)
Winsock1(Index).SendData StrConv("<p><i>Want to Try searching for something else Go back to </i><i><a href=" & Chr(34) & "Serach.htm" & Chr(34) & ">search", vbProperCase)
End Sub
Function FindFile(FileName As String) As Boolean
If Dir(FileName) = "" Then
FindFile = False
Else
FindFile = True
End If
End Function
Sub SendData(page, Index)
Dim databyte() As Byte
On Error Resume Next
If page = " " Then page = txtpage.Text
If FileExists(txtPath.Text & page) Then
Open txtPath.Text & page For Binary Shared As #1
ReDim databyte(0 To LOF(1))
Get #1, , databyte()
Close #1
Winsock1(Index).SendData databyte()
Else
Module1.Http404
Winsock1(Index).SendData Module1.Http_404_Error
End If
End Sub
Private Sub Command1_Click(Index As Integer)
Select Case Index
Case 0
Winsock1(0).Listen
Command1(0).Enabled = False
Command1(1).Enabled = True
Case 1
Winsock1(0).Close
Command1(0).Enabled = True
Command1(1).Enabled = False
Case 2
End
End Select
End Sub
Private Sub Form_Load()
If Right(App.Path, 1) = "\" Then
txtPath = App.Path
Else
txtPath = App.Path & "\"
End If
Winsock1(0).LocalPort = 80
Form1.Caption = "Simple http Server: " & Winsock1(0).LocalIP
Select Case Index
Case 0
Winsock1(0).Listen
Command1(0).Enabled = False
Command1(1).Enabled = True
Case 1
Winsock1(0).Close
Command1(0).Enabled = True
Command1(1).Enabled = False
Case 2
End
End Select
End Sub
Private Sub Winsock1_ConnectionRequest(Index As Integer, ByVal requestID As Long)
If Index = 0 Then
Users = Users + 1
Load Winsock1(Users)
Winsock1(Users).LocalPort = 0
Winsock1(Users).Accept requestID
End If
If Err Then Err.Clear
End Sub
Private Sub Winsock1_DataArrival(Index As Integer, ByVal bytesTotal As Long)
Dim StrData As String
Dim page As String
Winsock1(Index).GetData StrData
CGI StrData, Index
If Mid(StrData, 1, 3) = "GET" Then
StrGet = InStr(StrData, "GET ")
spc2 = InStr(StrGet + 5, StrData, " ")
page = Mid$(StrData, StrGet + 5, spc2 - (StrGet + 4))
SendData page, Index
End If
End Sub
Private Sub Winsock1_SendComplete(Index As Integer)
Winsock1(Index).Close
End Sub
module1:
Public Http_404_Error As String
Public Function FileExists(ByVal sFilename As String) As Integer
Dim x
x = Dir(sFilename)
If x = "" Then
FileExists = 0
Else
FileExists = -1
End If
End Function
Sub Http404()
Dim HttpErr As String
HttpErr = ""
HttpErr = "<p><img border=ے0ے src=ےres://C:\WINDOWS\SYSTEM\SHDOCLC.DLL/pagerror.gifے> "
HttpErr = HttpErr + "<span id=ےerrorTextے><font size=ے4ے color=ے#FF0000ے>The Page You Selected cannot"
HttpErr = HttpErr + " be Displayed</font></span></p>"
HttpErr = HttpErr + "<p><b>Peronal Web Server</b></p>"
HttpErr = HttpErr + "<p>The page you are looking for is currently unavailable. The Web <br>"
HttpErr = HttpErr + "site might be experiencing technical difficulties, or you may need <br>"
HttpErr = HttpErr + "to adjust your browser settings.</p>"
HttpErr = HttpErr + "<hr>"
HttpErr = HttpErr + "<p>Try one of the flowing options below:</p>"
HttpErr = HttpErr + "<ul>"
HttpErr = HttpErr + " <li><font size=ے3ے>Please make sure that the address you type in the URL bar"
HttpErr = HttpErr + " is spelled correctly.</font></li>"
HttpErr = HttpErr + " <li><font size=ے3ے>Click <a href=ےjavascript:history.back(1)ے><img border=ے0ے src=ےres://C:\WINDOWS\SYSTEM\SHDOCLC.DLL/back.gifے>"
HttpErr = HttpErr + " Back</a> and try again latter</font></li>"
HttpErr = HttpErr + " <li><font size=ے3ے>Click here <a href=ےjavascript:location.reload()ے><img border=ے0ے src=ےres://C:\WINDOWS\SYSTEM\SHDOCLC.DLL/refresh.gifے></a>"
HttpErr = HttpErr + " <a href=ےjavascript:location.reload()ے>refresh</a> and try again</font></li>"
HttpErr = HttpErr + "</ul>"
HttpErr = HttpErr + "<hr>"
HttpErr = HttpErr + "<p><i>If you have any more errors then please<br>"
HttpErr = HttpErr + "contact the local admin service</i></p>"
HttpErr = HttpErr + "<p><u><b>HTTP 404 - Page Not Found</b></u></p>"
Http_404_Error = Replace(HttpErr, Chr(255), Chr(34))
End Sub
دانلود فايل پروژه:78771
برنامه زير يك http server هست كه يك فايل html رو از كنار پروژه لود ميكنه.
من ميخوام كه فايل html رو از روي سايت (http://sitename.com/dir) بخونه. يعني نياز نباشه كه فايل html كنار پروژه باشه
عكس برنامه:
78770
سورس برنامه:
form1
Dim Users As Integer
Dim ResData As String
Sub CGI(Data, Index As Integer)
Dim StrBuff As String
Dim StrBuffer As String
Dim mStart, mEnd As Integer
mEnd = Len(Data)
mStart = InStr(Data, "Name")
If mStart Then
StrBuffer = Mid(Data, mStart, mEnd)
End If
'
StrBuffer = Replace(StrBuffer, "=", "")
StrBuffer = Replace(StrBuffer, "Name", "")
StrBuffer = Replace(StrBuffer, "Message", "")
StrBuffer = Replace(StrBuffer, "Comments", "")
StrBuffer = Replace(StrBuffer, "Send", "")
StrBuffer = Replace(StrBuffer, "Submit", "")
StrBuffer = Replace(StrBuffer, "+", " ")
StrBuffer = Replace(StrBuffer, "&", vbNewLine)
StrBuffer = Replace(StrBuffer, "%0D", "")
StrBuffer = Replace(StrBuffer, "%0A", vbNewLine)
StrBuffer = Trim(StrBuffer)
If Len(StrBuffer) > 8 Then
StrBuffer = Replace(StrBuffer, " ", " ")
StrBuffer = Replace(StrBuffer, Chr(13), "<p>")
Open App.Path & "\Board.htm" For Append As #1
Print #1, StrBuffer & "<br>"
Print #1, Date & Space(5) & Time
Print #1, "<hr>"
Close #1
Winsock1(Index).SendData "<p><b>Thank you for your feed back</b></p>"
Winsock1(Index).SendData "<p> Return back to <a href=" & Chr(34) & Chr(34) & ">" & Winsock1(0).LocalHostName & "</a> </p>"
End If
b1 = InStr(Data, "TSerach")
If b1 Then
StrBuff = Mid(Data, b1 + 8, Len(Data))
StrBuff = Replace(StrBuff, "Submit", "")
StrBuff = Replace(StrBuff, "&", "")
StrBuff = Replace(StrBuff, "=", "")
StrBuff = Replace(StrBuff, "+", " ")
StrBuff = Replace(StrBuff, Chr(10), "")
StrBuff = Replace(StrBuff, Chr(13), "")
StrBuff = Trim(StrBuff)
LoadSerachData StrBuff, Index
End If
End Sub
Sub LoadSerachData(FindWhat As String, Index As Integer)
Dim Filenum As Integer
Dim A1, A2 As Integer
Dim K As Integer
Filenum = FreeFile
Img = Replace("<h3><font face=ےCopperplate Gothic Boldے color=ے#FF0000ے>Hound Search</font></h3><p align=ےcenterے><img border=ے0ے src=ےbulldog.gifے width=ے456ے height=ے70ے></p><p align=ےrightے><font color=ے#0000FFے>Your number one search place</font></p><hr>", Chr(255), Chr(34))
Winsock1(Index).SendData Img
Open App.Path & "\Serach.txt" For Input As #Filenum
Do While Not EOF(Filenum)
Input #Filenum, StrBuffer
A1 = InStr(StrBuffer, FindWhat)
A2 = InStr(StrBuffer, "|")
Href = Trim(Mid(StrBuffer, A2 + 1, Len(StrBuffer)))
If A1 Then
K = K + 1
Winsock1(Index).SendData StrConv(Href & "<hr>", vbProperCase)
Else
End If
Loop
Close #Filenum
Winsock1(Index).SendData StrConv("<b>Found " & K & " Results for " & FindWhat & "</b>", vbProperCase)
Winsock1(Index).SendData StrConv("<p><i>Want to Try searching for something else Go back to </i><i><a href=" & Chr(34) & "Serach.htm" & Chr(34) & ">search", vbProperCase)
End Sub
Function FindFile(FileName As String) As Boolean
If Dir(FileName) = "" Then
FindFile = False
Else
FindFile = True
End If
End Function
Sub SendData(page, Index)
Dim databyte() As Byte
On Error Resume Next
If page = " " Then page = txtpage.Text
If FileExists(txtPath.Text & page) Then
Open txtPath.Text & page For Binary Shared As #1
ReDim databyte(0 To LOF(1))
Get #1, , databyte()
Close #1
Winsock1(Index).SendData databyte()
Else
Module1.Http404
Winsock1(Index).SendData Module1.Http_404_Error
End If
End Sub
Private Sub Command1_Click(Index As Integer)
Select Case Index
Case 0
Winsock1(0).Listen
Command1(0).Enabled = False
Command1(1).Enabled = True
Case 1
Winsock1(0).Close
Command1(0).Enabled = True
Command1(1).Enabled = False
Case 2
End
End Select
End Sub
Private Sub Form_Load()
If Right(App.Path, 1) = "\" Then
txtPath = App.Path
Else
txtPath = App.Path & "\"
End If
Winsock1(0).LocalPort = 80
Form1.Caption = "Simple http Server: " & Winsock1(0).LocalIP
Select Case Index
Case 0
Winsock1(0).Listen
Command1(0).Enabled = False
Command1(1).Enabled = True
Case 1
Winsock1(0).Close
Command1(0).Enabled = True
Command1(1).Enabled = False
Case 2
End
End Select
End Sub
Private Sub Winsock1_ConnectionRequest(Index As Integer, ByVal requestID As Long)
If Index = 0 Then
Users = Users + 1
Load Winsock1(Users)
Winsock1(Users).LocalPort = 0
Winsock1(Users).Accept requestID
End If
If Err Then Err.Clear
End Sub
Private Sub Winsock1_DataArrival(Index As Integer, ByVal bytesTotal As Long)
Dim StrData As String
Dim page As String
Winsock1(Index).GetData StrData
CGI StrData, Index
If Mid(StrData, 1, 3) = "GET" Then
StrGet = InStr(StrData, "GET ")
spc2 = InStr(StrGet + 5, StrData, " ")
page = Mid$(StrData, StrGet + 5, spc2 - (StrGet + 4))
SendData page, Index
End If
End Sub
Private Sub Winsock1_SendComplete(Index As Integer)
Winsock1(Index).Close
End Sub
module1:
Public Http_404_Error As String
Public Function FileExists(ByVal sFilename As String) As Integer
Dim x
x = Dir(sFilename)
If x = "" Then
FileExists = 0
Else
FileExists = -1
End If
End Function
Sub Http404()
Dim HttpErr As String
HttpErr = ""
HttpErr = "<p><img border=ے0ے src=ےres://C:\WINDOWS\SYSTEM\SHDOCLC.DLL/pagerror.gifے> "
HttpErr = HttpErr + "<span id=ےerrorTextے><font size=ے4ے color=ے#FF0000ے>The Page You Selected cannot"
HttpErr = HttpErr + " be Displayed</font></span></p>"
HttpErr = HttpErr + "<p><b>Peronal Web Server</b></p>"
HttpErr = HttpErr + "<p>The page you are looking for is currently unavailable. The Web <br>"
HttpErr = HttpErr + "site might be experiencing technical difficulties, or you may need <br>"
HttpErr = HttpErr + "to adjust your browser settings.</p>"
HttpErr = HttpErr + "<hr>"
HttpErr = HttpErr + "<p>Try one of the flowing options below:</p>"
HttpErr = HttpErr + "<ul>"
HttpErr = HttpErr + " <li><font size=ے3ے>Please make sure that the address you type in the URL bar"
HttpErr = HttpErr + " is spelled correctly.</font></li>"
HttpErr = HttpErr + " <li><font size=ے3ے>Click <a href=ےjavascript:history.back(1)ے><img border=ے0ے src=ےres://C:\WINDOWS\SYSTEM\SHDOCLC.DLL/back.gifے>"
HttpErr = HttpErr + " Back</a> and try again latter</font></li>"
HttpErr = HttpErr + " <li><font size=ے3ے>Click here <a href=ےjavascript:location.reload()ے><img border=ے0ے src=ےres://C:\WINDOWS\SYSTEM\SHDOCLC.DLL/refresh.gifے></a>"
HttpErr = HttpErr + " <a href=ےjavascript:location.reload()ے>refresh</a> and try again</font></li>"
HttpErr = HttpErr + "</ul>"
HttpErr = HttpErr + "<hr>"
HttpErr = HttpErr + "<p><i>If you have any more errors then please<br>"
HttpErr = HttpErr + "contact the local admin service</i></p>"
HttpErr = HttpErr + "<p><u><b>HTTP 404 - Page Not Found</b></u></p>"
Http_404_Error = Replace(HttpErr, Chr(255), Chr(34))
End Sub
دانلود فايل پروژه:78771