Zurück zur Homepage

Postleitzahlen in Karte darstellen

Mittlerweile hat sich herausgestellt, dass dieses Beispiel bei größeren Kartenausschnitten und Karten, welche nicht genau nach Norden ausgerichtet sind, Probleme bereitet. Passt man die Koordinaten  beispielsweise so an, dass es im Norden so gut wie möglich stimmt, bereiten Orte im Süden Probleme und umgekehrt. Das liegt zum größten Teil daran, dass die Abstände der Längengrade nach Norden hin geringer werden und nur zwei gegenüberliegende Ecken zur Berechnung herangezogen werden. Deshalb habe ich dieses Beispiel vor Kurzen überarbeitet und unter Punkt 109 zum Download bereitgestellt.

Für den, der dieses Beispiel als Grundlage für eigene Entwicklungen benutzen möchte, ist der Code dort recht ausführlich kommentiert. Der nachfolgende alte Code ist weiterhin auf dieser Seite zu Finden, weil einige Suchmaschinen darauf verweisen.






In der Newsgroup tauchte die Frage auf, wie man Informationen geografisch darstellen kann. Dabei ging es um an Postleitzahlen gebundene Informationen, die lagerichtig auf einer Deutschlandkarte angezeigt werden sollten.

An sich ist das kein großes Problem, aber die Beschaffung freier geografischen Daten stellte sich schon als schwierig heraus. Unter http://opengeodb.hoppe-media.com/ (OpenGeoDB - freie Geokoordinaten-Datenbank) bin ich schließlich fündig geworden. Auch das Kartenmaterial sollte nicht geschützt sein, dafür habe ich auch schon etwas länger suchen müssen.

Es hat sich mittlerweile herausgestellt, dass der Code nicht immer und überall auf Anhieb funktioniert, obwohl ich nie Probleme hatte. Warum das der Fall ist, kann ich nicht genau beantworten. Eine dieser nicht funktionierenden Mappen konnte ich jetzt unter die Lupe nehmen. Ich habe festgestellt, dass es hilft, wenn man das Blatt mit der Karte vorher aktiviert. Den Code habe ich soeben angepasst.

Dim wsVorher         As Worksheet
Set wsVorher = ActiveSheet
Worksheets(strBlatt).Activate

wsVorher.Activate 

 

 Beispieldatei (Geodaten.zip 1025 kB) 

Um statt Labels normale Kreise darzustellen, folgende Beispielmappe:

Beispieldatei (Geodaten2.zip 1025 kB) 

Nachfolgend ein Bild des Tabellenblattes, in das die darzustellenden Daten eingegeben werden:

In A2 bis F2 werden die Daten der Karte wie der Längen- und Breitengrad der linken oberen und rechten unteren Ecke eingegeben. Außerdem noch das Tabellenblatt und der Name des Bildes, wie er in dem linken oberen Namenfeld angezeigt wird.

In die Spalte A unter PLZ werden die gewünschten Postleitzahlen eingegeben, die Koordinaten und Namen werden automatisch eingetragen. In Spalte E kommt die gewünschte Beschriftung. Folgendermaßen sieht das Ergebnis aus:

Hier der Code, der beim Anklicken des Buttons "Daten Eintragen" ausgeführt wird:



Private Sub cmdDaten_Click()
Dim varPos           As Variant
Dim strBlatt         As String
Dim strObjekt        As String
Dim strBeschriftung  As String
Dim strKarte         As String
Dim strDummy         As String
Dim objZiel          As Shape
Dim XTopLeft         As Double
Dim YTopLeft         As Double
Dim XBottomRight     As Double
Dim YBottomRight     As Double
Dim x                As Double
Dim y                As Double
Dim i                As Long
Dim colVorhanden     As New Collection
Dim objShape         As Shape
Dim wsVorher         As Worksheet
XTopLeft = Me.Range(
"E2"'Längengrad Links oben
YTopLeft = Me.Range(
"D2"'Breitengrad Links oben
XBottomRight = Me.Range(
"F2"'Längengrad Rechts unten
YBottomRight = Me.Range(
"C2"'Breitengrad Rechts unten
strBlatt = Me.Range(
"A2"'Kartenblattname
strKarte = Me.Range(
"B2"'Name der Karte

colVorhanden.Add strKarte, strKarte
Set wsVorher = ActiveSheet
Worksheets(strBlatt).Activate
On Error Resume Next

For i = 6 To 25
   
If Me.Cells(i, 1) <> "" Then
      x = Me.Cells(i, 2) 
'Längengrad des Objekts
      y = Me.Cells(i, 3) 
'Breitengrad des Objekts
      strBeschriftung = Me.Cells(i, 5) 
'Beschriftung des Objekts
      
      
'Eindeutigen Objektnamen generieren
      strObjekt = 
"X" & Format(x, "0.000") & Format(y, "0.000")
      
      
'Position berechnen
      varPos = PositionBerechnen( _
         XTopLeft, YTopLeft, _
         XBottomRight, YBottomRight, _
         strBlatt, strKarte, _
         x, y)
         
      
If IsArray(varPos) Then
      
         Err.Clear
         
Set objZiel = Worksheets(strBlatt).Shapes(strObjekt)
         
If Err.Number <> 0 Then
            
'Shape erzeugen
            
Set objZiel = Worksheets(strBlatt).Shapes.AddShape( _
               msoShapeRoundedRectangularCallout, _
               0, 0, _
               100, 20)
            
'Namen für Shape vergeben
            objZiel.Name = strObjekt
         
End If
         
         colVorhanden.Add strObjekt, strObjekt
         
With objZiel
         
            
'Objekt beschriften
            .TextFrame.Characters.Text = strBeschriftung
            
'Verschieben und Pfeil auf Ziel setzen
            .Left = varPos(1) + .Width / 2
            .Top = varPos(2) - .Height * 2
             .DrawingObject.ShapeRange.Adjustments.Item(1) = -0.5
             .DrawingObject.ShapeRange.Adjustments.Item(2) = 2
         
End With
      
End If
   
End If
Next

For Each objShape In Worksheets(strBlatt).Shapes
   
'Nicht benötigte Shapes löschen
   Err.Clear
   strDummy = colVorhanden(objShape.Name)
   
If Err.Number <> 0 Then objShape.Delete
Next
wsVorher.Activate
End Sub


Diese Funktion berechnet die Position auf dem Tabellenblatt:

Public Function PositionBerechnen( _
   
ByVal LängengradLinksOben As Double, _
   
ByVal BreitengradLinksOben As Double, _
   
ByVal LängengradRechtsUnten As Double, _
   
ByVal BreitengradRechtsUnten As Double, _
   strBlatt 
As String, strPic As String, _
   dblPosX 
As Double, dblPosY As Double _
   ) 
As Variant
   
   
Dim As Double, y         As Double
   
Dim adblPosition(1 To 2)   As Double
   
Dim objKarte               As Shape
   
   
On Error Resume Next
   
Set objKarte = Worksheets(strBlatt).Shapes(strPic)
   
If Err.Number = 0 Then
      
With objKarte
         x = .Width / (LängengradRechtsUnten - LängengradLinksOben)
         y = .Height / (BreitengradLinksOben - BreitengradRechtsUnten)
         adblPosition(1) = .Left + x * (dblPosX - LängengradLinksOben)
         adblPosition(2) = .Top + y * (BreitengradLinksOben - dblPosY)
         PositionBerechnen = adblPosition 
      
End With
   
End If
End Function