[API 기초 챌린지 #3] 엑셀 x 카카오 지도 API | 실시간 주소 검색툴 만들기

Function GetKakaoAddress()

'카카오 로컬 API 개발문서
'https://developers.kakao.com/docs/latest/ko/local/dev-guide

'● 기본 변수 선언
Dim sAddress As String
Dim sURL As String: Dim APIKey As String
Dim vHeader As Variant: Dim sResult As String
Dim vResult As Variant: ReDim vHeader(0 To 1)

'● 변수 입력
'1. APIKey: 카카오 디벨로퍼 Rest API 키
'APIKey = "API키"

'2. sAddress: 검색할 주소
'sAdddress = "서울시 구로구 구로동"

'3. sURL: API로 요청할 URL
'sURL = "https://dapi.kakao.com/v2/local/search/address.json?query=" & ENCODEURL(sAddress)

'4. vHeader: API 요청에 사용할 Request Header
'vHeader(0) = Array("Content-Type", "application/json")
'vHeader(1) = Array("Authorization", "KakaoAK " & APIKey)

APIKey = ""
sAddress = ""
sURL = ""
vHeader(0) = Array("Content-Type", "application/json")
vHeader(1) = Array("Authorization", "KakaoAK " & APIKey)

'● HTTP 요청 및 결과 받아오기
'GetHTTP 함수를 사용합니다.
'사용예제:
'sResult = GetHttp(sURL,RequestHeader:=vHeader).Body.InnerHtml


'● 주소 추출 후 배열로 출력하기
'미리 완성해드린 GetAddress 예제 코드를 사용합니다.
'vResult = GetAddress(sResult)
'GetKakaoAddress = vResult


End Function

Function GetAddress(sResult)

'###############################################################
'API 기초 챌린지 강의용 VBA 코드입니다.
'▶ GetAddress 함수
'▶ 카카오 로컬 API 결과값에서 지번주소/도로명주소(첫번째 항목)을 배열로 반환합니다.
'###############################################################

Dim sOldAddress As String: Dim vOldAddress As Variant: Dim OldCount As Long
Dim sNewAddress As String: Dim vNewAddress As Variant: Dim NewCount As Long
Dim vResult As Variant
Dim i As Long

On Error Resume Next

sOldAddress = Splitter(sResult, """address"":{", "}")
sNewAddress = Splitter(sResult, """road_address"":{", "}")

vOldAddress = Split(sOldAddress, ",")
OldCount = UBound(vOldAddress)

If Len(sNewAddress) > 0 Then
    vNewAddress = Split(sNewAddress, ",")
    NewCount = UBound(vNewAddress)
End If

ReDim vResult(0 To OldCount + NewCount, 0 To 2)

For i = 0 To OldCount
    vResult(i, 0) = "지번주소"
    vResult(i, 1) = Replace(Split(vOldAddress(i), ":")(0), """", "")
    vResult(i, 2) = Replace(Split(vOldAddress(i), ":")(1), """", "")
Next

If Len(sNewAddress) > 0 Then
    For i = 0 To NewCount + 1
        vResult(i + OldCount + 1, 0) = "도로명주소"
        vResult(i + OldCount + 1, 1) = Replace(Split(vNewAddress(i), ":")(0), """", "")
        vResult(i + OldCount + 1, 2) = Replace(Split(vNewAddress(i), ":")(1), """", "")
    Next
End If

GetAddress = vResult

End Function

Function GetHttp(URL As String, Optional formText As String, _
                                Optional isWinHttp As Boolean = False, _
                                Optional RequestHeader As Variant, _
                                Optional includeMeta As Boolean = False, _
                                Optional RequestType As String = "GET") As Object
 
'###############################################################
'오빠두엑셀 VBA 사용자지정함수 (https://www.oppadu.com)
'▶ GetHttp 함수
'▶ 웹에서 데이터를 받아옵니다.
'▶ 인수 설명
'_____________URL                         : 데이터를 스크랩할 웹 페이지 주소입니다.
'_____________formText                 : Encoding 된 FormText 형식으로 보내야 할 경우, Send String에 쿼리문을 추가합니다.
'_____________isWinHttp               : WinHTTP 로 요청할지 여부입니다. Redirect가 필요할 경우 True로 입력하여 WinHttp 요청을 전송합니다.
'_____________RequestHeader       : RequestHeader를 배열로 입력합니다. 반드시 짝수(한 쌍씩 이루어진) 개수로 입력되어야 합니다.
'_____________includeMeta           : TRUE 일 경우 HTML 문서위로 ResponseText를 강제 입력합니다. Meta값이 포함되어 HTML이 작성되며 innerText를 사용할 수 없습니다. 기본값은 False 입니다.
'_____________RequestType           : 요청방식입니다. 기본값은 "GET"입니다.
'▶ 사용 예제
'Dim HtmlResult As Object
'Set htmlResult = GetHttp("https://www.naver.com")
'msgbox htmlResult.body.innerHTML
'###############################################################
 
Dim oHTMLDoc As Object: Dim objHTTP As Object
Dim HTMLDoc As Object
Dim i As Long: Dim blnAgent As Boolean: blnAgent = False
Dim sUserAgent As String: sUserAgent = "Mozilla/5.0 (Linux; Android 6.0; Nexus 5 Build/MRA58N) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/86.0.4240.183 Mobile Safari/537.36"
 
Application.DisplayAlerts = False
 
If Left(URL, 4) <> "http" Then URL = "http://" & URL
 
Set oHTMLDoc = CreateObject("HtmlFile")
Set HTMLDoc = CreateObject("HtmlFile")
 
If isWinHttp = False Then
    Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
Else
    Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
End If
 
objHTTP.setTimeouts 3000, 3000, 3000, 3000
objHTTP.Open RequestType, URL, False
If Not IsMissing(RequestHeader) Then
    Dim vRequestHeader As Variant
    For Each vRequestHeader In RequestHeader
        Dim uHeader As Long: Dim Lheader As Long: Dim steps As Long
        uHeader = UBound(vRequestHeader): Lheader = LBound(vRequestHeader)
        If (uHeader - Lheader) Mod 2 = 0 Then GetHttp = CVErr(xlValue): Exit Function
        For i = Lheader To uHeader Step 2
            If vRequestHeader(i) = "User-Agent" Then blnAgent = True
            objHTTP.setRequestHeader vRequestHeader(i), vRequestHeader(i + 1)
        Next
    Next
End If
If blnAgent = False Then objHTTP.setRequestHeader "User-Agent", sUserAgent
 
objHTTP.send formText
 
If includeMeta = False Then
    With oHTMLDoc
        .Open
        .Write objHTTP.responseText
        .Close
    End With
Else
    oHTMLDoc.Body.InnerHtml = objHTTP.responseText
End If
 
Set GetHttp = oHTMLDoc
Set oHTMLDoc = Nothing
Set objHTTP = Nothing
 
Application.DisplayAlerts = True
 
End Function

Function ENCODEURL(varText As Variant, Optional blnEncode = True)
 
'###############################################################
'오빠두엑셀 VBA 사용자지정함수 (https://www.oppadu.com)
'▶ EncodeURL 함수
'▶ 한글/영문, 특수기호가 포함된 문자열을 웹 URL 표준 주소로 변환합니다.
'▶ 인수 설명
'_____________varTest        : 표준 URL 주소로 변환할 문자열입니다.
'_____________blnEncode      : TRUE 일 경우 결과값을 출력합니다.
'▶ 사용 예제
's = "http://www.google.com/search=사과"
's = ENCODEURL(s)
'MsgBox s
'###############################################################
 
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

Function Splitter(v As Variant, Cutter As String, Optional Trimmer As String)
 
'###############################################################
'오빠두엑셀 VBA 사용자지정함수 (https://www.oppadu.com)
'▶ Splitter 함수
'▶ Cutter ~ Timmer 사이의 문자를 추출합니다. (Timmer가 빈칸일 경우 Cutter 이후 문자열을 추출합니다.)
'▶ 인수 설명
'_____________v       : 문자열입니다.
'_________Cutter      : 문자열 절삭을 시작할 텍스트입니다.
'_________Trimmer  : 문자열 절삭을 종료할 텍스트입니다. (선택인수)
'▶ 사용 예제
'Dim s As String
's = "{sa;b132@drama#weekend;aabbcc"
's = Splitter(s, "@", "#")
'msgbox s   '--> "drama"를 반환합니다.
'###############################################################
 
Dim vaArr As Variant
 
On Error GoTo EH:
 
vaArr = Split(v, Cutter)(1)
If Not IsMissing(Trimmer) Then vaArr = Split(vaArr, Trimmer)(0)
 
Splitter = vaArr
 
Exit Function
 
EH:
    Splitter = ""
 
End Function

Sub ExportText(InnerStrings As String, Optional fileName As String = "텍스트추출", Optional Path As String)
 
'###############################################################
'오빠두엑셀 VBA 사용자지정함수 (https://www.oppadu.com)
'▶ Export_Text 함수
'▶ 문자열을 텍스트파일로 추출합니다.
'▶ 인수 설명
'_____________InnerStrings      : 텍스트파일로 추출할 문자열입니다.
'_____________fileName           : 텍스트 파일 이름입니다. 기본값은 "텍스트추출" 입니다. (선택인수)
'_____________path                   : 텍스트 파일을 생성할 경로입니다. 기본값은 바탕화면입니다. (선택인수)
'▶ 사용 예제
'ExportText "추출할 텍스트"
'###############################################################
 
Dim TextFile As Integer
Dim FilePath As String
 
If Path = "" Then Path = Environ("USERPROFILE") & "\Desktop\"
If Right(Path, 1) <> "\" Then Path = Path & "\"
FilePath = Path & fileName & ".txt"
 
TextFile = FreeFile
 
Open FilePath For Output As TextFile
Print #TextFile, InnerStrings
Close TextFile
 
End Sub

Sub ArrayToRng(startRng As Range, Arr As Variant, Optional ColumnNo As String = "", Optional LinkColumnNo As String = "")
 
'###############################################################
'오빠두엑셀 VBA 사용자지정함수 (https://www.oppadu.com)
'▶ ArrayToRng 함수
'▶ 배열을 범위 위로 반환합니다.
'▶ 인수 설명
'_____________startRng      : 배열을 반환할 기준 범위(셀) 입니다.
'_____________Arr               : 반환할 배열입니다.
'_____________ColumnNo   : [선택인수] 배열의 특정 열을 선택하여 범위로 반환합니다. 여러개 열을 반환할 경우 열 번호를 쉼표로 구분하여 입력합니다.
'                                               값으로 공란을 입력하면 열을 건너뜁니다.
'_____________LinkColumNo   : [선택인수] 하이퍼링크로 출력할 열 번호입니다. 쉼표로 구분하여 입력합니다.
'▶ 사용 예제
'Dim v As Variant
'ReDim v(0 to 1)
''v(0) = "a" : v(1) = "b"
'ArrayToRng Sheet1.Range("A1"), v
'▶ 사용된 보조 명령문
'Extract_Column 함수
'##############################################################
 
On Error GoTo SingleDimension:
 
Dim Cols As Variant: Dim Col As Variant
Dim LinkCols As Variant: Dim LinkCol As Variant
Dim i As Long: Dim X As Long: X = 1
Dim colNo As Long
If ColumnNo = "" Then
    startRng.Cells(1, 1).Resize(UBound(Arr, 1) - LBound(Arr, 1) + 1, UBound(Arr, 2) - LBound(Arr, 2) + 1) = Arr
    If LinkColumnNo <> "" Then
        LinkCols = Split(LinkColumnNo, ",")
        For Each LinkCol In LinkCols
            For i = 1 To UBound(Arr, 1) - LBound(Arr, 1) + 1
                colNo = CLng(Trim(LinkCol))
                startRng.Parent.Hyperlinks.Add startRng.Cells(i, colNo), startRng.Cells(i, colNo).Value
            Next
        Next
    End If
Else
    Cols = Split(ColumnNo, ",")
    LinkCols = Split(LinkColumnNo, ",")
    For Each Col In Cols
        If Trim(Col) <> "" Then
            startRng.Cells(1, X).Resize(UBound(Arr, 1) - LBound(Arr, 1) + 1) = Extract_Column(Arr, CLng(Trim(Col)))
            For Each LinkCol In LinkCols
                If Trim(LinkCol) = Trim(Col) Then
                    For i = 1 To UBound(Arr, 1) - LBound(Arr, 1) + 1
                        startRng.Parent.Hyperlinks.Add startRng.Cells(i, X), startRng.Cells(i, X).Value
                    Next
                End If
            Next
        End If
        X = X + 1
    Next
End If
 
Exit Sub
 
SingleDimension:
Dim tempArr As Variant
ReDim tempArr(LBound(Arr, 1) To UBound(Arr, 1), 1 To 1)
For i = LBound(Arr, 1) To UBound(Arr, 1)
    tempArr(i, 1) = Arr(i)
Next
startRng.Cells(1, 1).Resize(UBound(Arr, 1) - LBound(Arr, 1) + 1, 1) = tempArr
 
End Sub
 
'########################
' 배열에서 특정 열 데이터만 추출합니다.
' Array = Extract_Column(Array, 1)
'########################
 
Function Extract_Column(DB As Variant, Col As Long) As Variant
 
Dim i As Long
Dim vArr As Variant
 
ReDim vArr(LBound(DB) To UBound(DB), 1 To 1)
For i = LBound(DB) To UBound(DB)
        vArr(i, 1) = DB(i, Col)
Next
 
Extract_Column = vArr
 
End Function