의료기기 검색 크롤링

 

위처럼 의료기기를 검색하는 사이트( https://emedi.mfds.go.kr/portal )의 검색결과를 엑셀로 가져오는 예시입니다.

 

여러가지 항목으로 검색할 수 있는데

일단 명칭(query2)과 업체명(entpName) 으로 검색하는 예시 파일을 만들어 보았습니다.

 

첨부파일 매크로 허용해서 열고

명칭이나 업체명을 입력하고 시작페이지 ~ 마지막 페이지를 입력하고

마우스 우클릭해서 getMed 를 실행합니다.

위와 같이 화면입니다.

​

내부적으로 xmlHttp를 이용해서

https://emedi.mfds.go.kr/search/data/list?chkList=1&nowPageNum=1&tabGubun=1&query2=브러쉬&entpName=신원&chkGroup=GROUP_BY_FIELD_01&pageNum=1&searchYn=true

위와 같은 주소로 get방식으로 접속합니다.

​

nowPageNum이 처음에는 1페이지였다가 2페이지는 10으로 3페이지는 20으로 4페이지는 30으로 바뀌네요.

뒤에 pageNum은 아무 영향이 없네요.

​

검색어는 query2 에 넣어주고

업체명은 entpName 에 넣어서 접속합니다.

​

접속하면 아래와 같은 response를 받아옵니다.

html Table에도 데이터 내용이 들어 있지만

<Script> 안에 아래와 같이 JSON 구조로 데이터가 모두 들어 있습니다.

​

이 데이터를 JasonBag 클래스를 이용해서 파싱해줍니다.

​

- 시작페이지(E1)와 마지막 페이지(G1)를 제한할 수 있는데 마지막 페이지(G1)을 생략하면 끝까지 출력합니다.

- 한글의 경우 문자열이 Escaped 문자열로 오지만 그냥 출력하면 한글로 나옵니다.

- 검색어나 업체명은 encodeURL 처리해서 서버로 넘겨서 검색합니다.

- 페이지마다 1초씩 쉬도록 했습니다.

- 1열은 값이 비어 있는데 항목 번호를 출력하도록 했습니다.

- 열의 개수는 44개로 출력됩니다.

 

사용코드:

 Option Explicit
 
Dim Http As Object  'MSXML2.ServerXMLHTTP60    ' Object
'Dim Html As New MSHTML.HTMLDocument
Dim JSON As New JsonBag, List As New JsonBag
Dim Total&

Sub getMed()

    Dim sht As Worksheet
    Dim query2$, entpName$, url$, page%, pageFrom%, pageTo%, cnt&
    
    Set Http = CreateObject("MSXML2.ServerXMLHttp")
    
    Set sht = ActiveSheet
    sht.Range("A3", sht.Cells(sht.Rows.Count, sht.Columns.Count)).Clear
    
    url = "https://emedi.mfds.go.kr/search/data/list?chkList=1&tabGubun=1&chkGroup=GROUP_BY_FIELD_01&searchYn=true"
    
    pageFrom = [E1]: pageTo = [G1]
    query2 = [B1]: entpName = [D1]
    If Not IsNumeric(pageFrom) Then pageFrom = 1
    If Not IsNumeric(pageTo) Then pageTo = 0
    
    page = pageFrom
    Do
        url = url & "&nowPageNum=" & (page - 1) * 10 & "&pageNum=" & page & _
            "&query2=" & ENCODEURL(query2) & _
            "&entpName=" & ENCODEURL(entpName)
        'Debug.Print url
        
        cnt = cnt + funcGetMed(url)
        If cnt < 0 Then Exit Do Else 'Debug.Print page, ">>", cnt
        Application.Wait Now + TimeSerial(0, 0, 1)
        If cnt >= Total Then Exit Do
        page = page + 1
        If pageTo <> 0 And page > pageTo Then Exit Do
        
    Loop
    
    sht.Columns.AutoFit
    'sht.Columns("H").ColumnWidth = 100
    'sht.Rows.AutoFit
    'Set Html = Nothing
    Set Http = Nothing
    Set JSON = Nothing: Set List = Nothing
    
End Sub

Function funcGetMed(sUrl) As Integer

    Dim sht As Worksheet
    Dim lastRow&, i%, j%, p&
    Dim script$, sTotal$
    
    Set sht = ActiveSheet
     
    'connect
    With Http
        .Open "Get", sUrl, False
        .setRequestHeader "User-Agent", "Mozilla/5.0 (Linux; Android 6.0;) AppleWebKit/537.36 Chrome/120.0.0.0 Mobile Safari/537.36"
        .setRequestHeader "Content-Type", "text/html;charset=UTF-8"     '"application/json"
        .send
        'Html.body.innerHTML = .responseText
        script = .responseText
        'Debug.Print script
    End With
    
    
    'get Total
    sTotal = "id=""totSearchCnt"" value="""
    p = InStr(script, sTotal) + Len(sTotal)
    If p < 1 Then funcGetMed = -1: Debug.Print "json result not found": Exit Function
    sTotal = Mid(script, p, 20)
    sTotal = Left(sTotal, InStr(sTotal, """") - 1)
    Total = CLng(sTotal)
    
    'get Json
    p = InStr(script, "[{")
    If p < 1 Then funcGetMed = -1: Debug.Print "json result not found": Exit Function
    script = Mid(script, p)
    p = InStr(script, "}];") + 1
    If p < 1 Then funcGetMed = -1: Debug.Print "json result not found": Exit Function
    script = Left(script, p)
    'Debug.Print script
    JSON.JSON = script
    If JSON.Count = 0 Then funcGetMed = 0: Exit Function
    
    'print result
    lastRow = sht.Cells(sht.Rows.Count, "B").End(xlUp).Row
    For i = 1 To JSON.Count
        For j = 1 To JSON(i).Count
            If lastRow + i = 3 Then sht.Cells(2, j) = JSON(i).Name(j)   'Key Name
            sht.Cells(lastRow + i, j) = JSON(i)(j)                      'Json Value
        Next j
        sht.Cells(lastRow + i, 1) = sht.Cells(lastRow + i, 1).Row - 2
        If lastRow + i - 2 > Total Then Exit For
    Next i
 
    funcGetMed = JSON.Count
    
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

'https://gist.github.com/yadimon/ce1d04b88de17064bfae
Public Function UnescapeUTF8(ByVal StringToDecode As String) As String
    Dim i As Long
    Dim acode As Integer, sTmp As String
    
    On Error Resume Next
    
    If InStr(1, StringToDecode, "\") = 0 And InStr(1, StringToDecode, "%") = 0 Then
        UnescapeUTF8 = StringToDecode
        Exit Function
    End If
    For i = Len(StringToDecode) To 1 Step -1
        acode = Asc(Mid$(StringToDecode, i, 1))
        Select Case acode
        Case 48 To 57, 65 To 90, 97 To 122
            ' don't touch alphanumeric chars
            DoEvents

        Case 92, 37: ' Decode \ or % value with uXXXX format
            If Mid$(StringToDecode, i + 1, 1) = "u" Then
                sTmp = CStr(CLng("&H" & Mid$(StringToDecode, i + 2, 4)))
                If IsNumeric(sTmp) Then
                    StringToDecode = Left$(StringToDecode, i - 1) & ChrW$(CInt("&H" & Mid$(StringToDecode, i + 2, 4))) & Mid$(StringToDecode, i + 6)
                End If
            End If
            
        Case 37: ' % not %uXXXX but %XX format
            
            sTmp = CStr(CLng("&H" & Mid$(StringToDecode, i + 1, 2)))
            If IsNumeric(sTmp) Then
                StringToDecode = Left$(StringToDecode, i - 1) & ChrW$(CInt("&H" & Mid$(StringToDecode, i + 1, 2))) & Mid$(StringToDecode, i + 3)
            End If
            
        End Select
    Next

    UnescapeUTF8 = StringToDecode
End Function

 

 

- 마우스우클릭 메뉴 추가 코드는 '현재_통합_문서' 코드에 들어 있습니다.

 
'우측버튼 컨트롤 삭제
Private Sub Workbook_Deactivate()
    On Error Resume Next
        With Application
            .CommandBars("Cell").Controls("getMed").Delete
        End With
    On Error GoTo 0
End Sub

'우측버튼 클릭시
Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    
    Dim cmdBtn As CommandBarButton
    
    On Error Resume Next
    With Application
        .CommandBars("Cell").Controls("GetMed").Delete
        Set cmdBtn = .CommandBars("Cell").Controls.Add(Type:=msoControlButton, Before:=1, Temporary:=True)
    End With
    With cmdBtn
        .FaceId = 1922
        .Caption = "getMed"
        .OnAction = "getMed"
    End With
    On Error GoTo 0
    
End Sub

 

JsonBag 클래스 버전 2.6

https://www.vbforums.com/showthread.php?738845-VB6-JsonBag-Another-JSON-Parser-Generator&p=5366455&viewfull=1#post5366455

VB6 - JsonBag, Another JSON Parser/Generator - Page 3-VBForums

 

 

첨부파일 참고하세요.

이 파일은 웹크롤링에 대한 예시일 뿐이고

서버의 작동에 무리를 주어서는 안됨을 주의하시기 바랍니다.

또한 서버의 HTML등의 변경으로 작동이 안된다해도 유지보수를 보장하지 않습니다.

 

getMed1.xlsm

0.09MB