VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.Form frmMain 
   AutoRedraw      =   -1  'True
   Caption         =   "WebServer"
   ClientHeight    =   5250
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   7725
   LinkTopic       =   "Form1"
   ScaleHeight     =   5250
   ScaleWidth      =   7725
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton cmdLoad 
      Caption         =   "重載文件"
      Height          =   495
      Left            =   5640
      TabIndex        =   6
      Top             =   480
      Width           =   1455
   End
   Begin VB.TextBox txtList 
      Height          =   3735
      Left            =   120
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   5
      Top             =   1320
      Width           =   7455
   End
   Begin VB.Timer StateTimer 
      Interval        =   1
      Left            =   720
      Top             =   0
   End
   Begin VB.TextBox txtServerLocalIP 
      Enabled         =   0   'False
      BeginProperty Font 
         Name            =   "宋體"
         Size            =   14.25
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   405
      Left            =   1920
      TabIndex        =   0
      Top             =   480
      Width           =   2520
   End
   Begin MSWinsockLib.Winsock sckTcpIP 
      Left            =   0
      Top             =   0
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
   End
   Begin VB.Label lblAD 
      AutoSize        =   -1  'True
      Caption         =   "點擊這里"
      Height          =   180
      Left            =   480
      TabIndex        =   4
      Top             =   960
      Width           =   720
   End
   Begin VB.Label lblCount 
      AutoSize        =   -1  'True
      Caption         =   "0"
      Height          =   180
      Left            =   3720
      TabIndex        =   3
      Top             =   960
      Width           =   90
   End
   Begin VB.Label SockState 
      AutoSize        =   -1  'True
      Caption         =   "0"
      Height          =   180
      Left            =   2040
      TabIndex        =   2
      Top             =   960
      Width           =   90
   End
   Begin VB.Label lblClientLocalIP 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "WEB服務器IP："
      BeginProperty Font 
         Name            =   "宋體"
         Size            =   12
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   240
      Left            =   300
      TabIndex        =   1
      Top             =   540
      Width           =   1560
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'QQ群：10988210
'老人家
'QQ:1504839
'TEST.C是在ARM的Web Server源文件，現在用VB實現，用來分析TCPIP。

Option Explicit




'用來打開指定網頁或EMAIL的API聲明
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation _
   As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long




Dim strData                         As String   '通信數據
Dim strAppPath                      As String   '當前路徑
Dim tMain                           As tMaster  '結構名
Dim intCount                        As Integer  '次數
Dim strSockState                    As String   'SockState狀態
Dim strPost                         As String   'Post內容




Private Type tMaster
    strHttpTmp                      As String
    bytHttpWeb()                    As Byte
    bytWeb()                        As Byte
    bytHttpGif()                    As Byte
    bytBmp()                        As Byte
End Type








Private Sub cmdLoad_Click()
     Form_Load
End Sub





Private Sub lblAD_Click()
    Dim Ret&
    Ret& = ShellExecute(Me.hWnd, "Open", "http://" & txtServerLocalIP.Text, "", "", 1)
End Sub






Private Sub Form_Load()

    On Error GoTo ErrorEnd

    Dim strIn           As String
    Dim strInTXT        As String
    Dim intLocFont      As Integer
    Dim intLocBack      As Integer
    Dim strTemp         As String
    Dim strTempCu       As String
    Dim l As Long
    
    strPost = ""
    strAppPath = App.Path
    If Right$(strAppPath, 1) <> "\" Then strAppPath = strAppPath & "\"
    
    
    Open strAppPath & "test.c" For Input As #1
        Do Until EOF(1)
            Line Input #1, strIn
            strIn = Trim(strIn)
            strIn = VBA.Replace(strIn, vbTab, "")
            If InStr(strIn, "//") <> 1 Then
                If Left(strIn, 1) = """" Then strIn = Right(strIn, Len(strIn) - 1)
                strInTXT = strInTXT & VBA.Replace(strIn, "\r\n""", vbCrLf)
            Else
                Print
            End If
        Loop
    Close
    
    strInTXT = VBA.Replace(strInTXT, "\""", """")
    
    intLocFont = InStr(1, strInTXT, "uint8 httpweb[]={")
    intLocFont = InStr(intLocFont, strInTXT, "{")
    intLocBack = InStr(intLocFont, strInTXT, "}")
    tMain.strHttpTmp = Mid(strInTXT, intLocFont + 1, intLocBack - intLocFont - 1)
    Debug.Print "bytHttpGif" & vbCrLf & tMain.strHttpTmp
    tMain.bytHttpWeb = subStrToByt(tMain.strHttpTmp)
    
    intLocFont = InStr(intLocBack, strInTXT, "uint8 web[]={")
    intLocFont = InStr(intLocFont, strInTXT, "{")
    intLocBack = InStr(intLocFont, strInTXT, "}")
    tMain.strHttpTmp = Mid(strInTXT, intLocFont + 1, intLocBack - intLocFont - 1)
    Debug.Print "bytHttpGif" & vbCrLf & tMain.strHttpTmp
    tMain.bytWeb = subStrToByt(tMain.strHttpTmp)
    
    intLocFont = InStr(intLocBack, strInTXT, "uint8 httpgif[]")
    intLocFont = InStr(intLocFont, strInTXT, "{")
    intLocBack = InStr(intLocFont, strInTXT, "}")
    tMain.strHttpTmp = Mid(strInTXT, intLocFont + 1, intLocBack - intLocFont - 1)
    Debug.Print "bytHttpGif" & vbCrLf & tMain.strHttpTmp
    tMain.bytHttpWeb = subStrToByt(tMain.strHttpTmp)
    
    intLocFont = InStr(intLocBack, strInTXT, "uint8 bmp[")
    intLocFont = InStr(intLocFont, strInTXT, "{")
    intLocBack = InStr(intLocFont, strInTXT, "}")
    
    strTempCu = Mid(strInTXT, intLocFont + 1, intLocBack - intLocFont - 1)
    strTempCu = VBA.Replace(strTempCu, "0x", "&H")
    strTempCu = VBA.Replace(strTempCu, "0X", "&H")
    strTempCu = VBA.Replace(strTempCu, vbCrLf, "")
    strTempCu = strTempCu & ","

    ReDim tMain.bytBmp(Len(strTempCu) / 5) As Byte
    Do While InStr(strTempCu, "&H") > 0
        tMain.bytBmp(l) = Val(Mid(strTempCu, 1, 4))
        l = l + 1
        strTempCu = Right(strTempCu, Len(strTempCu) - 5)
    Loop
    
    subConnection
    
    Exit Sub

ErrorEnd:
    MsgBox Error, vbOKOnly, "test.c"
    End
   
End Sub






Private Sub lblCount_Click()
    lblCount = 0
    intCount = 0
    txtList = ""
End Sub

Private Sub sckTcpIP_Close()                   '#5100 對象關閉
    subConnection
    DoEvents
End Sub







Private Sub sckTcpIP_ConnectionRequest(ByVal requestID As Long)
    '檢查控件的 State 屬性是否為關閉的。                        '#5200 有新連接
    '如果不是，在接受新的連接之前先關閉此連接。
    If sckTcpIP.state <> sckClosed Then sckTcpIP.Close
    '接受具有 requestID 參數的連接。
    sckTcpIP.Accept requestID
    
    intCount = intCount + 1
    Me.lblCount.Caption = intCount
End Sub







Private Sub sckTcpIP_DataArrival(ByVal bytesTotal As Long)
    '為進入的數據聲明一個變量。                                 '#5300 收數據
    '調用 GetData 方法，并將數據賦予名為 txtOutput的 TextBox 的 Text 屬性。
    sckTcpIP.GetData strData
    
    subCasePack (strData)
    
    subConnection

End Sub






Sub subCasePack(strText As String)  'GET、HEAD、POST、DELETE、OPTIONS、TRACE、PUT
    
    txtList.Text = txtList.Text & "第" & intCount & "次:" & GetWinsockState(frmMain.sckTcpIP.state) & vbCrLf & strText & vbCrLf & vbCrLf
    
    Select Case Left(strText, 3)
        
        Case "GET"      'GET 請求指定的文檔
            
            Select Case UCase(funGetTxtPack(strText))
                Case ""
                    Call subSendData(tMain.bytHttpWeb)
                    Call subSendData(tMain.bytWeb)
                
                Case UCase("100.bmp")                                '這只是簡單判斷    '題
                    'Call subSendData(tMain.bytHttpGif)
                    Call subSendData(tMain.bytBmp)
                
                Case Else
                    '
                
            End Select
                        
        Case "HEA"      'HEAD 僅請求文檔頭
            txtList.Text = txtList.Text & "HEAD" & vbCrLf & vbCrLf    '題
            
        Case "POS"      'POST 請求服務器接收指定文檔作為可執行的信息
            If InStr(strText, "S1=zlg&B1=%CC%E1%BD%BB") > 0 Then     '這只是簡單判斷  輸入:zlg再提交,看看有什么結果?  '題
                'Call subSendData(tMain.bytHttpGif)
                Call subSendData(tMain.bytBmp)
            
            Else
                Call subSendData(tMain.bytHttpWeb)
                Call subSendData(tMain.bytWeb)
            End If
            
        Case "DEL"      'DELETE 請求服務器刪除指定頁面
            txtList.Text = txtList.Text & "DELETE" & vbCrLf & vbCrLf    '題
        
        Case "OPT"      'OPTIONS 允許客戶端查看服務器的性能
            txtList.Text = txtList.Text & "OPTIONS 允許客戶端查看服務器的性能" & vbCrLf & vbCrLf    '題
        
        Case "TRA"      'TRACE 用于測試—允許客戶端查看消息回收過程
            txtList.Text = txtList.Text & "TRACE 用于測試—允許客戶端查看消息回收過程" & vbCrLf & vbCrLf    '題
        
        Case "PUT"      'PUT 用從客戶端傳送的數據取代指定文檔中的內容
            txtList.Text = txtList.Text & "PUT 用從客戶端傳送的數據取代指定文檔中的內容" & vbCrLf & vbCrLf    '題
        
        Case Else
            txtList.Text = txtList.Text & "Else" & vbCrLf & vbCrLf    '題
    
    End Select
    
    txtList.SelStart = Len(txtList.Text)

End Sub





Private Sub sckTcpIP_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)               '#5400 出錯處理
    frmMain.Cls
    Print Number & " " & Description & " " & Scode
End Sub





Sub DelayMs(Ms As Long)
    Dim iTimer
    iTimer = Timer * 1000
    Do While (Timer * 1000 - iTimer < 100)
        DoEvents
    Loop
End Sub




Sub subConnection()                       '#2300 連接
    If sckTcpIP.state <> sckClosed Then sckTcpIP.Close
    sckTcpIP.LocalPort = 80
    sckTcpIP.Listen
    txtServerLocalIP = sckTcpIP.LocalIP
    DelayMs (2)
End Sub




Sub subSendData(ParamArray bytArrar())    '#2400 發送數據
    Dim iFor            As Integer
    Dim sTxt            As String
    
    If IsEmpty(bytArrar(0)) Then Exit Sub

    If sckTcpIP.state <> sckClosed Then
        sckTcpIP.SendData bytArrar(0)
        
        For iFor = 0 To UBound(bytArrar())
            sTxt = sTxt & Chr(bytArrar(0)(iFor))
        Next
        
        txtList = txtList & vbCrLf & "發送數據" & vbCrLf & sTxt & vbCrLf
    Else
        Print
    End If
    DelayMs (20)
End Sub






Private Sub StateTimer_Timer()
    
    strSockState = GetWinsockState(frmMain.sckTcpIP.state)
    If frmMain.SockState.Caption <> strSockState Then frmMain.SockState.Caption = strSockState

End Sub



'sckClosed             0 缺省的。關閉
'sckOpen               1 打開
'sckListening          2 偵聽
'sckConnectionPending  3 連接掛起
'sckResolvingHost      4 識別主機
'sckHostResolved       5 已識別主機
'sckConnecting         6 正在連接
'sckConnected          7 已連接
'sckClosing            8 同級人員正在關閉連接
'sckError              9 錯誤