Option Compare Database
Option Explicit

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Sub cmdRefresh_Click()
'[最新情報に更新]ボタンクリック時

  Dim cnn As New ADODB.Connection
  Dim rst As New ADODB.Recordset
  Dim strSQL As String
  Dim lngRecCnt As Long
  Dim dblLat As Double
  Dim dblLng As Double
  
  Beep
  If MsgBox("最新情報に更新します！" & _
            vbCrLf & vbCrLf & _
            "件数によってはGoogleマップから住所を検索するのに非常に時間がかかることがあります。" & _
            "実行してよろしいですか？", vbYesNo + vbQuestion) = vbNo Then
    Exit Sub
  End If
  
  'テーブルの座標値データを更新
  Set cnn = CurrentProject.Connection
  With rst
    strSQL = "SELECT * FROM tbl住所情報 WHERE 座標取得済み = False"
    .Open strSQL, cnn, adOpenStatic, adLockOptimistic, adCmdText
    SysCmd acSysCmdInitMeter, "ただいま処理中です....", .RecordCount
    lngRecCnt = 0
    Do Until .EOF
      If GetGeocode(!住所, dblLat, dblLng) Then
        !緯度 = dblLat
        !経度 = dblLng
        !座標取得済み = True
        .Update
      End If
      lngRecCnt = lngRecCnt + 1
      SysCmd acSysCmdUpdateMeter, lngRecCnt
      .MoveNext
    Loop
    SysCmd acSysCmdRemoveMeter
    .Close: Set rst = Nothing
  End With
  cnn.Close: Set cnn = Nothing

  'マップの表示処理
  cbfRefreshMap True

End Sub

Private Sub マップ縮尺_AfterUpdate()
'マップ縮尺の更新後処理

  'マップの表示処理
  cbfRefreshMap True
  
End Sub

Private Sub マップ中心住所_AfterUpdate()
'マップ中心住所の更新後処理

  'マップの表示処理
  cbfRefreshMap True
  
End Sub

Private Sub Form_Load()
'フォーム読み込み時

  'WebブラウザコントロールのURLを設定
  Me!wbマップ.ControlSource = "=""" & CurrentProject.Path & "\index.html"""
   
  'マップの表示処理

End Sub

Private Sub cbfRefreshMap(blnRefreshFlg As Boolean)
'マップの表示処理
  
  Dim cnn As New ADODB.Connection
  Dim rst As New ADODB.Recordset
  Dim strm As New ADODB.Stream
  Dim strSQL As String
  Dim strData As String
  
  'テーブルからマーカーの住所情報を取得して組み立て
  Set cnn = CurrentProject.Connection
  With rst
    strSQL = "SELECT * FROM tbl住所情報 WHERE 座標取得済み = True ORDER BY ID"
    .Open strSQL, cnn, adOpenStatic, adLockReadOnly, adCmdText
    strData = ""
    Do Until .EOF
      strData = strData & _
                  IIf(Len(strData) > 0, "," & vbCrLf, "") & _
                  "['" & !住所 & "', '" & !名前 & "', " & _
                  !緯度 & ", " & !経度 & ", 1]"
      .MoveNext
    Loop
    .Close: Set rst = Nothing
  End With
  cnn.Close: Set cnn = Nothing

  '画面より中心住所と縮尺を取得して組み立て
  strData = "var mapzoom = " & Nz(Me!マップ縮尺, 10) & ";" & vbCrLf & _
              "var places = [" & vbCrLf & _
              "['" & Me!マップ中心住所 & "', '', 0, 0, 0]" & _
              IIf(Len(strData) > 0, ", " & strData & vbCrLf, "") & vbCrLf & _
              "];" & vbCrLf

  '組み立てたデータをmapdata.jsに書き出し
  With strm
    .Charset = "UTF-8"
    .Open
    .WriteText strData
    .SaveToFile CurrentProject.Path & "\mapdata.js", adSaveCreateOverWrite
    .Close: Set strm = Nothing
  End With
  
  'Webブラウザコントロールを最新情報に更新
  If blnRefreshFlg Then
    Me!wbマップ.Refresh
  End If

End Sub

Private Function GetGeocode(ByVal strAddress As String, _
                            ByRef dblLat As Double, ByRef dblLng As Double) As Boolean

  Dim objXml As MSXML2.DOMDocument
  Dim objNodeList As MSXML2.IXMLDOMNodeList
  Dim objSC As Object
  Dim strURL As String
  Dim intReTry As Integer

  DoCmd.Hourglass True

  'Google Map API へのリクエスト文字列を組み立て
  strURL = "https://maps.googleapis.com/maps/api/geocode/xml?sensor=false&address="
  
  '住所をエンコード
  Set objSC = CreateObject("ScriptControl")
  With objSC
    .Language = "Jscript"
    strURL = strURL & .CodeObject.encodeURIComponent(strAddress)
  End With
  Set objSC = Nothing
  
  intReTry = 0
  Do
    'リクエストを発行してデータを取得
    Set objXml = New MSXML2.DOMDocument
    With objXml
      .async = False
      .SetProperty "ServerHTTPRequest", True
      If Not objXml.Load(strURL) Then
        Sleep 1000  '１秒５件を満たすための待機
        intReTry = intReTry + 1
      End If
    End With
    
    '取得したXMLよりrecordDataノードのデータを取得
    Set objNodeList = objXml.documentElement.selectNodes("/GeocodeResponse/result/geometry/location")
    With objNodeList
      If .Length > 0 Then
        '該当するデータがあれば座標値を取得
        With .Item(0)
          dblLat = CDbl(.childNodes(0).Text)
          dblLng = CDbl(.childNodes(1).Text)
        End With
        Exit Do
      Else
        Sleep 1000
        intReTry = intReTry + 1
      End If
    End With
  
  Loop Until intReTry > 3

  Set objNodeList = Nothing
  Set objXml = Nothing
  DoCmd.Hourglass False
  
  '返り値を設定
  GetGeocode = Not (intReTry > 3)
  
End Function