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