源码函数分享GetUrlByXmlHttp XMLHTTP方式下载网页

源码函数分享GetUrlByXmlHttp　XMLHTTP方式下载网页

'〓〓〓〓〓〓〓〓〓〓GetUrlByXmlHttp函数相关定义声明等 Start
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function DeleteUrlCacheEntry Lib "Wininet.dll" Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long
'删除缓存中文件
'〓〓〓〓〓〓〓〓〓〓GetUrlByXmlHttp函数相关定义声明等 End
'┏〓〓〓〓〓〓〓〓〓 GetUrlByXmlHttp,start 〓〓〓〓〓〓〓〓〓┓
'［详介］：
'函数注释:
'［简介］：
'XMLHTTP方式下载网页
Function GetUrlByXmlHttp(Url As String, Optional MaxTime As Long = 20000, Optional ShowErr As Boolean = True, Optional KillCache As Boolean = True) As String
   'VB源码，帮你写函数，帮你写代码，帮你写模块，帮你设计软件
   '--需要什么函数或功能，可以联系我。
   '版权所有，请保留作者信息.QQ：1085992075
   '如需商业用途请联系作者
   On Error GoTo Err
   Dim XmlHttp '  As xmlhttp
   If KillCache Then DeleteUrlCacheEntry Url
   Set XmlHttp = CreateObject("Microsoft.XMLHTTP") '//建立对象
   
   With XmlHttp
           .Open "GET", Url, True
           .send
           On Error Resume Next
           Dim Tick As Long
           Dim S As Integer
           Tick = GetTickCount
           While Not S = 200 And GetTickCount - Tick < MaxTime
               DoEvents
               Sleep 1
               S = .Status
           Wend
           
           If GetTickCount - Tick >= MaxTime And S <> 200 Then Exit Function
           GetUrlByXmlHttp = StrConv(.responseBody, vbUnicode)
   End With
   Set XmlHttp = Nothing '//释放
   
   Exit Function
   Err:
   If ShowErr Then MsgBox Err.Description & vbCrLf '获取错误信息，产生错误后，错误信息会放入vb.Err对象
   Err.Clear
End Function
'┗〓〓〓〓〓〓〓〓〓  GetUrlByXmlHttp,end  〓〓〓〓〓〓〓〓〓┛