📄 tcp.bas
字号:
Attribute VB_Name = "Tcp"
Option Explicit
'depend on StringProcess.bas
'Components:
'Microsoft Winsock Control 6.0
Public Const POP3_PORT = 110
Public Const SMTP_PORT = 25
Public Const HTTP_PORT = 80
Public Function CheckEmail(ByVal strEmail As String) As Boolean
If InStr(1, strEmail, "@") > 1 Then
CheckEmail = True
Else
CheckEmail = False
End If
End Function
Public Function ChkHttp(ByVal strHttp As String) As Boolean
If InStr(1, LCase(LTrim(strHttp)), "http://") = 1 Then
ChkHttp = True
Else
ChkHttp = False
End If
End Function
Public Function GetHttpHost(ByVal strHttp As String) As String
Dim strTmp As String
If ChkHttp(strHttp) Then
strTmp = Mid(LTrim(strHttp), 8) + "/"
GetHttpHost = GetNoString(strTmp, "/", 0)
Else
GetHttpHost = ""
End If
End Function
Public Function GetHttpPage(ByVal strHttp As String) As String
Dim strTmp As String
If ChkHttp(strHttp) Then
strTmp = Mid(LTrim(strHttp), 8)
strTmp = NextString(strTmp, "/")
If strTmp = "" Then
GetHttpPage = ""
Exit Function
End If
If InStr(1, strTmp, ".") > 0 Or Mid(strTmp, Len(strTmp), 1) = "/" Or _
InStr(1, strTmp, "?") > 0 Or InStr(1, strTmp, "=") > 0 Then
GetHttpPage = strTmp
Exit Function
End If
GetHttpPage = strTmp + "/"
Else
GetHttpPage = ""
End If
End Function
Public Function GetHttpCommand(ByVal strHttp As String) As String
'It is legal here that HttpHost contains port such as ":8090".
'"Range: bytes=0-500", or 9500-
'"Referer: " + strHttp + vbCrLf
'"User-Agent: " + App.EXEName + vbCrLf
'Accept-Language: zh-cn
'''''''''''''''''''''''''''''This is from IE.'''''''''''''''''''''''''''
'GET /windowsxp/expertzone/focuson/moviemaker.asp HTTP/1.1
'Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, application/vnd.ms-powerpoint, application/vnd.ms-excel, application/msword, */*
'Accept-Language: zh-cn
'Accept -Encoding: gzip , deflate
'User-Agent: Mozilla/4.0 (compatible; MSIE 6.0b; Windows NT 5.0)
'Host: walker:1024
'Connection: Keep-Alive
'Cookie: ASPSESSIONIDQGGGGIDC=BNALFNMAELBABMIHDONIOKPB; ASPSESSIONIDSQSQDRSA=LGABHLIAJEBOICJNKJBEBIGG
'If there is no "HTTP/1.1", then will not receive response head.
'[Server]>GET / HTTP/1.1
'HOST: www.zaobao.com.sg
'Accept: text/html
'Accept -Language: zh -cn
'Range: bytes = 0 - 501
'Connection: Keep -Alive
'
'TickCount:32363586 // Time: 15:43:29
'<[Server]HTTP/1.1 206 Partial Content
'Date: Sun, 01 Jun 2003 07:39:24 GMT
'Server: Apache/1.3.12 (Unix)
'Last-Modified: Sun, 01 Jun 2003 07:35:48 GMT
'ETag: "15809b-d152-3ed9acd4"
'Accept -Ranges: bytes
'Content-Length: 502
'Content -Range: bytes 0 - 501 / 53586
'Keep-Alive: timeout=15, max=100
'Connection: Keep -Alive
'Content-Type: text/html
'
'<html>
'<head>
'<title>早报网 Zaobao.com</title> ......
If ChkHttp(strHttp) Then
GetHttpCommand = "GET /" + GetHttpPage(strHttp) + " HTTP/1.1" + vbCrLf + _
"HOST: " + GetHttpHost(strHttp) + vbCrLf + _
"Accept: text/html" + vbCrLf + _
"Accept-Language: zh-cn" + vbCrLf + _
"Connection: Keep-Alive" + vbCrLf
Else
GetHttpCommand = ""
End If
'HttpCommand must ended with two vbCrLf, here is one, another in [Send].
End Function
Public Function GetWinSockState(tcpSock As Winsock) As String
Dim strTmp As String
On Error Resume Next
Select Case tcpSock.State
Case 0
strTmp = "Closed"
Case 1
strTmp = "Open"
Case 2
strTmp = "Listening"
Case 3
strTmp = "Connection pending"
Case 4
strTmp = "Resolving host"
Case 5
strTmp = "Host resolved"
Case 6
strTmp = "Connecting"
Case 7
strTmp = "Connected"
Case 8
strTmp = "Peer is closing the connection"
Case 9
strTmp = "Error"
End Select
GetWinSockState = strTmp
End Function
Public Function GetMailEnd() As String
GetMailEnd = vbCrLf + "." + vbCrLf
End Function
Public Function GetMailData(strFromHead As String, strFrom As String, strTo As String, strSubject As String, strContent As String) As String
GetMailData = "from: " + Chr(&H22) + strFromHead + Chr(&H22) + " <" + strFrom + ">" + vbCrLf + _
"to: <" + strTo + ">" + vbCrLf + _
"subject: " + strSubject + vbCrLf + _
"MIME-Version: 1.0" + vbCrLf + _
"Content-Type: text/html; charset=gb2312" + vbCrLf + _
"X-Priority: 1" + vbCrLf + _
"X-Mailer: Myself v 1.0" + vbCrLf + _
strContent + vbCrLf + _
GetMailEnd()
End Function
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -