[vb6.0/vba] 네이버 뉴스 xml로 긁어오기 > vb6.0/vba

본문 바로가기

vb6.0/vba

[vb6.0/vba] [vb6.0/vba] 네이버 뉴스 xml로 긁어오기

회원사진
하나를하더라도최선을
2019-10-24 21:45 5,609 0

본문





Sub program1472()
    Dim P As Integer, Cookie As String
    Dim T As String, B() As Byte, XDoc As Object, DOM As Object
    Dim x As New Collection
    Const URL As String = "" & _
    "query={0}&" & _
    "nso=so:r,p:from{1}to{2},a:all&" & _
    "start={3}&"
 
    Const S As Integer = 1  '// 시작 페이지
    Const E As Integer = 5  '// 종료 페이지
    Const query As String = "건조기"    '// 검색어
    Const SD As Date = "2019-01-01" '// 거색 시작일
    Const ED As Date = "2019-05-19" '// 검색 종료일
    Dim V As Variant, i As Integer
    Cookie = ""
    Cells.Clear
    
    Set XDoc = CreateObject("MSXML2.DOMDocument")
    For P = S To E
    '// Debug.Print String_Format(URL, ENCODEURL(query), Format(SD, "yyyymmdd"), Format(ED, "yyyymmdd"), (P - 1) * 10 + 1)
        With CreateObject("WinHttp.WinHttpRequest.5.1")
            .Open "GET", String_Format(URL, ENCODEURL(query), Format(SD, "yyyymmdd"), Format(ED, "yyyymmdd"), (P - 1* 10 + 1)
            .setRequestHeader "Host""newssearch.naver.com"
            .setRequestHeader "User-Agent""Mozilla/5.0 (Windows NT 10.0; WOW64; rv:56.0) Gecko/20100101 Firefox/56.0"
            .setRequestHeader "Accept""text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8"
            .setRequestHeader "Accept-Language""ko-KR,ko;q=0.8,en-US;q=0.5,en;q=0.3"
            .setRequestHeader "Connection""keep-alive"
 
            If Len(Cookie) Then .setRequestHeader "Cookie", Cookie
            .setRequestHeader "Upgrade-Insecure-Requests""1"
            .send
            .waitForResponse: DoEvents
            B = .responseBody
            T = UTF82(B, "utf-8")
        End With
 
        XDoc.LoadXML T
        ReDim V(1 To 81 To XDoc.SelectNodes("//rss/channel/item").Length)
        i = 0
        On Error Resume Next
        For Each DOM In XDoc.SelectNodes("//rss/channel/item")
            If xAdd(x, DOM.SelectSingleNode("link").Text) Then
                i = i + 1
                ReDim Preserve V(1 To 81 To i)
                V(1, i) = query
                V(2, i) = DOM.SelectSingleNode("title").Text
                V(3, i) = DOM.SelectSingleNode("link").Text
                V(4, i) = DOM.SelectSingleNode("description").Text
                V(5, i) = DOM.SelectSingleNode("pubDate").Text
                If Len(V(5, i)) Then V(5, i) = getXtime(CStr(V(5, i)))
                V(6, i) = DOM.SelectSingleNode("author").Text
                V(7, i) = DOM.SelectSingleNode("category").Text
                V(8, i) = DOM.SelectSingleNode("media:thumbnail").XML
                If Len(V(8, i)) Then V(8, i) = Split(Split(V(8, i), "url=")(1), """")(1)
            End If
        Next
        Cells(Rows.Count, "A").End(3)(2).Resize(UBound(V, 2), UBound(V, 1)).value = Application.Transpose(V)
    Next
End Sub
 
Function String_Format(ByVal str As String, ParamArray strArray() As Variant) As String
    Dim i As Integer
    For i = 0 To UBound(strArray)
        str = Replace(str, Join(Array("{", i, "}"), vbNullString), strArray(i))
    Next
    String_Format = str
End Function
 
Function xAdd(ByRef x As Collection, ByVal value As StringAs Boolean
    On Error GoTo ErrPass
    x.Add value, value
    xAdd = True
ErrPass:
End Function
 
Public Function UTF82(ByRef data() As Byte, ByVal Charset As Variant) As String
    On Error GoTo ErrPass
    With CreateObject("ADODB.Stream")
        .Charset = Charset
        .Mode = 3
        .Type = 1
        .Open
        .Write data
        .flush
        .Position = 0
        .Type = 2
        UTF82 = .ReadText
        .Close
    End With
    Exit Function
ErrPass:
    UTF82 = ""
End Function
 
'XML 시간을 일반 시간으로 변환
Function getXtime(xstr As StringAs String
 
    Dim str As String
    str = Mid(xstr, InStr(xstr, " "+ 1)
    str = Left(str, InStrRev(str, " "- 1)
    getXtime = str
 
End Function
 
'검색어 인코딩 손상 방지
Function ENCODEURL(varText As Variant, Optional blnEncode = True)
    Static objHtmlfile As Object
    If objHtmlfile Is Nothing Then
        Set objHtmlfile = CreateObject("htmlfile")
        With objHtmlfile.parentWindow
            .execScript "function encode(s) {return encodeURIComponent(s)}""jscript"
        End With
    End If
    If blnEncode Then
        ENCODEURL = objHtmlfile.parentWindow.encode(varText)
    End If
End Function
 


 

댓글목록0

등록된 댓글이 없습니다.
게시판 전체검색