vb6.0/vba [vb6.0/vba] 네이버 뉴스 xml로 긁어오기
페이지 정보
본문
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 8, 1 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 8, 1 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 String) As 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 String) As 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
- 이전글[vba] 엑셀에서 클립보드(Clipboard) 사용하기 19.10.29
- 다음글[vb6.0/vba] 특정 패턴으로 더하고 빼기(자화자찬) 19.10.20
댓글목록
등록된 댓글이 없습니다.