📄 frmmain.frm
字号:
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 错误
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -