• 쇼핑몰
  • 커뮤니티
  • 북마크

vb6.0/vba




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

하나를하더라도최선을
2021.01.30 09:34 93 0

본문



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


댓글목록 0

등록된 댓글이 없습니다.