Пример вызова Подсказок DaData.ru из Excel

## README.md

      
        

          Raw
        
        
          
            
          
          
            
              README.md
            
          
        
      
    
  
    Как подключить пример

Откройте Excel и включите отображение вкладки «Разработчик»
Перейдите в редактор Visual Basic (в ленте Разработчик > Visual Basic).
Откройте список ссылок: в меню Tools > References...
Отметьте пункты «Microsoft Scripting Runtime» и «Microsoft VBScript Regular Expressions 5.5».
Нажмите OK.
Откройте модуль Лист1.
Скопируйте код из примера в модуль.
Замените значение константы API_KEY с CHANGE_ME на ваш API-ключ.

Как работает пример
Введите название компании или ИНН в ячейку A1, нажмите «энтер». В соседних ячейках появятся реквизиты компании из Подсказок.

  

  

## suggestions.cls
Private Const API_KEY = "CHANGE_ME"
Private pCachedRegexes As Dictionary

Public Function GetRegex( _
    ByVal pattern As String, _
    Optional ByVal IgnoreCase As Boolean = True, _
    Optional ByVal MultiLine As Boolean = True, _
    Optional ByVal MatchGlobal As Boolean = True) As RegExp

    ' Ensure the dictionary has been initialized
    If pCachedRegexes Is Nothing Then Set pCachedRegexes = New Dictionary

    ' Build the unique key for the regex: a combination
    ' of the boolean properties and the pattern itself
    Dim rxKey As String
    rxKey = IIf(IgnoreCase, "1", "0") & _
            IIf(MultiLine, "1", "0") & _
            IIf(MatchGlobal, "1", "0") & _
            pattern

    ' If the RegExp object doesn't already exist, create it
    If Not pCachedRegexes.Exists(rxKey) Then
        Dim oRegExp As New RegExp
        With oRegExp
            .pattern = pattern
            .IgnoreCase = IgnoreCase
            .MultiLine = MultiLine
            .Global = MatchGlobal
        End With
        Set pCachedRegexes(rxKey) = oRegExp
    End If

    ' Fetch and return the pre-compiled RegExp object
    Set GetRegex = pCachedRegexes(rxKey)
End Function

Function Utf8ToAscii(ByVal txt) As String
    On Error Resume Next: Err.Clear
    With CreateObject("ADODB.Stream")
        .Type = 1
        .Open
        .Write txt
        .Position = 0
        .Type = 2
        .Charset = "UTF-8"
        Utf8ToAscii = .ReadText
        .Close
    End With
End Function

Function Suggest(ByVal name, ByVal query, ByVal count) As String
    Dim http
    Set http = CreateObject("WinHttp.WinHttpRequest.5.1")
    timeout = 2000 'milliseconds
    http.setTimeouts timeout, timeout, timeout, timeout
    request = "{ ""query"": """ & query & """, ""count"": """ & count & """ }"
    http.Open "POST", "https://suggestions.dadata.ru/suggestions/api/4_1/rs/suggest/" & name
    http.setRequestHeader "Content-Type", "application/json"
    http.setRequestHeader "Authorization", "Token " & API_KEY
    http.send request
    suggestions = Replace(http.responseText, "\""", "")
    Debug.Print suggestions
    Suggest = suggestions
End Function

Function Extract(ByVal fieldName, ByVal suggestion)
    rePattern = "^.+""" & fieldName & """:""([^""]+)"".+$"
    Debug.Print "Pattern: " & rePattern
    Dim re As RegExp
    Set re = GetRegex(rePattern)
    If re.Test(suggestion) Then
        result = re.Replace(suggestion, "$1")
    Else
        result = ""
    End If
    Debug.Print "Extracted: " & result
    Extract = result
End Function

Function ExtractName(suggestion) As String
    ExtractName = Extract("suggestions.....value", suggestion)
End Function

Function ExtractOGRN(suggestion) As String
    ExtractOGRN = Extract("ogrn", suggestion)
End Function

Function ExtractINN(suggestion) As String
    ExtractINN = Extract("inn", suggestion)
End Function

Function ExtractKPP(suggestion) As String
    ExtractKPP = Extract("kpp", suggestion)
End Function

Function ExtractOKVED(suggestion) As String
    ExtractOKVED = Extract("okved", suggestion)
End Function

Function ExtractAddress(suggestion) As String
    ExtractAddress = Extract("address....value", suggestion)
End Function

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim KeyCells As Range
    If Target.Address = "$A$1" Then
        Debug.Print "Source: " & Target.Value
        suggested = Suggest("party", Target.Value, 1)
        'Debug.Print "Suggested: " & suggested
        Range("B1").Value = ExtractName(suggested)
        Range("C1").Value = ExtractOGRN(suggested)
        Range("D1").Value = ExtractINN(suggested)
        Range("E1").Value = ExtractKPP(suggested)
        Range("F1").Value = ExtractOKVED(suggested)
        Range("G1").Value = ExtractAddress(suggested)
    End If
End Sub