Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0751: Google Maps in VB6 - Neu

VB 5/6-Tipp 0751: Google Maps in VB6 - Neu

 von BAGZZlash

Schwierigkeitsgrad:

Verwendete API-Aufrufe: WideCharToMultiByte

Download: Download des Beispielprojektes [4.01 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 Projekt1.vbp -------------
' Die Komponente ' (ieframe.dll)' wird benötigt.

'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Webbrowsercontrol "WebBrowser2"
' Steuerelement: Webbrowsercontrol "WebBrowser1"
' Steuerelement: Schaltfläche "Command2"
' Steuerelement: Rahmensteuerelement "Frame1"
' Steuerelement: Textfeld "Text4" auf Frame1
' Steuerelement: Textfeld "Text3" auf Frame1
' Steuerelement: Textfeld "Text2" auf Frame1
' Steuerelement: Textfeld "Text1" auf Frame1
' Steuerelement: Beschriftungsfeld "Label3" auf Frame1
' Steuerelement: Beschriftungsfeld "Label4" auf Frame1
' Steuerelement: Beschriftungsfeld "Label2" auf Frame1
' Steuerelement: Beschriftungsfeld "Label1" auf Frame1
' Steuerelement: Schaltfläche "Command1"
'------------------ Weitere Informationen  ------------------
' Weitere Informationen zur Google-Maps-API:
' http://code.google.com/intl/pl/apis/maps/documentation/javascript/reference.html#MapOptions

Option Explicit

Private Declare Function WideCharToMultiByte Lib "kernel32.dll" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByVal lpMultiByteStr As Long, ByVal cbMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long

Private Const CP_UTF8 As Long = 65001
Private Const MarginHeight = 4
Private Const MarginWidth = 21

Private Sub Command1_Click()

DisplayMap

End Sub

Private Sub Command2_Click()

Unload Me

End Sub

Private Sub Form_Load()

Form1.WebBrowser1.Resizable = True
Form1.WebBrowser1.Navigate ("about:blank") 'Startseite initialisieren.
Form1.WebBrowser2.ZOrder 1 'Wird für den Abruf der Koordinaten benötigt und kann versteckt werden.

End Sub

Private Sub Text1_KeyPress(KeyAscii As Integer)

If KeyAscii = 13 Then
    DisplayMap
    KeyAscii = 0 'Verhindet den üblichen Bestätigungsklang.
End If

End Sub

Private Function ConvertToUTF8(ByRef Source As String) As Byte()

Dim Length As Long
Dim Pointer As Long
Dim Size As Long
Dim Buffer() As Byte

Length = Len(Source)
Pointer = StrPtr(Source)
Size = WideCharToMultiByte(CP_UTF8, 0, Pointer, Length, 0, 0, 0, 0)
ReDim Buffer(0 To Size - 1)

WideCharToMultiByte CP_UTF8, 0, Pointer, Length, VarPtr(Buffer(0)), Size, 0, 0
    
ConvertToUTF8 = Buffer
    
End Function

Private Function UTFMiniFix(InString As String) As String

Dim n As Long
Dim m As Long
Dim Char() As Byte

For n = 1 To Len(InString)
    Char = ConvertToUTF8(Mid$(InString, n, 1))
   
    If UBound(Char) > 0 Then
        For m = 0 To UBound(Char)
            UTFMiniFix = UTFMiniFix & "%" & Hex$(Char(m))
        Next m
    Else
        UTFMiniFix = UTFMiniFix & Chr$(Char(0))
    End If
Next n

End Function

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 DisplayMap()

Dim LocationStringArr() As String
Dim Latitude As String
Dim Longitude As String
Dim HTMLCode As String

LocationStringArr = ReturnLocation(Form1.Text1) 'Gibt ein Array zurück, das Breiten- und Längengraden enthält.

If UBound(LocationStringArr) <> 3 Then
    MsgBox "Fehler bei Abrufen der Koordinatendaten.", vbCritical
    Exit Sub
End If

Latitude = LocationStringArr(2)
Longitude = LocationStringArr(3)

HTMLCode = ReturnHTMLString(Latitude, Longitude, CInt(Form1.Text4))

Form1.WebBrowser1.Height = (Val(Form1.Text2) + MarginHeight) * Screen.TwipsPerPixelY
Form1.WebBrowser1.Width = (Val(Form1.Text3) + MarginWidth) * Screen.TwipsPerPixelX

Form1.WebBrowser1.Document.write HTMLCode
Form1.WebBrowser1.Refresh

End Sub

Private Function ReturnLocation(Location As String) As String()

Dim SearchString As String
Dim ReturnString As String
Dim ReturnStringArr(0 To 3) As String

Location = UTFMiniFix(Location) 'Google interpretiert den übergebenen String als UTF-8-kodiert.

SearchString = "http://maps.googleapis.com/maps/api/geocode/xml?address=" & Location & "&sensor=false"

Form1.WebBrowser2.Navigate (SearchString)

Do
    DoEvents
Loop While WebBrowser2.ReadyState <> READYSTATE_COMPLETE

ReturnString = ReadTagContent(Form1.WebBrowser2.Document.Body.InnerText, "location")
 
ReturnStringArr(0) = "" 'Hier standen bei der Google Maps API v2
ReturnStringArr(1) = "" 'Bestätigungscodes. Nun beliebig selbst füllen.

ReturnStringArr(2) = ReadTagContent(ReturnString, "lat")
ReturnStringArr(3) = ReadTagContent(ReturnString, "lng")

ReturnLocation = ReturnStringArr

End Function

Private Function ReturnHTMLString(Latitude As String, Longitude As String, ZoomFactor As Integer) As String

ReturnHTMLString = "<!DOCTYPE html PUBLIC '-//W3C//DTD XHTML 1.0 Strict//EN'" & vbNewLine
ReturnHTMLString = ReturnHTMLString & "    'http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd'>" & vbNewLine
ReturnHTMLString = ReturnHTMLString & "<html xmlns='http://www.w3.org/1999/xhtml'" & vbNewLine
ReturnHTMLString = ReturnHTMLString & "xmlns:v='urn:schemas-microsoft-com:vml'>" & vbNewLine
ReturnHTMLString = ReturnHTMLString & vbNewLine
ReturnHTMLString = ReturnHTMLString & "<head>" & vbNewLine
ReturnHTMLString = ReturnHTMLString & "  <meta http-equiv='content-type' content='text/html;charset=utf-8'/>" & vbNewLine
ReturnHTMLString = ReturnHTMLString & "  <meta http-equiv='X-UA-Compatible' content='IE=edge'>" & vbNewLine 'Dies ist wohl aus Kompatibilitätsgründen erforderlich (Internet Explorer), siehe hier: https://code.google.com/p/gmaps-api-issues/issues/detail?id=9004 und hier: https://blogs.msdn.microsoft.com/patricka/2015/01/12/controlling-webbrowser-control-compatibility/
ReturnHTMLString = ReturnHTMLString & vbNewLine
ReturnHTMLString = ReturnHTMLString & "<title>Zugriff auf Google Maps API</title>" & vbNewLine
ReturnHTMLString = ReturnHTMLString & vbNewLine
ReturnHTMLString = ReturnHTMLString & "<script src='http://maps.google.com/maps?file=api&v=2&key=ABQIAAAAwMzF90OPDYCo3ejYxew4zhQ4n4xcLoLVQXW0-1NaLBfn657FaBQ8WA-rssNtB7dwdTd80OlCLmZqsw' type='text/javascript'></script>" & vbNewLine
ReturnHTMLString = ReturnHTMLString & vbNewLine
ReturnHTMLString = ReturnHTMLString & "<script type='text/javascript'>" & vbNewLine
ReturnHTMLString = ReturnHTMLString & vbNewLine
ReturnHTMLString = ReturnHTMLString & "var map;" & vbNewLine
ReturnHTMLString = ReturnHTMLString & "var zoomFactor = " & ZoomFactor & vbNewLine
ReturnHTMLString = ReturnHTMLString & "var lat = " & Latitude & vbNewLine
ReturnHTMLString = ReturnHTMLString & "var lng = " & Longitude & vbNewLine
ReturnHTMLString = ReturnHTMLString & vbNewLine
ReturnHTMLString = ReturnHTMLString & "function initialize() {" & vbNewLine
ReturnHTMLString = ReturnHTMLString & "  if (GBrowserIsCompatible()) {" & vbNewLine
ReturnHTMLString = ReturnHTMLString & "     map = new GMap2(document.getElementById('map_canvas'));" & vbNewLine
ReturnHTMLString = ReturnHTMLString & "     map.setCenter(new GLatLng(lat, lng), zoomFactor);" & vbNewLine
ReturnHTMLString = ReturnHTMLString & "     map.setUIToDefault();" & vbNewLine
ReturnHTMLString = ReturnHTMLString & "   }" & vbNewLine
ReturnHTMLString = ReturnHTMLString & "}" & vbNewLine
ReturnHTMLString = ReturnHTMLString & vbNewLine
ReturnHTMLString = ReturnHTMLString & "</script>" & vbNewLine
ReturnHTMLString = ReturnHTMLString & "</head>" & vbNewLine
ReturnHTMLString = ReturnHTMLString & vbNewLine
ReturnHTMLString = ReturnHTMLString & "<body onload='initialize()'onunload='GUnload()'>" & vbNewLine
ReturnHTMLString = ReturnHTMLString & "   <div id='map_canvas' style='position:absolute; top:0px; left:0px; width: " & Form1.Text3 & "px; height: " & Form1.Text2 & "px; border: 0px solid black;'></div>" & vbNewLine
ReturnHTMLString = ReturnHTMLString & "<br clear='all'/>" & vbNewLine
ReturnHTMLString = ReturnHTMLString & "<br/>" & vbNewLine
ReturnHTMLString = ReturnHTMLString & vbNewLine
ReturnHTMLString = ReturnHTMLString & "</body>" & vbNewLine
ReturnHTMLString = ReturnHTMLString & "</html>"

ReturnHTMLString = Replace(ReturnHTMLString, "'", Chr$(34))

End Function
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'-------------- Ende Projektdatei Projekt1.vbp --------------