• GetContent


    Sub GetContent(ByVal URL As String, ByVal SheetName As String)
        Dim strText As String
        Dim i As Long
        Dim OneSpan
        Dim IsContent As Boolean
    
        With CreateObject("MSXML2.XMLHTTP")
            .Open "GET", URL, False
            .Send
            strText = .responsetext
        End With
    
        Dim arr() As String
        ReDim arr(1 To 1) As String
    
        With CreateObject("htmlfile")
            .write strText
            i = 0
            For Each OneSpan In .getElementsByTagName("span")
                s = RegReplace(OneSpan.innerhtml, "<.*?>")
                s = Replace(s, " ", "")
    
                If s = " 排行榜" Then IsContent = False
                If IsContent Then
                    i = i + 1
                    ReDim Preserve arr(1 To i)
                    arr(i) = s
                    'Debug.Print s
                    'If i = 100 Then Exit For
                End If
                If s = "分类:" Then IsContent = True
    
            Next
        End With
    
        Dim brr() As String
        ReDim brr(1 To 1)
    
        brr(1) = arr(1)
        M = 1
        For n = 2 To i
            If RegTest(arr(n - 1), "[A-D].") Or RegTest(arr(n - 1), "^d*?.??$") Then
                brr(M) = brr(M) & arr(n)
            Else
                M = M + 1
                ReDim Preserve brr(1 To M)
                brr(M) = arr(n)
            End If
        Next n
    
        For i = 1 To M
            'Debug.Print brr(i)
            If i = 150 Then Exit For
        Next i
    
    
        Set sht = AddWorksheet(ThisWorkbook, SheetName)
    
        With sht
            .Cells.ClearContents
            .Range("A1:A1").Value = Array("内容")
            .Range("A2").Resize(M, 1).Value = _
            Application.WorksheetFunction.Transpose(brr)
        End With
    
    
    
    
    End Sub
    
    Sub TestRegReplace()
        s = "215MY"
        s = RegReplace(s, "[A-Z]")
        Debug.Print s
    End Sub
    Public Function RegReplace(ByVal OrgText As String, ByVal Pattern As String, Optional RepStr As String = "") As String
    '传递参数 :原字符串, 匹配模式 ,替换字符
        Dim Regex As Object
        Dim newText As String
        Set Regex = CreateObject("VBScript.RegExp")
        With Regex
            .Global = True
            .Pattern = Pattern
        End With
        newText = Regex.Replace(OrgText, RepStr)
        RegReplace = newText
        Set Regex = Nothing
    End Function
    
    Public Function RegTest(ByVal OrgText As String, ByVal Pattern As String) As Boolean
    '传递参数 :原字符串, 匹配模式
        Dim Regex As Object
        Set Regex = CreateObject("VBScript.RegExp")
        With Regex
            .Global = True
            .Pattern = Pattern
        End With
        RegTest = Regex.TEST(OrgText)
        Set Regex = Nothing
    End Function
    
    Sub dd()
        Debug.Print RegTest("13.", "^d+?.$")
    End Sub
    
    Function AddWorksheet(ByVal Wb As Workbook, ByVal ShtName As String, Optional ReplaceSymbol As Boolean = True) As Worksheet
        Dim sht As Worksheet
        If Len(ShtName) = 0 Or Len(ShtName) > 31 Then
            Set AddWorksheet = Nothing
            MsgBox "Worksheet名称长度不符!", vbInformation, "AddWorksheet"
            Exit Function
        Else
            On Error Resume Next
            Set sht = Wb.Worksheets(ShtName)
            If Err.Number = 9 Then
                Set sht = Wb.Worksheets.Add(After:=Wb.Worksheets(Wb.Worksheets.Count))
                Err.Clear
                On Error GoTo 0
                On Error Resume Next
                sht.Name = ShtName
                If Err.Number = 1004 Then
                    Err.Clear
                    On Error GoTo 0
                    If ReplaceSymbol Then
                        arr = Array("/", "", "?", "*", "[", "]")
                        For i = LBound(arr) To UBound(arr)
                            ShtName = Replace(ShtName, arr(i), "")
                        Next i
                        Set AddWorksheet = AddWorksheet(Wb, ShtName)    '再次调用
                    Else
                        Set AddWorksheet = Nothing
                        MsgBox "Worksheet名称含有特殊符号!", vbInformation, "AddWorksheet"
                    End If
                Else
                    Set AddWorksheet = sht
                End If
            ElseIf Err.Number = 0 Then
                Set AddWorksheet = sht
            End If
        End If
    End Function
    

      

  • 相关阅读:
    mysql时间日期的加、减
    IDEA 下的svn检出maven代码
    IDEA中如何显示和关闭工具栏、目录栏
    Idea集成使用SVN教程
    Python PEP8 代码规范常见问题及解决方法
    Word文档中手写签名操作说明
    19.名称空间和作用域
    18.函数的参数
    17.文件处理
    16.字符编码
  • 原文地址:https://www.cnblogs.com/nextseven/p/7291775.html
Copyright © 2020-2023  润新知