clsnetget.cls

来自「本书源码主要针对目前流行的FTP、HTTP、E-mail、Telnet、ICMP」· CLS 代码 · 共 326 行

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "ClsNetGet"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'打开并初始化Internet连接
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" _
        (ByVal lpszAgent As String, ByVal dwAccessType As Long, ByVal lpszProxyName As String, _
         ByVal lpszProxyBypass As String, ByVal dwFlags As Long) As Long

'关闭Internet连接或URL句柄
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer

'打开一个URL，获得句柄
Private Declare Function InternetOpenUrl Lib "wininet.dll" Alias "InternetOpenUrlA" _
        (ByVal hInternetSession As Long, ByVal lpszUrl As String, ByVal lpszHeaders As String, _
         ByVal dwHeadersLength As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long

'从打开的URL中读取数据(用于读取文本文件）
Private Declare Function InternetReadHtml Lib "wininet.dll" Alias "InternetReadFile" _
        (ByVal hFile As Long, ByVal lpBuffer As String, ByVal dwNumberOfBytesToRead As Long, _
         lNumberOfBytesRead As Long) As Integer
'从打开的URL中读取数据(用于读取二进制文件）
Private Declare Function InternetReadImg Lib "wininet.dll" Alias "InternetReadFile" _
        (ByVal hFile As Long, lpBuffer As Any, ByVal dwNumberOfBytesToRead As Long, _
         lNumberOfBytesRead As Long) As Integer

Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0   '使用缺省的配置
Private Const INTERNET_FLAG_EXISITING_CONNECT = &H20000000
Private Const INTERNET_FLAG_RELOAD = &H80000000  '不从Cache中下载
Private Const scBlankStr = ""                    '空字符串常量

Private hInternetSession    As Long     ' Internet会话句柄
Private bInitialized        As Boolean  ' 标志是否已经初始化
Private hUrlFile            As Long     ' 打开的Url句柄
Private sContents           As String   ' html页面文本内容
Private sLastError          As String   ' 最近一次错误
Private sStatus             As String   ' 存放状态字符串的变量
Private objWindow           As Object   ' 显示状态字符串的窗口
Private sUserAgent          As String   ' 在HTTP协议中的UserAgent

'根据错误设置描述错误的变量
Sub CheckError()
Dim lLastErrorNo As Long
lLastErrorNo = Err.LastDllError
If lLastErrorNo > 0 Then sLastError = TranslateErrorCode(lLastErrorNo)
End Sub

'初始化过程，用于打开Internet会话及设置变量
Public Sub Init(Optional vInUserAgent As Variant)
On Error Resume Next
If IsMissing(vInUserAgent) Then
    sUserAgent = App.EXEName
Else
    sUserAgent = vInUserAgent
End If
Term
hUrlFile = 0
sContents = scBlankStr
sLastError = scBlankStr
sStatus = scBlankStr
'打开Internet连接
hInternetSession = InternetOpen(sUserAgent, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
bInitialized = CBool(hInternetSession)
End Sub

'分析Html文本，从中提取有用的文件链接
Public Function ParseHTML(ByVal sToken As String, colItems As Collection) As Boolean
Dim lPosInStr As Long
Dim lEndPosInStr1, lEndPosInStr2 As Long
Dim lStartPos As Long
Dim sAddItem As String
On Error Resume Next
'设置鼠标状态为等待
Screen.MousePointer = vbHourglass
SetStatus "分析Html页面开始..."
sContents = Replace(sContents, vbCrLf, "")
If Len(sContents) > Len(sToken) Then
    lStartPos = 1
    '查找字符串中的链接起始标志字符串sToken
    lPosInStr = InStr(lStartPos, sContents, sToken, vbTextCompare)
    '如果起始标志字符串找到
    While lPosInStr > 0
        DoEvents: DoEvents
        lPosInStr = lPosInStr + Len(sToken)
        '查找链接的结束位置
        If Mid(sContents, lPosInStr, 1) = """" Then
            lPosInStr = lPosInStr + 1
            lEndPosInStr1 = InStr(lPosInStr, sContents, """", vbTextCompare)
        ElseIf lEndPosInStr1 = 0 Then
            lEndPosInStr1 = InStr(lPosInStr, sContents, " ", vbTextCompare)
        Else
            lEndPosInStr1 = InStr(lPosInStr, sContents, ">", vbTextCompare)
        End If
        '得到链接字符串
        sAddItem = Mid(sContents, lPosInStr, lEndPosInStr1 - lPosInStr)
        '检查链接字符串
        lEndPosInStr1 = InStr(1, sAddItem, " ", vbTextCompare)
        lEndPosInStr2 = InStr(1, sAddItem, ">", vbTextCompare)
        If lEndPosInStr1 > 0 Or lEndPosInStr2 > 0 Then
            If lEndPosInStr1 > lEndPosInStr2 Then
                sAddItem = Mid(sAddItem, 1, lEndPosInStr1 - 1)
            Else
                sAddItem = Mid(sAddItem, 1, lEndPosInStr2 - 1)
            End If
        End If
        '将链接加入到集合中
        If Len(sAddItem) Then colItems.Add sAddItem, sAddItem
        lStartPos = lPosInStr + Len(sAddItem)
        lPosInStr = InStr(lStartPos, sContents, sToken, vbTextCompare)
    Wend
    ParseHTML = True
End If
SetStatus "分析Html页面结束"
'恢复鼠标状态为缺省
Screen.MousePointer = vbDefault
End Function


'从给定的Url取得html文件的内容。并保存在字符串sContents和指定的文件中
Public Function ReadUrlHtml(ByVal sUrl As String, Optional vFileName As Variant) As Boolean
Dim sReadBuffer As String * 2048        ' 为InternetReadFile函数提供字符串作为数据接收缓冲区
Dim lNumberOfBytesRead  As Long         ' 调用InternetReadFile函数读取的字节数
Dim lTotalBytesRead     As Long         ' 一共读取的字节数
Dim bDoLoop             As Boolean      ' 调用InternetReadFile的返回值
Dim i                   As Integer
On Error GoTo errReadUrl
'设置鼠标状态为等待
Screen.MousePointer = vbHourglass
SetStatus "下载开始: " & sUrl
'打开url下载
hUrlFile = InternetOpenUrl(hInternetSession, sUrl, vbNullString, 0, INTERNET_FLAG_EXISITING_CONNECT, 0)
If CBool(hUrlFile) Then
    sContents = scBlankStr
    bDoLoop = True
    While bDoLoop
        sReadBuffer = scBlankStr
        '从打开的InternetOpenUrl句柄中读取文件数据
        bDoLoop = InternetReadHtml(hUrlFile, sReadBuffer, Len(sReadBuffer), lNumberOfBytesRead)
        If Not CBool(bDoLoop) Then CheckError
        lTotalBytesRead = lTotalBytesRead + lNumberOfBytesRead
        SetStatus "读取" & CStr(lTotalBytesRead) & "字节：" & sUrl
        If CBool(lNumberOfBytesRead) Then
            '将读取的数据保存到变量sContents中，分析链接时要使用
            sContents = sContents & Left$(sReadBuffer, lNumberOfBytesRead)
        Else
            bDoLoop = False
        End If
    Wend
    '关闭InternetOpenUrl打开的句柄
    InternetCloseHandle (hUrlFile)
    '将读取的数据存到指定的文件中
    If Len(sContents) > 0 Then
        Dim iFileNum As Integer
        iFileNum = FreeFile
        Open CStr(vFileName) For Binary As iFileNum
        Put #iFileNum, , sContents
        Close (iFileNum)
        ReadUrlHtml = True
    Else
        ReadUrlHtml = False
    End If
Else
    CheckError
End If
SetStatus "下载完毕：" & sUrl
'设置鼠标为缺省状态
Screen.MousePointer = vbDefault
Exit Function
errReadUrl:
sLastError = Error$(Err)
Screen.MousePointer = vbDefault
Exit Function
End Function


'从给定的Url取得二进制文件的内容。并保存到指定的文件
Public Function ReadUrlImg(ByVal sUrl As String, Optional vFileName As Variant) As Boolean
Dim sReadBuffer(2048)   As Byte         '为InternetReadFile函数提供字符串作为数据接收缓冲区
Dim lNumberOfBytesRead  As Long         '调用InternetReadFile函数读取的字节数
Dim lTotalBytesRead     As Long         '一共读取的字节数
Dim bDoLoop             As Boolean      '调用InternetReadFile的返回值
Dim i                   As Integer
On Error GoTo errReadUrl
Screen.MousePointer = vbHourglass
SetStatus "下载开始: " & sUrl
If IsMissing(vFileName) Then
    ReadUrlImg = False
    Exit Function
End If
'打开url下载
hUrlFile = InternetOpenUrl(hInternetSession, sUrl, vbNullString, 0, INTERNET_FLAG_EXISITING_CONNECT, 0)
If CBool(hUrlFile) Then
    sContents = scBlankStr
    bDoLoop = True
    Dim iFileNum As Integer
    While bDoLoop
        '从打开的InternetOpenUrl句柄中读取文件数据
        bDoLoop = InternetReadImg(hUrlFile, sReadBuffer(0), 2048, lNumberOfBytesRead)
        If Not CBool(bDoLoop) Then CheckError
        lTotalBytesRead = lTotalBytesRead + lNumberOfBytesRead
        SetStatus "读取" & CStr(lTotalBytesRead) & "字节：" & sUrl
        If CBool(lNumberOfBytesRead) Then
            '读取的数据存到指定的文件中
            If iFileNum = 0 Then
                iFileNum = FreeFile
                Open CStr(vFileName) For Binary As iFileNum
            End If
            For i = 0 To lNumberOfBytesRead - 1
                Put #iFileNum, , sReadBuffer(i)
            Next i
        Else
            bDoLoop = False
        End If
    Wend
    '关闭InternetOpenUrl打开的句柄
    InternetCloseHandle (hUrlFile)
    If iFileNum <> 0 Then
        Close (iFileNum)
        ReadUrlImg = True
    Else
        ReadUrlImg = False
    End If
Else
    CheckError
End If
SetStatus "下载完毕：" & sUrl
'设置鼠标为缺省状态
Screen.MousePointer = vbDefault
Exit Function
errReadUrl:
sLastError = Error$(Err)
Screen.MousePointer = vbDefault
Exit Function
End Function

'根据下载的状态设置窗口的文字
Private Sub SetStatus(sInStatus As String)
On Error Resume Next
objWindow = sInStatus
DoEvents
End Sub

'结束程序所做的一些处理，释放资源
Public Sub Term()
On Error Resume Next
If InternetCloseHandle(hInternetSession) Then
    bInitialized = False
    SetStatus ("Ready")
Else
    CheckError
End If
End Sub

'解释错误码
Function TranslateErrorCode(ByVal lErrorCode As Long) As String
Select Case lErrorCode
    Case 12001: TranslateErrorCode = "No more handles could be generated at this time"
    Case 12002: TranslateErrorCode = "The request has timed out."
    Case 12003: TranslateErrorCode = "An extended error was returned from the server."
    Case 12004: TranslateErrorCode = "An internal error has occurred."
    Case 12005: TranslateErrorCode = "The URL is invalid."
    Case 12006: TranslateErrorCode = "The URL scheme could not be recognized, or is not supported."
    Case 12007: TranslateErrorCode = "The server name could not be resolved."
    Case 12008: TranslateErrorCode = "The requested protocol could not be located."
    Case 12009: TranslateErrorCode = "A request to InternetQueryOption or InternetSetOption specified an invalid option value."
    Case 12010: TranslateErrorCode = "The length of an option supplied to InternetQueryOption or InternetSetOption is incorrect for the type of option specified."
    Case 12011: TranslateErrorCode = "The request option can not be set, only queried. "
    Case 12012: TranslateErrorCode = "The Win32 Internet support is being shutdown or unloaded."
    Case 12013: TranslateErrorCode = "The request to connect and login to an FTP server could not be completed because the supplied user name is incorrect."
    Case 12014: TranslateErrorCode = "The request to connect and login to an FTP server could not be completed because the supplied password is incorrect. "
    Case 12015: TranslateErrorCode = "The request to connect to and login to an FTP server failed."
    Case 12016: TranslateErrorCode = "The requested operation is invalid. "
    Case 12017: TranslateErrorCode = "The operation was canceled, usually because the handle on which the request was operating was closed before the operation completed."
    Case 12018: TranslateErrorCode = "The type of handle supplied is incorrect for this operation."
    Case 12019: TranslateErrorCode = "The requested operation can not be carried out because the handle supplied is not in the correct state."
    Case 12020: TranslateErrorCode = "The request can not be made via a proxy."
    Case 12021: TranslateErrorCode = "A required registry value could not be located. "
    Case 12022: TranslateErrorCode = "A required registry value was located but is an incorrect type or has an invalid value."
    Case 12023: TranslateErrorCode = "Direct network access cannot be made at this time. "
    Case 12024: TranslateErrorCode = "An asynchronous request could not be made because a zero context value was supplied."
    Case 12025: TranslateErrorCode = "An asynchronous request could not be made because a callback function has not been set."
    Case 12026: TranslateErrorCode = "The required operation could not be completed because one or more requests are pending."
    Case 12027: TranslateErrorCode = "The format of the request is invalid."
    Case 12028: TranslateErrorCode = "The requested item could not be located."
    Case 12029: TranslateErrorCode = "The attempt to connect to the server failed."
    Case 12030: TranslateErrorCode = "The connection with the server has been terminated."
    Case 12031: TranslateErrorCode = "The connection with the server has been reset."
    Case 12036: TranslateErrorCode = "The request failed because the handle already exists."
    Case Else: TranslateErrorCode = "Error details not available."
End Select
End Function

'设置用于显示描述信息的窗口
Property Let SetStatusWindow(objStatusWindow As Object)
On Error Resume Next
Set objWindow = objStatusWindow
End Property

'获得最近的一次错误信息
Property Get GetLastError() As String
GetLastError = sLastError
End Property

'设置程序名（在InternetOpen函数中使用）
Property Let SetUserAgent(sInUserAgent As String)
If Len(sInUserAgent) > 0 Then sUserAgent = sInUserAgent
End Property

'类对象使用结束
Private Sub Class_Terminate()
Term
End Sub