form1.frm

用VB编写的一个小程序

  Else
     MsgBox "Bad request: " & Request
  End If
  'Check if a double CrLF is found. (this indicates end of header)
  DCrLfPos = InStr(1, ClientDataArrival(Index).cData, vbCrLf & vbCrLf)
  If DCrLfPos <> 0 Then
  'Found Double CrLF
      'Check if a content-length tag exists (means there are more data to go after the header)
      ContentLengthPos = InStr(1, ClientDataArrival(Index).cData, "Content-Length:")
      
      If ContentLengthPos <> 0 Then
      'Found content length tag
         'Get it's value
         ContentLength = Val(Mid(ClientDataArrival(Index).cData, ContentLengthPos + 15, InStr(ContentLengthPos + 15, ClientDataArrival(Index).cData, vbCrLf) - ContentLengthPos - 15))
         'If the length of the data we have agrees with the header+content length data
         If DCrLfPos + 4 + ContentLength - 1 = Len(ClientDataArrival(Index).cData) Then
            'Request completed and not missing any part
            ClientDataArrival(Index).cCompleted = True
         End If
      Else
      'Content length tag not found => only header in request
         'Request completed and not missing any part
         ClientDataArrival(Index).cCompleted = True
      End If
  End If
'''END OF CHECK IF THE REQUEST IS COMPLETE OR IS MISSING ANY PIECE'''


If ClientDataArrival(Index).cCompleted Then
    'Store the request for later reference
    Open App.Path & "\Logs\CompleteReq" & CRC & ".txt" For Binary As #1
      Put #1, , ClientDataArrival(Index).cData
    Close #1
    CRC = CRC + 1
    
    Dim UserAgentPos&, UserAgentEndPos&
    UserAgentPos = InStr(1, ClientDataArrival(Index).cData, "User-Agent:") + 12
    UserAgentEndPos = InStr(UserAgentPos, ClientDataArrival(Index).cData, vbCrLf)
    List1.AddItem Mid(ClientDataArrival(Index).cData, UserAgentPos, UserAgentEndPos - UserAgentPos)
End If

'PROCESS THE COMPLETED REQUEST
If ClientDataArrival(Index).cCompleted Then
  Request = Mid(ClientDataArrival(Index).cData, 1, InStr(1, ClientDataArrival(Index).cData, " ") - 1)
  Select Case Request
  Case "GET"
    'This is a request for sending a file to the client
    
    'Track the file requested
    Dim bFlag As Integer
    bFlag = -1
    Dim ReqFileName$
    ReqFileName = UrlDecode(Mid(ClientDataArrival(Index).cData, 6, InStr(5, ClientDataArrival(Index).cData, " ") - 6))
    
SendFile:
    For i = 1 To UBound(FileItem)
      If LCase(ReqFileName) = LCase(FileItem(i).text) Then bFlag = i
      If ReqFileName = "" And FileItem(i).Special = 1 Then bFlag = i
    Next
    If bFlag = -1 Then
      For i = 1 To UBound(FileItem)
        If FileItem(i).Special = 2 Then bFlag = i
      Next
    End If
      
      Dim data() As Byte
      'Open the requested file and extract it's data
      If Dir(FileItem(bFlag).Path) = "" Then
         ErrorLog "File not exists: " & FileItem(bFlag).Path
         Client(Index).CloseSck
         Exit Sub
      End If
      
      Open FileItem(bFlag).Path For Binary As #1
        L = LOF(1)
        ReDim data(LOF(1) - 1)
        Get #1, , data
      Close #1
      'Send header and data to client
      Client(Index).SendData _
      "HTTP/1.0 200 OK" & vbCrLf & _
      "Date: " & GetGMTDateTime & vbCrLf & _
      "P3P: policyref=""http://p3p.yahoo.com/w3c/p3p.xml"", CP=""CAO DSP COR CUR ADM DEV TAI PSA PSD IVAi IVDi CONi TELo OTPi OUR DELi SAMi OTRi UNRi PUBi IND PHY ONL UNI PUR FIN COM NAV INT DEM CNT STA POL HEA PRE GOV""" & vbCrLf & _
      "Last-Modified: Tue, 20 May 2003 21:08:48 GMT" & vbCrLf & _
      "ETag: ""da68c-42d-3eca9960""" & vbCrLf & _
      "Accept-Ranges: bytes" & vbCrLf & _
      "Content-Length: " & L & vbCrLf & _
      "Content-Type: " & ContentType(Right(FileItem(bFlag).Path, 3)) & vbCrLf & _
      "Age: 2606" & vbCrLf & _
      "Connection: close" & vbCrLf & vbCrLf & StrConv(data(), vbUnicode)
      bSent(Index) = False
      Do
        DoEvents
      Loop Until bSent(Index)
      Client(Index).CloseSck
  Case "POST"
      ContentLengthPos = InStr(1, ClientDataArrival(Index).cData, "Content-Length:")
      DCrLfPos = InStr(1, ClientDataArrival(Index).cData, vbCrLf & vbCrLf)
      If ContentLengthPos <> 0 Then
         Dim PostResponce As String
         ContentLength = Val(Mid(ClientDataArrival(Index).cData, ContentLengthPos + 15, InStr(ContentLengthPos + 15, ClientDataArrival(Index).cData, vbCrLf) - ContentLengthPos - 15))
         PostResponce = Mid(ClientDataArrival(Index).cData, DCrLfPos + 4, ContentLength)
         'Process post responce here
         SavePostResponce PostResponce
         SavePostForm UrlDecode(Mid(PostResponce, InStr(1, PostResponce, "=") + 1))
         ReqFileName = UrlDecode(Mid(ClientDataArrival(Index).cData, 7, InStr(6, ClientDataArrival(Index).cData, " ") - 7))
         GoTo SendFile
      End If
  End Select
  ClientDataArrival(Index).cData = "" 'CLEAR THE REQUEST
  ClientDataArrival(Index).cCompleted = False
End If
End Sub

Private Sub Client_SendComplete(Index As Integer)
  bSent(Index) = True
End Sub

Private Sub Command2_Click(Index As Integer)
Dim C&
Select Case Index
Case 0
  cd1.Filter = "Web files|*.wml;*.xml;*.wmlc;*.wbxml;*.wmlsc;*.sic;*.wmls;*.wbmp;*.mid;*.mmid;*.mmf;*.wav;*.amr;*.mp3;*.jpg;*.gif;*.bmp;*.ico;*.jad;*.jar|Web page files|*.wml;*.xml;*.wmlc;*.wbxml;*.wmlsc;*.sic;*.wmls|Audio|*.mid;*.mmid;*.mmf;*.wav;*.amr;*.mp3|Images|*.jpg;*.gif;*.bmp;*.ico;*.wbmp|Applications|*.jad;*.jar|(All Files)|*.*"
  cd1.ShowOpen
  If cd1.FileName = "" Then Exit Sub
  C = UBound(FileItem) + 1
  ReDim Preserve FileItem(C)
  FileItem(C).x = (C - 1) Mod 5
  FileItem(C).y = (C - 1) \ 5
  FileItem(C).text = FileNameFromPath(cd1.FileName)
  FileItem(C).Path = cd1.FileName
  FileItem(C).Icon = dIcon(Right(cd1.FileName, 3))
  cd1.FileName = ""
Case 1
  For i = SelectedFileIndex To UBound(FileItem) - 1
     FileItem(i).Icon = FileItem(i + 1).Icon
     FileItem(i).Path = FileItem(i + 1).Path
     FileItem(i).text = FileItem(i + 1).text
  Next
  ReDim Preserve FileItem(UBound(FileItem) - 1)
  Case 2
  If SelectedFileIndex <> 0 And SelectedFileIndex <= UBound(FileItem) Then Me.PopupMenu mnuSetAs, , Command2(Index).Left, Command2(Index).Top + 600
End Select
  FileList.Cls
  RenderFileList
End Sub

Private Sub Command3_Click()
If Client(0).State = sckListening Then
  Client(0).CloseSck
  Command3.Caption = "Start"
  Label1.Caption = "Status: Inactive"
Else
  Client(0).Listen
  Command3.Caption = "Stop"
  Label1.Caption = "Status: Active"
End If
End Sub

Private Sub Command4_Click()
   Socket1.Connect "whatismyip.org", 80
End Sub

Private Sub Command5_Click()
If Dir(App.Path & "\Directory.txt") <> "" Then Kill App.Path & "\Directory.txt"
Open App.Path & "\Directory.txt" For Output As #1
For i = 1 To UBound(FileItem)
    Print #1, FileItem(i).Special & Replace(FileItem(i).Path, App.Path, "$Path", , , vbTextCompare)
Next i
Close #1
End Sub

Private Sub FileList_DblClick()
mnuPreviewItm_Click
End Sub

Private Sub FileList_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
FileList.Cls

'xx = ((x - 10 - IconSpacingX& / 2 + 16) \ IconSpacingX)
'xx = ((x - 10 - IconSpacingX& / 2 + 16) \ IconSpacingX)
xx = ((x - 10) \ IconSpacingX)
yy = (y \ IconSpacingY)
SelectedFileIndex = xx + yy * 5 + 1
RenderFileList (xx), (yy)
FileList.Refresh
  'makeit only popup when over a file
  If (Button And 2) = 2 And SelectedFileIndex <> 0 And SelectedFileIndex <= UBound(FileItem) Then PopupMenu mnuContext
End Sub

Sub LoadFiles()
  Dim File1$, C&
  
  Open App.Path & "\Directory.txt" For Input As #1
     Do While Not EOF(1)
       ReDim Preserve FileItem(UBound(FileItem) + 1)
       Line Input #1, File1
       C = C + 1
       FileItem(C).x = (C - 1) Mod 5
       FileItem(C).y = (C - 1) \ 5
       FileItem(C).Special = Mid(File1, 1, 1)
       File1 = Replace(Mid(File1, 2), "$Path", App.Path, , , vbTextCompare)
       FileItem(C).text = FileNameFromPath(File1)
       FileItem(C).Path = File1
       FileItem(C).Icon = dIcon(Right(File1, 3))
     Loop
  Close #1
End Sub

Private Sub FileList_OLEDragDrop(data As DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)

  If data.Files(1) = "" Then Exit Sub
  C = UBound(FileItem) + 1
  ReDim Preserve FileItem(C)
  FileItem(C).x = (C - 1) Mod 5
  FileItem(C).y = (C - 1) \ 5
  FileItem(C).text = FileNameFromPath(data.Files(1))
  FileItem(C).Path = data.Files(1)
  FileItem(C).Icon = dIcon(Right(data.Files(1), 3))
  FileList.Cls
  RenderFileList
End Sub

Private Sub Form_Load()
   Text1.text = "http://" & Socket1.LocalIP
   ReDim FileItem(0)
   LoadFiles
   
   RenderFileList
   Client(0).LocalPort = 1000
   Client(0).Listen
End Sub

Private Sub Form_Unload(Cancel As Integer)
If Client(0).State = sckListening Then
  Client(0).CloseSck
End If
DoEvents
End
End Sub

Private Sub mnuContextItm_Click(Index As Integer)
If Index = 0 Then Command2_Click 1
If Index > 2 Then mnuSetAsItm_Click Index - 3
End Sub

Private Sub mnuPreviewItm_Click()
Dim wml$, t$
If SelectedFileIndex > UBound(FileItem) Then Exit Sub
Select Case UCase(Right(FileItem(SelectedFileIndex).Path, 3))
 Case "WML"
   Open FileItem(SelectedFileIndex).Path For Input As #1
   Do While Not EOF(1)
     Line Input #1, t
     wml = wml & t & vbCrLf
   Loop
   Close #1
   frmPreview.Show
   frmPreview.Render wml
   frmPreview.Caption = "Preview of " & FileItem(SelectedFileIndex).text
 Case Else
   ShellExecute Me.hwnd, vbNullString, FileItem(SelectedFileIndex).Path, vbNullString, "C:\", SW_SHOWNORMAL
End Select
End Sub

Private Sub mnuSetAsItm_Click(Index As Integer)
For i = 1 To UBound(FileItem)
  If FileItem(i).Special = Index + 1 Then FileItem(i).Special = 0
Next
  FileItem(SelectedFileIndex).Special = Index + 1
End Sub

Private Sub Socket1_Connect()
  Socket1.SendData "GET / HTTP/1.1" & vbCrLf & "Connection: Keep -Alive" & vbCrLf & vbCrLf
End Sub

Private Sub Socket1_DataArrival(ByVal bytesTotal As Long)
  If bytesTotal > 0 Then
    Dim a$
    Socket1.GetData a
    Text1.text = "http://" & Mid(a, InStr(1, a, vbCrLf & vbCrLf) + 4)
  End If
End Sub

Sub SavePostResponce(Responce As String)
  Open App.Path & "\Logs\PostResponce.txt" For Append As #1
     Print #1, Responce
  Close #1
End Sub

Sub SavePostForm(Responce As String)
  Dim t$, a$, z&
  Open App.Path & "\wap site\postings.wml" For Input As #1
     Do While Not EOF(1)
        Line Input #1, t
        a = a & t & vbCrLf
     Loop
  Close #1
  z = InStr(1, a, "<p>" & vbCrLf) + 5
  a = Mid(a, 1, z) & "      " & Responce & "<br/>" & vbCrLf & Mid(a, z + 1)
  a = Mid(a, 1, Len(a) - 2)
  Kill App.Path & "\wap site\postings.wml"
  Open App.Path & "\wap site\postings.wml" For Output As #1
     Print #1, a
  Close #1
End Sub

Function FileNameFromPath(Path As String) As String
   For i = Len(Path) To 1 Step -1
      If Mid(Path, i, 1) = "\" Then
         FileNameFromPath = Mid(Path, i + 1)
         Exit For
      End If
   Next
End Function

'DO URL DECODE
Function UrlDecode(text As String) As String
On Error Resume Next
Dim i&, Out$
Do
i = i + 1
If Mid(text, i, 1) = "%" Then
  Out = Out & Chr(Val("&H" & Mid(text, i + 1, 2) & "&"))
  i = i + 2
Else
  Out = Out & Mid(text, i, 1)
End If
Loop Until i >= Len(text)
UrlDecode = Out
End Function


Function URLEncode(strBefore As String) As String
    Dim strAfter As String
    Dim intLoop As Integer
    If Len(strBefore) > 0 Then
        For intLoop = 1 To Len(strBefore) Step 2
            Select Case Val("&H" & Mid(strBefore, intLoop, 2) & "&")
                Case 48 To 57, 65 To 90, 97 To 122, 46, 45, 95, 42 '0-9, A-Z, a-z . - _ *
                   strAfter = strAfter & Chr(Val("&H" & Mid(strBefore, intLoop, 2) & "&"))
                Case 32
                   strAfter = strAfter & "+"
                Case Else
                   strAfter = strAfter & "%" & Mid(strBefore, intLoop, 2)
            End Select
    Next
End If
URLEncode = strAfter
End Function