ServerXMLHTTP2009

ClsServerXMLHTTP2009类

Option Explicit
Public Enum EN_STATUS
EN_STOP
EN_SEND
End Enum
Public Enum EN_SENDMETHOD
EN_GET = 0
EN_POST = 1
End Enum
Public Event Complete(bolOk As Boolean) '完成事件
Private NET As ServerXMLHTTP40
Private WithEvents Timer As ClsTimer
Private priEnCoding As String '网站编码
Private priErrInfo As String  '错误信息
Private priStatus As EN_STATUS  '对象状态

Private priHtmlCode As String '返回的html源代码
Private priCookies As String '返回的Cookies

Private Sub Class_Initialize()
Set Timer = New ClsTimer
Timer.TimeEnabled = False
Timer.Interval = 5000  '默认超时为5000毫秒
Me.EnCoding = "gb2312"  '默认网页编码为gb2312
End Sub
Private Sub Class_Terminate()
Set Timer = Nothing
End Sub

'设置超时
Public Property Get TimeOut() As Integer
TimeOut = Timer.Interval
End Property
Public Property Let TimeOut(ByVal vNewValue As Integer)
Timer.Interval = vNewValue
End Property

'网站编码格式
Public Property Get EnCoding() As String
EnCoding = priEnCoding
End Property
Public Property Let EnCoding(ByVal vNewValue As String)
priEnCoding = vNewValue
End Property

'发送数据
Public Function SendData(URL As String, _
Optional SendMethod As EN_SENDMETHOD = EN_GET, _
Optional PostData As String = vbNullString, _
Optional RefUrl As String = vbNullString, _
Optional Cookie As String = vbNullString) As Boolean
'URL:目标URL
'SendMethod:发送模式GET还是POST
'PostData:如果是POST模式发送,这个参数为需要POST的数据
'RefUrl:引用URL
'Cookie:Cookie
'返回值:发送成功返回True,否则返回false

On Error GoTo SilenceErr
If priStatus <> EN_STOP Then
Err.Raise 455412423, , "HtmlSourceCode在发送过程中请误再次发送,请先使用Abort方法进止"
Exit Function
End If
Set NET = New ServerXMLHTTP40

Call NET.Open(IIf(SendMethod = EN_POST, "POST", "GET"), URL, True) '异步操作

If RefUrl <> vbNullString Then
Call NET.setRequestHeader("Referer", RefUrl)
End If

Call NET.setRequestHeader("Accept", "image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, application/QVOD, application/x-shockwave-flash, application/vnd.ms-excel, application/vnd.ms-powerpoint, application/msword, */*")

If Cookie <> vbNullString Then
Call NET.setRequestHeader("Cookie", Cookie)
End If
NET.onreadystatechange = Me

If SendMethod = EN_POST Then
Call NET.setRequestHeader("Content-Type", "application/x-www-form-urlencoded")
NET.send PostData
Else
NET.send
End If

Timer.TimeEnabled = True
priStatus = EN_SEND
SendData = True
Exit Function
SilenceErr:
priErrInfo = Err.Description
End Function

'ServerXMLHTTP组件状态变化
'该公用方法仅供ServerXMLHTTP对象调用/请勿进行外部调用
Public Sub StatusChang()
If priStatus = EN_STOP Then Exit Sub      '如果当前是停止状态则退出
On Error GoTo SilenceErr

If NET.readyState = 4 Then    '发送完成
If NET.Status = 200 Then  'http响应代码为200　请求ok
priCookies = NET.getResponseHeader("Cookie") & _
";" & NET.getResponseHeader("Set-Cookie") '取出Cookie
If BytesToBstr(NET.responseBody, priEnCoding) Then '进行编码转换
RaiseEvent Complete(True)
Else
RaiseEvent Complete(False)
End If
Else
priErrInfo = "服务器响应代码:" & NET.Status
RaiseEvent Complete(False)
End If
Me.Abort  '中止一切活动对象
End If

Exit Sub
SilenceErr:
priErrInfo = Err.Description
Err.Number = 0
Err.Clear
End Sub

'连接超时了
Private Sub Timer_Timer()
Me.Abort
priErrInfo = "连接超时"
RaiseEvent Complete(False)
End Sub

'中止一切活动对象
Public Sub Abort()
NET.Abort
priStatus = EN_STOP
Set NET = Nothing
Timer.TimeEnabled = False
End Sub

'编码转换
Private Function BytesToBstr(strBody, CodeBase As String) As Boolean
On Error GoTo SilenceErr

Dim objStream As Stream
Set objStream = New Stream

objStream.Type = StreamTypeEnum.adTypeBinary '设置输入类型为二进制
objStream.Mode = ConnectModeEnum.adModeReadWrite  '读写模式
objStream.Open  '打开流对象
objStream.Write strBody    '输入数据到Stream
objStream.Position = 0      '定位）
objStream.Type = StreamTypeEnum.adTypeText    '输出类型为文本
objStream.Charset = CodeBase                  '输出编码
priHtmlCode = objStream.ReadText              '读出转换后的文本
objStream.Close  '关闭流对象

Set objStream = Nothing
BytesToBstr = True
Exit Function
SilenceErr:
priErrInfo = Err.Description
Err.Clear
Err.Number = 0
End Function

'取得最后一个错误信息
Public Function getLastError() As String
getLastError = priErrInfo
End Function
'取得Cookies
Public Function getCookies() As String
getCookies = priCookies
End Function
'取得网页源代码
Public Function getSourceCode() As String
getSourceCode = priHtmlCode
End Function

ClsTimer类

Option Explicit
Private WithEvents frmTime As frmTimer
Event Timer()
Public Property Get TimeEnabled() As Boolean
TimeEnabled = frmTime.Timer1.Enabled
End Property
Public Property Let TimeEnabled(ByVal vNewValue As Boolean)
frmTime.Timer1.Enabled = vNewValue
End Property
Public Property Get Interval() As Long
Interval = frmTime.Timer1.Interval
End Property
Public Property Let Interval(ByVal vNewValue As Long)
frmTime.Timer1.Interval = vNewValue
End Property

Private Sub Class_Initialize()
Set frmTime = New frmTimer
frmTime.Timer1.Enabled = False
End Sub

Private Sub frmTime_Timer()
RaiseEvent Timer
End Sub

frmTimer窗口

Option Explicit
Event Timer()

Private Sub Timer1_Timer()
RaiseEvent Timer
End Sub

对ServerXMLHTTP的封装,异步方法,支持超时,Cookie,PostData,引用页,请求类型等设置,网页编码转换,

不过超时设置使用的方法比较WS用窗口中的Timer实现的,

我的目标,稳定第一.. 嘿嘿... 就让他WS去

下载演示地址:http://download.csdn.net/source/1393610