자료실

부자는 돈을 써서 시간을 아끼지만 가난한 사람은 시간을 써서 돈을 아낀다

vb6.0/vba

IT HUB를 찾아주셔서 감사합니다.

vb6.0/vba [vb6.0/vba] MSXML2.XmlHttp와 MSXML2.DOMDocument 를 이용한 www.kimsonline.co…

페이지 정보

profile_image
작성자 하나를하더라도최선을
댓글 0건 조회 4,254회 작성일 21-01-30 09:34

본문

Sub Test()
    Dim pData As String
    Dim url As String
    Dim sHtml As String
    Dim r As Long
    
    '// https://www.kimsonline.co.kr/drugcenter/search/retotalsearch?Keyword=%EA%B8%80%EB%A6%AC%EB%A9%9C&Page=1
    url = "https://www.kimsonline.co.kr/Function/GetTotalSearch"
    '// Post문자열
    pData = "{""parameters"":[{""Key"":""TotalSearchKeyword"",""Value"":""글리멜""}," & _
        "{""Key"":""MarketStatus"",""Value"":""AS""}, " & _
        "{""Key"":""PageNo"",""Value"":""1""}, " & _
        "{""Key"":""RowCount"",""Value"":""200""}]}"
 
    sHtml = getResponse(url, pData)
    sHtml = Mid(sHtml, 7)  'remove  {"d":"
    sHtml = Left(sHtml, Len(sHtml) - 2)  'remove }"
    'Debug.Print sHtml
    
    Dim xDoc As Object  'New MSXML2.DOMDocument60
    Dim xNodes As Object    'MSXML2.IXMLDOMNodeList
    Dim xNode As Object     'MSXML2.IXMLDOMElement
    
    Set xDoc = CreateObject("MSXML2.DOMDocument")
    xDoc.LoadXML sHtml
    Set xNodes = xDoc.SelectNodes("//DrugList/Item")
  
    Cells.Clear
    Range("A1:C1"= Array("이름""가격""코드")
    r = 1
    For Each xNode In xNodes
        r = r + 1
        '이름
        Cells(r, 1= xNode.getElementsByTagName("ProductNameKr")(0).Text
        '가격
        Cells(r, 2= xNode.getElementsByTagName("NHIPrice")(0).Text
        '코드
        Cells(r, 3).NumberFormat = "@"
        Cells(r, 3= xNode.getElementsByTagName("KDCode")(0).Text
 
    Next xNode
    Cells.Columns.AutoFit
    
    Set xDoc = Nothing
End Sub

'// 서버에 접속해서 Response를 가져옴
Function getResponse(sUrl As String, PostData As String)
    Dim http As Object
    Set http = CreateObject("MSXML2.XmlHttp")
    With http
        .Open "post", sUrl, False
        .setRequestHeader "Accept""application/json, text/javascript, */*; q=0.01"
        .setRequestHeader "Content-Type""application/json; charset=UTF-8"
        .send PostData
        '\u003c: <, \u003e: >, \r\n: vbNewLine
        getResponse = Replace(Replace(Replace(.responseText, "\u003c""<"), "\u003e"">"), "\r\n""")
        '\" => "
        getResponse = Replace(getResponse, "\\""""""")
    End With
    Set http = Nothing
End Function

댓글목록

등록된 댓글이 없습니다.