Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0798: Zugriff auf Google Maps mit Usercontrols (AsyncRead)

VB 5/6-Tipp 0798: Zugriff auf Google Maps mit Usercontrols (AsyncRead)

 von BAGZZlash

Schwierigkeitsgrad:

Verwendete API-Aufrufe: SetStretchBltMode, StretchBlt

Download: Download des Beispielprojektes [6 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'--------------- Anfang Projektdatei GMap.vbp ---------------
'---------- Anfang Formular "fTest" alias GMap.frm ----------
' Steuerelement: Listen-Steuerelement "lstMarkers"
' Steuerelement: Kombinationsliste "cmbMapType"
' Steuerelement: Kombinationsliste "cmbZoom"
' Steuerelement: Textfeld "txtSearch"
' Steuerelement: GmapTest.ucGMap "ucGMap1"
' Steuerelement: Beschriftungsfeld "lblMarkers"
' Steuerelement: Beschriftungsfeld "lblMouseLatLng"
' Steuerelement: Beschriftungsfeld "lblCenter"
' Steuerelement: Beschriftungsfeld "lblMapType"
' Steuerelement: Beschriftungsfeld "lblZoom"
Option Explicit
 
Private Sub Form_Load()
Dim i&
  For i = 0 To 20: cmbZoom.AddItem 2 ^ i: Next
  cmbZoom.ListIndex = 16
  
  For i = 0 To 3: cmbMapType.AddItem ucGMap1.GetMapType(i): Next
  cmbMapType.ListIndex = 0
  
  txtSearch.Text = "Berlin Alte Schönhauser Straße"
  txtSearch_KeyDown 13, 0
End Sub

Private Sub Form_Resize()
  On Error Resume Next
  ucGMap1.Move txtSearch.Width + 10, 0, ScaleWidth - txtSearch.Width - 10, ScaleHeight
End Sub

Private Sub txtSearch_KeyDown(KeyCode As Integer, Shift As Integer)
  If KeyCode <> 13 Then Exit Sub
  If Me.Visible Then cmbZoom.SetFocus
  DoEvents
  txtSearch.Text = Replace(txtSearch.Text, vbCrLf, "")
  If Len(txtSearch.Text) = 0 Then Exit Sub
  ucGMap1.SetCenterToTextLocation txtSearch.Text
  lblCenter.Caption = "CenterPoint: " & ucGMap1.GPoint
End Sub
 
Private Sub cmbZoom_Click()
  ucGMap1.GZoom = cmbZoom.ListIndex
End Sub

Private Sub cmbMapType_Click()
  ucGMap1.MapType = cmbMapType.ListIndex
End Sub

Private Sub lstMarkers_DblClick()
  ucGMap1.GPoint = Mid$(lstMarkers.Text, 3)
End Sub

Private Sub ucGMap1_MouseMove(ByVal GMouseCoordLatLng As String)
  lblMouseLatLng.Caption = "MousePoint: " & GMouseCoordLatLng
End Sub
Private Sub ucGMap1_MouseUp(ByVal GMouseCoordLatLng As String)
  cmbZoom.SetFocus
End Sub

Private Sub ucGMap1_DblClick(ByVal GMouseCoordLatLng As String)
Dim MarkerChar As String
  MarkerChar = Chr$(65 + ucGMap1.Markers.Count)
  lstMarkers.AddItem MarkerChar & ": " & GMouseCoordLatLng
  
  ucGMap1.AddMarker GMouseCoordLatLng, vbGreen, MarkerChar
  ucGMap1.Refresh
End Sub

'----------- Ende Formular "fTest" alias GMap.frm -----------
'--- Anfang benutzerdefiniertes Steuerelement "ucGMap" alias ucGMap.ctl ---
'Implementation of the Google-Static-API (limited to 1000 requests per User and Day)
'There's no dependencies to a Browser-Control - just the plain AsynRead-functionality
'of a VB6-Usercontrol (the only two API-calls are used, to blit with HalfTone-Quality)
'Author: Olaf Schmidt (2012)
'2013... adjustments to the location-search-api, which now requires a new URL:
'        "http://maps.googleapis.com/maps/api/geocode/xml?&sensor=false&address=" & UTF8-encoded-Address

Option Explicit

Public Enum MapType
  mt_roadmap
  mt_satellite
  mt_hybrid
  mt_terrain
End Enum

Private Declare Function SetStretchBltMode Lib "gdi32" (ByVal hDC As Long, ByVal nStretchMode As Long) As Long
Private Declare Function StretchBlt Lib "gdi32.dll" (ByVal hdcDest As Long, ByVal nXDest As Long, ByVal nYDest As Long, ByVal nDestWidth As Long, ByVal nDestHeight As Long, ByVal hdcSrc As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal hSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long

Event MouseMove(ByVal GMouseCoordLatLng As String)
Event MouseUp(ByVal GMouseCoordLatLng As String)
Event DblClick(ByVal GMouseCoordLatLng As String)
 
Private Const mSize& = 640 'this is the max (free usable) SquareSize of the GMap-Static-API
Private Const PI# = 3.14159265358979, TwoPI# = 6.28318530717959
Private Const D2RFac# = 1.74532925199433E-02

Private BackBuf As VB.PictureBox
Private mGZoom As Long, mGPoint As String, mMapType As MapType
Private mLat As Single, mLng As Single
Private mPxlX As Long, mPxlY As Long
Private MDownPoint, LastGMouseMovePoint As String, LastGSearchPoint As String

Public Markers As New Collection

Private Sub UserControl_Initialize()
  ScaleMode = vbPixels
  Set BackBuf = Controls.Add("VB.PictureBox", "BackBuf")
  BackBuf.BorderStyle = 0
  BackBuf.AutoRedraw = True
  BackBuf.Move 0, 0, mSize, mSize
  mGPoint = "0,0"
End Sub

Private Sub UserControl_AsyncReadComplete(AsyncProp As AsyncProperty)
  If AsyncProp.StatusCode <> vbAsyncStatusCodeEndDownloadData Then Exit Sub
  
  Select Case TypeName(AsyncProp.Value)
    Case "Byte()"
      Dim XML As String
       XML = ReadTagContent(StrConv(AsyncProp.Value, vbUnicode), "location")
  
       LastGSearchPoint = ReadTagContent(XML, "lat") & "," & ReadTagContent(XML, "lng")
    Case "Picture"
      If AsyncProp.BytesRead < 8000 Then Exit Sub
      Set BackBuf.Picture = AsyncProp.Value
      UserControl_Paint
  End Select
End Sub

Private Function ReadTagContent(sXML As String, Tag As String) As String
Dim Result As String
  Result = Mid$(sXML, InStr(sXML, "<" & Tag & ">") + Len(Tag) + 2)
  Result = Left$(Result, InStr(Result, "</" & Tag & ">") - 1)
  Result = Replace(Replace(Result, vbCr, ""), vbLf, "")
  ReadTagContent = Trim$(Result)
End Function

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  X = (X / ScaleWidth - 0.5) * mSize: Y = (Y / ScaleHeight - 0.5) * mSize
  If Button = 1 Then MDownPoint = Array(CLng(X), CLng(Y))
End Sub
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  X = (X / ScaleWidth - 0.5) * mSize: Y = (Y / ScaleHeight - 0.5) * mSize
  LastGMouseMovePoint = Trim(Str(PxlYToLat(mPxlY + Y))) & "," & Trim(Str(PxlXToLng(mPxlX + X)))
  RaiseEvent MouseMove(LastGMouseMovePoint)
End Sub
Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  X = (X / ScaleWidth - 0.5) * mSize: Y = (Y / ScaleHeight - 0.5) * mSize
  If Not IsEmpty(MDownPoint) Then
    Dim dx As Long, dy As Long
    dx = MDownPoint(0) - X: dy = MDownPoint(1) - Y
    MDownPoint = Empty
    GPoint = Trim(Str(PxlYToLat(mPxlY + dy))) & "," & Trim(Str(PxlXToLng(mPxlX + dx)))
  End If
  RaiseEvent MouseUp(LastGMouseMovePoint)
End Sub
Private Sub UserControl_DblClick()
  RaiseEvent DblClick(LastGMouseMovePoint)
End Sub

Private Sub UserControl_Resize()
  UserControl_Paint
End Sub
Private Sub UserControl_Paint()
  SetStretchBltMode UserControl.hDC, 4
  StretchBlt hDC, 0, 0, ScaleWidth, ScaleHeight, BackBuf.hDC, 0, 0, BackBuf.Width, BackBuf.Height, vbSrcCopy
End Sub

'Zoom-related Props
Public Property Let GZoom(ByVal NewValue As Long)
  If NewValue < 0 Then NewValue = 0
  If NewValue > 20 Then NewValue = 20
  If mGZoom = NewValue Then Exit Property
  mGZoom = NewValue
  mPxlX = LngToPxlX
  mPxlY = LatToPxlY
  Refresh
End Property
Public Property Get GZoom() As Long
  GZoom = mGZoom
End Property
Public Property Get RealZoom() As Long
  RealZoom = 2 ^ mGZoom
End Property

'Lat,Long "Csv-String-Point"-related Props
Public Property Let GPoint(ByVal NewValue As String)
Dim Sarr() As String
  If mGPoint = NewValue Then Exit Property
  mGPoint = NewValue
  Sarr = Split(NewValue, ",")
  If UBound(Sarr) <> 1 Then Err.Raise vbObjectError, , _
                            "not a valid Lat,Long-Point-Definition"
  mLat = Val(Sarr(0))
  mLng = Val(Sarr(1))

  mPxlX = LngToPxlX
  mPxlY = LatToPxlY
  Refresh
End Property
Public Property Get GPoint() As String
  GPoint = mGPoint
End Property
Public Property Get Lat() As Double
  Lat = mLat
End Property
Public Property Get Lng() As Double
  Lng = mLng
End Property

'maptype-Props
Public Property Let MapType(ByVal NewValue As MapType)
  If NewValue < 0 Then NewValue = 0
  If NewValue > 3 Then NewValue = 3
  mMapType = NewValue
  Refresh
End Property
Public Property Get MapType() As MapType
  MapType = mMapType
End Property
Public Function GetMapType(Optional MapType) As String
  If IsMissing(MapType) Then MapType = mMapType
  Select Case MapType
    Case mt_roadmap:   GetMapType = "roadmap"
    Case mt_satellite: GetMapType = "satellite"
    Case mt_hybrid:    GetMapType = "hybrid"
    Case mt_terrain:   GetMapType = "terrain"
  End Select
End Function

'all the Pxl to GeoCoord-formulas found in PHP-code from Fabrice Bernhard
Public Function LngToPxlX(Optional Lng, Optional GZoom, Optional GImgWidth) As Long
  If IsMissing(Lng) Then Lng = mLng
  If IsMissing(GZoom) Then GZoom = mGZoom
  If IsMissing(GImgWidth) Then GImgWidth = mSize
  If Lng > 180 Then Lng = 180 Else If Lng < -180 Then Lng = -180
  
  LngToPxlX = (D2RFac * Lng + PI) * 256 / TwoPI * 2 ^ GZoom
End Function

Public Function LatToPxlY(Optional Lat, Optional GZoom, Optional GImgHeight) As Long
  If IsMissing(Lat) Then Lat = mLat
  If IsMissing(GZoom) Then GZoom = mGZoom
  If IsMissing(GImgHeight) Then GImgHeight = mSize
  If Lat > 85 Then Lat = 85 Else If Lat < -85 Then Lat = -85
  
  LatToPxlY = (PI - Log(Tan(PI / 4 + D2RFac * Lat / 2))) * 256 / TwoPI * 2 ^ GZoom
End Function

Public Function PxlXToLng(Optional PxlX, Optional GZoom, Optional GImgWidth) As Single
  If IsMissing(PxlX) Then PxlX = mPxlX
  If IsMissing(GZoom) Then GZoom = mGZoom
  If IsMissing(GImgWidth) Then GImgWidth = mSize
  PxlX = PxlX / 2 ^ GZoom
  If PxlX > GImgWidth Then PxlX = GImgWidth Else If PxlX < 0 Then PxlX = 0
  
  PxlXToLng = (PxlX / 256 * TwoPI - PI) / D2RFac
End Function
 
Public Function PxlYToLat(Optional PxlY, Optional GZoom, Optional GImgHeight) As Single
  If IsMissing(PxlY) Then PxlY = mPxlY
  If IsMissing(GZoom) Then GZoom = mGZoom
  If IsMissing(GImgHeight) Then GImgHeight = mSize
  PxlY = PxlY / 2 ^ GZoom
  If PxlY > GImgHeight Then PxlY = GImgHeight Else If PxlY < 0 Then PxlY = 0
  
  PxlYToLat = (2 * Atn(Exp(PI - PxlY / 256 * TwoPI)) - PI / 2) / D2RFac
End Function

Public Function FindLatLngPointFromTextLocation(TextLocation As String) As String
Dim ReqURL As String
  ReqURL = "http://maps.googleapis.com/maps/api/geocode/xml?&sensor=false&address=" & UTF8UrlEnc(TextLocation)
  AsyncRead ReqURL, vbAsyncTypeByteArray, CStr(Timer), vbAsyncReadSynchronousDownload
  FindLatLngPointFromTextLocation = LastGSearchPoint
End Function

Public Sub SetCenterToTextLocation(TextLocation As String)
  GPoint = FindLatLngPointFromTextLocation(TextLocation)
End Sub

Public Sub AddMarker(GPosLatLng As String, ByVal Color As Long, MarkerChar As String)
  Markers.Add "&markers=color:0x" & Color2Hex(Color) & "%7Clabel:" & Left$(MarkerChar, 1) & "%7C" & GPosLatLng
End Sub

Public Function Refresh() As Long
Dim ReqURL As String, M
Static Counter As Long
  Counter = Counter + 1
  ReqURL = "http://maps.googleapis.com/maps/api/staticmap?sensor=false&format=jpg"
  ReqURL = ReqURL & "¢er=" & GPoint
  ReqURL = ReqURL & "&zoom=" & GZoom
  ReqURL = ReqURL & "&size=" & mSize & "x" & mSize
  ReqURL = ReqURL & "&maptype=" & GetMapType
  For Each M In Markers: ReqURL = ReqURL & M: Next
  
  On Error Resume Next
    AsyncRead ReqURL, vbAsyncTypePicture, "C=" & Counter, vbAsyncReadResynchronize
  If Err Then Err.Clear
  Refresh = Counter
End Function
 
 
'small Helper-Functions
Private Function Color2Hex(Color As Long) As String
  Color2Hex = Right("0" & Hex(Color \ 65536), 2) & _
              Right("0" & Hex(Color \ 256 And 255), 2) & _
              Right("0" & Hex(Color And 255), 2)
End Function

Private Function UTF8UrlEnc(S As String) As String
Dim i As Long, W As Integer
  For i = 1 To Len(S)
    W = AscW(Mid$(S, i, 1))
    If W < 128 Then
      UTF8UrlEnc = UTF8UrlEnc & ChrW$(W)
    ElseIf W < 2048 Then
      UTF8UrlEnc = UTF8UrlEnc & "%" & Hex$(W \ 64 Or 192) & "%" & Hex$(W And 63 Or 128)
    End If
  Next i
End Function

'--- Ende benutzerdefiniertes Steuerelement "ucGMap" alias ucGMap.ctl ---
'---------------- Ende Projektdatei GMap.vbp ----------------