Postleitzahlen in Karte (old)

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 x 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