Postleitzahlen, Werte, Name, etc. in Karte darstellen

In einem vorherigen Beispiel habe ich schon einmal versucht, Geodaten auf einer Karte geografisch genau darzustellen. Mittlerweile habe ich etwas dazugelernt und die Arbeitsmappe etwas aufgepeppt. Verbessert wurde vor Allem die Positionsberechnung. Wie ich nämlich festgestellt hatte, klappte die Darstellung bei kleinen Kartenausschnitten recht gut, bei größeren Karten wurde die Abweichung von der tatsächlichen Position immer gravierender. Das liegt unter anderem daran, dass die Abstände der Längengerade nach Norden hin immer kleiner werden.

Mit den Koordinaten von 2 Ecken des Kartenmaterials kommt man dann aber nicht mehr hin, es müssen die Koordinaten aller vier Ecken angegeben werden. Dafür muss das Kartenmaterial nun nicht mehr genau nach Norden ausgerichtet sein, kleinere Abweichungen werden ausgebügelt. Genau ist die Berechnung damit aber auch noch nicht, man hat es ja schließlich immer noch mit gekrümmten Flächen zu tun, die lediglich in zwei Dimensionen dargestellt werden. Der Fehler ist aber in den meisten Fällen so gering, dass er nicht weiter auffällt. Indem man die Koordinaten der vier Ecken etwas modifiziert, kann man zudem noch einiges ausgleichen.

In der neuen Version von Excel (2007) hat sich auch etwas in Bezug auf die Standardformen geändert. Ging zuvor die Position der Pfeilspitze von der linken Ecke aus, liegt der Ursprung nun in der Mitte. Trägt man dem nicht Rechnung, zeigt die Pfeilspitze unter den verschiedenen Versionen nicht immer auf den richtigen Punkt.

Letzte Änderungen

In der neusten Version vom 05.03.2009 wurden einige kleine Änderungen an der Klasse vorgenommen.  Die Klasse enthält jetzt die neue Eigenschaft ShowStar, wird diese gesetzt, erscheinen statt Fahnen Sterne und die Anzahl der Einträge an dieser Position. In diesem Beispiel wird im Blatt Info die Zelle B11 ausgewertet, enthält diese irgendeinen Wert oder Text, wird die Klasseneigenschaft gesetzt. 

Bei einer Änderung habe ich festgestellt, dass unter Versionen vor Excel 2007 der Blattschutz im Blatt Info nicht die Einstellungen von Excel 2007 hatte. Es konnten  die Formate in Zelle B7 nicht gesetzt werden. In diesem Fall sollte der Blattschutz aufgehoben und angepasst werden.

Anfang August 2009 habe ich aufgrund einer Anfrage die Klasse etwas erweitert. Die Klasse enthält jetzt die neue Eigenschaft HeightFaktor. Nun kann die Größe der Sterne von der Anzahl der Werte pro Postleitzahl abhängig gemacht werden. 

Dabei habe ich außerdem festgestellt, dass M$ einen Fehler im Objektmodell von Excel 2007 behoben hat.  Diese Korrektur hat aber nun bewirkt, dass meine Klasse nicht mehr funktioniert hat, was nun behoben ist.

Der angesprochene Fehler wurde in meiner Klasse ursprünglich folgendermaßen korrigiert.

' Objekt Zielblatt wird erstellt
If Application.Version = "12.0" Then
Set mwsDestSheet = Worksheets(mobjMap.Parent.Parent.Name)
Else
Set mwsDestSheet = Worksheets(mobjMap.Parent.Name)
End If

Wie man sieht, war unter Excel 2007 das Elternobjekt des übergebenen Bildobjekts nicht die Arbeitsmappe, sondern erst dessen Elternobjekt (Parent.Parent). Durch die unterschiedliche Behandlung  je nach Version wurde das ausgebügelt. Neuerdings ist allerdings wieder das Elternobjekt des übergebenen Bildobjekts die Arbeitsmappe, so dass das zugehörige Arbeitsblatt jetzt unter XL 2007 nicht gefunden wird. So sieht nun der Würgaround aus, da man nicht sicher sein kann, dass überall alle Updates installiert sind.

' Objekt Zielblatt wird erstellt
If Application.Version = "12.0" Then
Set mwsDestSheet = Worksheets(mobjMap.Parent.Parent.Name)
      If mwsDestSheet Is Nothing Then
Set mwsDestSheet = Worksheets(mobjMap.Parent.Name)
   End If
Else
Set mwsDestSheet = Worksheets(mobjMap.Parent.Name)
End If

Angemerkt wurde von einem Benutzer dieser Mappe, dass eine Stadt mehrere Postleitzahlen mit leicht unterschiedlichen Koordinaten enthalten kann und diese sich dann überlappen können. Nun, das ist tatsächlich so!

Eine Abhilfe bietet sich möglicherweise, indem man im Blatt Plz die Liste bearbeitet und für eine Stadt nur die niedrigste Postleitzahl stehen lässt. Ich habe im Blatt Infos SVERWEIS den letzten Parameter auf WAHR gesetzt, laut OH müsste dann die nächstniedrigere gefunden werden, wenn sie in der aufsteigend sortierten Liste nicht vorkommt.

Aus der OH:
Bereich_Verweis
Ein Wahrheitswert, der angibt, ob SVERWEIS eine genaue Entsprechung oder eine ungefähre Entsprechung suchen soll.
Wenn dieser Parameter WAHR oder nicht belegt ist, wird eine genaue oder ungefähre Entsprechung zurückgegeben. Wenn keine genaue Entsprechung gefunden wird, wird der nächstgrößere Wert zurückgegeben, der kleiner als Suchkriterium ist.
Die Werte in der ersten Spalte von Matrix müssen in aufsteigender Sortierreihenfolge geordnet sein, andernfalls gibt SVERWEIS möglicherweise nicht den richtigen Wert zurück. Weitere Informationen finden Sie unter Sortieren von Daten.
Ist der Parameter FALSCH, sucht SVERWEIS nur eine genaue Entsprechung. In diesem Fall müssen die Werte in der ersten Spalte von Matrix nicht sortiert werden. Wenn in der ersten Spalte von Matrix mindestens zwei Werte vorhanden sind, die dem Suchkriterium entsprechen, wird der erste gefundene Wert verwendet. Wenn keine genaue Entsprechung gefunden wird, wird der Fehlerwert #N/A zurückgegeben. 

Schnellübersicht

Das folgende Bild zeigt das Eingabeblatt. Die auf der Karte anzuzeigenden Fahnen können auf vielfältige Weise an die eigenen Wünsche angepasst werden. Zudem kann festgelegt werden, ob in der Fahne ein Text oder die Summe der Objekte gleicher Position erscheinen soll. Wird Text ausgewählt, wird bei mehreren Objekten auf der gleichen Position eine mehrzeilige Fahne mit dem gesamten Text der Einzelfahnen ausgegeben.

Die Zellen B2 bis E3 nehmen die vier Kartenkoordinaten auf.
In die Zelle B4 wird der Blattname eingegeben, auf dem sich die Karte befindet und in B5 kommt der eigentliche Kartenname. Möchte man eine eigene Karte verwenden, muss der Kartenname angepasst werden. Dazu wird in dem Namenfeld, in dem normalerweise die Zelladressen der aktiven Zelle erscheint ( über der Tabelle, links neben dem Eingabefeld) ein Name eingegeben und mit der Return-Taste bestätigt.

In B6 wird die Transparenz eingegeben (0-1).
Die Zelle B7 wird so formatiert, wie nachher die Fahne oder der Stern aussehen soll.
Gesetzt werden kann die Hintergrundfarbe, die Schriftfarbe, die Texteigenschaften wie Größe, Kursiv, unterstrichen und Fett.

In Zelle B8 gibt man einen Faktor ein. Mit diesem Faktor wird die Normalhöhe und -breite eines Sterns multipliziert, dieser Wert wird dann mit der Anzahl der
PLZ auf dieser Position (Minus 1) multipiziert und das Ergebnis zur Normalhöhe (Breite) addiert.
Bei 2 Werten, einer Normalhöhe von 20 und einem Faktor von 0,1 wird die Höhe  und die Breite also auf 22, bei 3 Werten auf 24 usw. gesetzt. Eine Eingabe von Null in B8 ändert die Größe also gar nicht.

Die Werte in B9, C9, D9 legen die Größe der Fahne oder des Sterns in Prozent der Kartenbreite fest. Für einen Stern wird nur die Höhe ausgewertet, da die Höhe und Breite in dem Fall gleich sind.
In B10 wird die Rahmendicke der Form eingegeben.
Steht irgendein Text in der Zelle B11, wird in der Fahne der Text dargestellt, welcher sich im gelben Bereich in Spalte F befindet. Andernfalls steht in der Form eine Zahl, welche die Anzahl der Einträge pro PLZ angibt.
Steht irgendein Text in der Zelle B12, wird statt einer Fahne ein Stern mit der Anzahl der Einträge pro PLZ angegeben.
In den gelben Bereich kommen die Postleitzahlen, in die Spalte F der Text, welcher in den Fahnen erscheinen soll.

Folgendermaßen sieht das Ergebnis aus, die verwendete Karte ist übrigens Public Domain, kann also frei verwendet werden:

Auch bei diesem Beispiel gilt, dass man den Code frei benutzen kann. Eine Veröffentlichung des Codes oder Teilen davon, womöglich noch unter anderem Namen, sollte aber unterbleiben.

Excel-Dateien zum Download ca. 2300 KB: KarteUndSternGroesse.xlsm oder KarteUndSternGroesse.xls

Das Klassenmodul des Tabellenblatts Infos

Ein Klick auf die Schaltfläche cmdAddItems löst die entsprechende Ereignisprozedur aus.

Zu Beginn wird ein Objekt der Klasse clsGeo erzeugt. Aus dem Tabellenblatt werden verschiedene Einstellungen ausgelesen und an Eigenschaftsprozeduren der Klasse übergeben. Darunter sind auch die Koordinaten der vier Eckpunkte der Karte, der Name und das Blatt, auf dem sich die Karte befindet.

An die Methode AddItem der Klasse übergibt man den Längengrad, Breitengrad und die Beschriftung eines darzustellenden Objektes. Sollen mehrere Objekte dargestellt werden, wird die Methode mehrmals aufgerufen. Der Aufruf der Methode InsertItems stellt die Objekte schließlich auf der Karte dar.

Option Explicit

Private Sub cmdAddItems_Click()
Dim i       As Long
Dim objGeo  As New clsGeo

With objGeo

' Längengrad Karte links unten
      .LonLeftBotton = Me.Range("B2")
' Breitengrad Karte links unten
      .LatLeftBotton = Me.Range("B3")

' Längengrad Karte rechts unten
      .LonRightBotton = Me.Range("C2")
' Breitengrad Karte rechts unten
      .LatRightBotton = Me.Range("C3")

' Längengrad Karte links oben
      .LonLeftTop = Me.Range("E2")
' Breitengrad Karte links oben
      .LatLeftTop = Me.Range("E3")

' Längengrad Karte rechts oben
      .LonRightTop = Me.Range("D2")
' Breitengrad Karte rechts oben
      .LatRightTop = Me.Range("D3")

' Transparenz der Fahnen (optional)
      .Transparency = Me.Range("B6")

' Rahmendicke
      .BorderWeight = Me.Range("B9")

' Farbe der Fahnen (optional)
      .BackColor = Me.Range("B7").Interior.Color 'RGB(255, 0, 0)

' Farbe des Textes (optional)
      .TextColor = Me.Range("B7").Font.Color

' Textgröße (optional)
      .TextSize = Me.Range("B7").Font.Size

' Text Fett (optional)
      .TextBold = Me.Range("B7").Font.Bold

' Text Kursiv (optional)
      .TextItalic = Me.Range("B7").Font.Italic

' Text Unterstrichen (optional)
      .TextUnderline = Me.Range("B7").Font.Underline

' Höhe der Fahne in Prozent der Kartenhöhe (optional)
      .HeightPercent = Me.Range("B8")

' Breite der Fahne in Prozent der Kartenbreite (optional)
      .WidthPercent = Me.Range("C8")

' Höhe der Pfeilspitze in Prozent der Kartenhöhe (optional)
      .HeightArrowPercent = Me.Range("D8")

' Shapeobjekt übergeben (Tabellenblattname
' und Name der Karte aus dem Blatt)
      .Map = Worksheets(CStr(Me.Range("B4"))).Shapes( _
CStr(Me.Range("B5")))

' Text statt Anzahl anzeigen
      .ShowText = (Me.Range("B10") <> "")

For i = 13 To 5000
If Me.Cells(i, 1) <> "" Then
' Darzustellende Koordinate hinzufügen
' Längengrad, Breitengrad, Beschriftung
            .AddItem Me.Cells(i, 2), Me.Cells(i, 3), Me.Cells(i, 5)
End If
Next

' Daten anzeigen
      .InsertItems

End With

End Sub

Das Klassenmodul clsGeo

Die Klasse clsGeo übernimmt die eigentliche Arbeit des Berechnens, Erzeugens der Fahnen und der Darstellung auf dem Tabellenblatt.

Option Explicit
Private mcolData                    As New Collection
Private mobjMap                     As Shape
Private mwsDestSheet                As Worksheet
Private mstrMap                     As String
Private mdblLonLeftBotton           As Double
Private mdblLatLeftBotton           As Double
Private mdblLonRightBotton          As Double
Private mdblLatRightBotton          As Double
Private mdblLonLeftTop              As Double
Private mdblLatLeftTop              As Double
Private mdblLonRightTop             As Double
Private mdblLatRightTop             As Double
Private mdblWidth                   As Double
Private mdblHeight                  As Double
Private mdblHeightArrow             As Double
Private mdblTransparency            As Double
Private mlngTextColor               As Long
Private mlngTextSize                As Long
Private mlngColor                   As Long
Private mlngBorderWeight            As Long
Private mblnShowCount               As Boolean
Private mblnShowText                As Boolean
Private mblnTextBold                As Boolean
Private mblnTextItalic              As Boolean
Private mlngTextUnderline           As Long
Private Const Pi                    As Double = 3.1415826


Public Property Let Map(ByVal vNewValue As Shape)
' Die Karte wird als Shape-Objekt übergeben
' Das stellt sicher, dass ein solcher Objekt
' existiert
On Error Resume Next

' Zielobjekt in Variable speichern
Set mobjMap = vNewValue

' Objekt Zielblatt wird erstellt
If Application.Version = "12.0" Then
Set mwsDestSheet = Worksheets(mobjMap.Parent.Parent.Name)
Else
Set mwsDestSheet = Worksheets(mobjMap.Parent.Name)
End If

' Der Name des Zielobjektes wird ermittelt
   mstrMap = mobjMap.Name

End Property

Public Function InsertItems() As Boolean
Dim varDummy      As Variant
Dim varPos        As Variant
Dim objZiel       As Shape
Dim strName       As String
Dim strDummy      As String
Dim x             As Double
Dim y             As Double
Dim lngCount      As Long
Dim dblZeilen     As Double
Dim dblArrow      As Double
Dim objDummy      As Object
On Error Resume Next

' Abbrechen, wenn nicht genügend Infos vorhanden
If mcolData.Count = 0 Then Exit Function
If mobjMap Is Nothing Then Exit Function
If mdblLonLeftBotton = mdblLatLeftBotton Then Exit Function
If mdblLonRightBotton = mdblLatRightBotton Then Exit Function
If mdblLonLeftTop = mdblLatLeftTop Then Exit Function
If mdblLonRightTop = mdblLatRightTop Then Exit Function

' Alle Shape-Objekte im Zielblatt löschen,
' außer das karten-Objekt
For Each objZiel In mwsDestSheet.Shapes
If objZiel.Name <> mstrMap Then objZiel.Delete
Next

' Alle Elemente der Daten-Collection durchlaufen
For Each varDummy In mcolData


' Längen- und Breitengrad aus der Collection holen
      x = varDummy(1)
      y = varDummy(2)

If x <> 0 And y <> 0 Then ' Daten vorhanden

' Die Position auf dem Blatt berechnen
         varPos = PositionBerechnen(x, y)

' Namen aus der X- und Y-Position erzeugen
         strName = "X" & _
            Format(varPos(1), "0.000") & _
            Format(varPos(2), "0.000")

         Err.Clear

' Überprüfen, ob ein Shape an der gleichen Position,
' also mit gleichem Namen bereits vorhanden ist
Set objZiel = mwsDestSheet.Shapes(strName)

If Err.Number <> 0 Then

' Bei einem Fehler ist das Shape noch nicht
' vorhanden. Dann Shape erzeugen.

Set objZiel = mwsDestSheet.Shapes.AddShape( _
               msoShapeRoundedRectangularCallout, _
               0, 0, mdblWidth, mdblHeight)

' Namen für das Shape vergeben, der sich aus der
' Position zusammensetzt
            objZiel.Name = strName

End If

With objZiel

strDummy = ""
            strDummy = .TextFrame.Characters.Text

            lngCount = 0

If mblnShowCount Then
               lngCount = CLng(strDummy)
               lngCount = lngCount + 1
               .TextFrame.Characters.Text = lngCount

' Höhe anpassen
               .Height = mdblHeight * (mobjMap.Height / 100)

Else
If strDummy = "" Then
                  .TextFrame.Characters.Text = varDummy(3)
Else
                  .TextFrame.Characters.Text = strDummy & vbLf & varDummy(3)
End If

' Anzahl der Zeilen ermitteln
               dblZeilen = Abs(strDummy <> "") + (Len(strDummy) - _
                  Len(Replace(strDummy, vbLf, ""))) + 1

' Höhe an die Anzahl der Zeilen anpassen
               .Height = mdblHeight * (mobjMap.Height / 100) * dblZeilen

End If

' Breite anpassen
            .Width = mdblWidth * (mobjMap.Width / 100)

' Position Fahne setzen
            .Left = varPos(1)

' Länge Pfeil berechnen
            dblArrow = (mdblHeightArrow * (mobjMap.Height / 100))

            .Top = varPos(2) - .Height - dblArrow ' mal Höhe nach oben

If Application.Version = "12.0" Then

' Pfeil von Mitte Form nach Links (Minus), 0,5 mal Breite
               .DrawingObject.ShapeRange.Adjustments.Item(1) = -0.5

' Pfeil von Mitte Form nach unten (Plus).
' Angaben als Faktor der Höhe
               .DrawingObject.ShapeRange.Adjustments.Item(2) = dblArrow / .Height + 0.5

Else
' Pfeil von linkem Rand nach Links, 0 mal Breite
               .DrawingObject.ShapeRange.Adjustments.Item(1) = 0
' Pfeil von oberem Rand nach unten (Plus).
' Angaben als Faktor der Höhe
               .DrawingObject.ShapeRange.Adjustments.Item(2) = dblArrow / .Height + 1

End If

' Texteigenschaften anpassen
            .DrawingObject.Font.Size = mlngTextSize
            .DrawingObject.Font.Color = mlngTextColor
            .DrawingObject.Font.Bold = mblnTextBold
            .DrawingObject.Font.Italic = mblnTextItalic
            .DrawingObject.Font.Underline = mlngTextUnderline

' Textabstand zum Rand
            .TextFrame.MarginLeft = 0
            .TextFrame.MarginRight = 0
            .TextFrame.MarginTop = 0
            .TextFrame.MarginBottom = 0

' Füllung anpassen
            .DrawingObject.ShapeRange.Fill.ForeColor.RGB = mlngColor
            .DrawingObject.ShapeRange.Fill.Transparency = mdblTransparency

' Rahmen anpassen
            .DrawingObject.Border.Color = mlngColor
If mlngBorderWeight = 0 Then
' Kein Rahmen
               .DrawingObject.Border.LineStyle = -4142
Else
               .DrawingObject.Border.LineStyle = 1
               .DrawingObject.Border.Weight = mlngBorderWeight
End If
End With
End If
Next

End Function

Private Function PositionBerechnen( _
   dblPosX As Double, dblPosY As Double _
   ) As Variant
Dim dblHeight                 As Double
Dim dblWidth                  As Double
Dim dblFactorX(1 To 2)        As Double
Dim dblFactorY(1 To 2)        As Double
Dim adblPosX(1 To 2)          As Double
Dim adblPosY(1 To 2)          As Double
Dim adblPosition(1 To 2)      As Double
Dim dblLonDegree              As Double
Dim dblLatDegree              As Double
Dim dblDummy                  As Double
Dim dblA                      As Double
Dim dblB                      As Double
Dim dblC                      As Double
Dim dblLenLat                 As Double
Dim dblLenLon                 As Double
Dim dblLenLatLon              As Double
Dim dblPosDestX               As Double
Dim dblPosDestY               As Double

On Error Resume Next

' Bildgröße
With mobjMap
      dblWidth = .Width
      dblHeight = .Height
End With

' Faktor zum umrechnen (X-Achse)
   dblFactorX(1) = dblWidth / (mdblLonRightBotton - mdblLonLeftBotton)
   dblFactorX(2) = dblWidth / (mdblLonRightTop - mdblLonLeftTop)

' Faktor zum umrechnen (Y-Achse)
   dblFactorY(1) = dblHeight / (mdblLatLeftTop - mdblLatLeftBotton)
   dblFactorY(2) = dblHeight / (mdblLatRightTop - mdblLatRightBotton)


' Position Längengrad auf oberer X-Achse berechnen
   adblPosX(1) = (dblPosX - mdblLonLeftTop) * dblFactorX(2)
' Position Längengrad auf unterer X-Achse berechnen
   adblPosX(2) = (dblPosX - mdblLonLeftBotton) * dblFactorX(1)

' Position Breitengrad auf linker Y-Achse berechnen
   adblPosY(1) = (dblPosY - mdblLatLeftBotton) * dblFactorY(1)
' Position Breitengrad auf rechter Y-Achse berechnen
   adblPosY(2) = (dblPosY - mdblLatRightBotton) * dblFactorY(2)

' Winkel Längengrad X-Achse oben berechnen
   dblLonDegree = Atn(dblHeight / (adblPosX(1) - adblPosX(2) + 0.00001))

' Winkel Breitengrad Y-Achse links berechnen
   dblLatDegree = Atn(dblWidth / (adblPosY(2) - adblPosY(1) + 0.00001))

' Winkel Verbindung Längengrad X-Achse oben -
' Breitengrad Y-Achse links
   dblDummy = Atn(adblPosX(1) / (dblHeight - adblPosY(1)))

' Länge Verbindung Längengrad Links-Breitengrad oben
   dblLenLatLon = adblPosX(1) / Sin(dblDummy)

' Winkel virtuelles Dreieck für Sinussatz
   dblA = dblLatDegree - dblDummy
   dblC = dblLonDegree - (Pi / 2 - dblDummy)
   dblB = Pi - dblA - dblC

' Länge Zeiger Längengrad berechnen
   dblLenLon = (Sin(dblA) * dblLenLatLon) / Sin(dblB)
' Zielposition berechnen
   dblPosDestX = adblPosX(1) - Cos(dblLonDegree) * dblLenLon
   dblPosDestY = Sin(dblLonDegree) * dblLenLon

' Länge Zeiger Breitengrad berechnen
   dblLenLat = (Sin(dblC) * dblLenLatLon) / Sin(dblB)
' Zielposition berechnen
   dblPosDestX = Cos(Pi / 2 - dblLatDegree) * dblLenLat
   dblPosDestY = dblHeight - adblPosY(1) - Sin(Pi / 2 - dblLatDegree) * dblLenLat

With mobjMap
      dblPosDestX = dblPosDestX + .Left
      dblPosDestY = dblPosDestY + .Top
End With

' Ergebnis zurückgeben
   adblPosition(1) = dblPosDestX
   adblPosition(2) = dblPosDestY
   PositionBerechnen = adblPosition

End Function

Public Sub AddItem(Lon As Double, Lat As Double, Text As String)
' Neuer darzustellender Wert in Collection einfügen
On Error Resume Next
Dim avarDummy(1 To 3)   As Variant
   avarDummy(1) = Lon
   avarDummy(2) = Lat
   avarDummy(3) = Text
   mcolData.Add avarDummy
End Sub

Public Sub ClearItems()
' Die Collection zurücksetzen
Set mcolData = New Collection
End Sub

' Koordinaten der Kartengrenzen entgegennehmmen
Public Property Let LonLeftBotton(ByVal vNewValue As Double)
   mdblLonLeftBotton = vNewValue
End Property
Public Property Let LatLeftBotton(ByVal vNewValue As Double)
   mdblLatLeftBotton = vNewValue
End Property
Public Property Let LonRightBotton(ByVal vNewValue As Double)
   mdblLonRightBotton = vNewValue
End Property
Public Property Let LatRightBotton(ByVal vNewValue As Double)
   mdblLatRightBotton = vNewValue
End Property
Public Property Let LonLeftTop(ByVal vNewValue As Double)
   mdblLonLeftTop = vNewValue
End Property
Public Property Let LatLeftTop(ByVal vNewValue As Double)
   mdblLatLeftTop = vNewValue
End Property
Public Property Let LonRightTop(ByVal vNewValue As Double)
   mdblLonRightTop = vNewValue
End Property
Public Property Let LatRightTop(ByVal vNewValue As Double)
   mdblLatRightTop = vNewValue
End Property

Public Property Let ShowCount(ByVal vNewValue As Boolean)
' Anzahl ausgeben
   mblnShowCount = vNewValue
   mblnShowText = Not vNewValue
End Property
Public Property Let ShowText(ByVal vNewValue As Boolean)
' Text, beispielsweise Namen ausgeben
' Für jedes Element mit den gleichen Koordinaten
' eine eigene Zeile
   mblnShowText = vNewValue
   mblnShowCount = Not vNewValue
End Property
Public Property Let BorderWeight(ByVal vNewValue As Long)
' Rahmendicke
   mlngBorderWeight = vNewValue
End Property
Public Property Let TextSize(ByVal vNewValue As Long)
' Textgröße
   mlngTextSize = vNewValue
End Property
Public Property Let TextBold(ByVal vNewValue As Boolean)
' Text Fett
   mblnTextBold = vNewValue
End Property
Public Property Let TextItalic(ByVal vNewValue As Boolean)
' Text Kursiv
   mblnTextItalic = vNewValue
End Property
Public Property Let TextUnderline(ByVal vNewValue As XlUnderlineStyle)
' Text unterstrichen
   mlngTextUnderline = vNewValue
End Property
Public Property Let TextColor(ByVal vNewValue As Long)
' Textfarbe als RGB-Wert
   mlngTextColor = vNewValue
End Property
Public Property Let BackColor(ByVal vNewValue As Long)
' Farbe Hintergrund
   mlngColor = vNewValue
End Property
Public Property Let Transparency(ByVal vNewValue As Double)
' Transparenz (0=Undurchsichtig, 1=Transparent)
   mdblTransparency = vNewValue
End Property
Public Property Let HeightArrowPercent(ByVal vNewValue As Double)
' Pfeilspitze in Prozent von Kartenhöhe
If (vNewValue < 0) Or (vNewValue > 100) Then Exit Property
   mdblHeightArrow = vNewValue
End Property
Public Property Let WidthPercent(ByVal vNewValue As Double)
' Fahnenbreite in Prozent von Kartenbreite
If (vNewValue < 0) Or (vNewValue > 100) Then Exit Property
   mdblWidth = vNewValue
End Property
Public Property Let HeightPercent(ByVal vNewValue As Double)
' Fahnenhöhe in Prozent von Kartenhöhe
If (vNewValue < 0) Or (vNewValue > 100) Then Exit Property
   mdblHeight = vNewValue
End Property

Private Sub Class_Initialize()
' Defaultwerte festlegen
   mdblWidth = 10
   mdblHeight = 1.5
   mdblHeightArrow = 1.5
   mlngTextColor = 0
   mlngColor = RGB(255, 0, 0)
   mlngTextSize = 5
   mlngBorderWeight = 4
   mblnShowCount = True
   mlngTextUnderline = xlUnderlineStyleNone
End Sub

Die Prozedur InsertItems

Wird die Prozedur InsertItems aufgerufen, werden die darzustellenden Objekte angelegt und auf dem Zieltabellenblatt an der (hoffentlich) richtigen Position dargestellt.

Zu Beginn werden auf dem Zielblatt alle vorhandenen Shapes gelöscht, deren Namen nicht mit dem der Karte übereinstimmt. Nun werden alle Elemente der klassenweit gültigen Collection durchlaufen, jedes Element darin entspricht einem darstellbaren Objekt. Mit Hilfe der Prozedur PositionBerechnen errechnet man nun die absolute Position des Objektes.

Damit später an der gleichen Position nicht zwei oder mehrere Fahnen erscheinen, muss aus jeder Position ein eindeutiger und reproduzierbarer Name erzeugt werden. Mit Hilfe dieses Namens kann man feststellen, ob bereits ein Objekt mit diesem Namen existiert.

Existiert es, wird entweder die sich als Text darin befindliche Zahl um 1 erhöht, oder es wird die Höhe angepasst und in einer neuen Zeile der neue Text zum Alten hinzugefügt. Die Variable mblnShowCount entscheidet darüber, welche von beiden Aktionen durchgeführt wird. Existiert noch kein Objekt, wird es angelegt. Auch hier entscheidet die Variable mblnShowCount darüber, ob die Zahl 1 oder der Text eingefügt wird.

Nun wird die Breite, Höhe, Länge des Pfeils und die Position der Fahne gesetzt. Damit der Pfeil auch auf die richtige Position zeigt, ist die Office-Version entscheidend. Bei der aktuellen Version 2007 werden die Werte von der Mitte Form nach links und nach unten angegeben, bei anderen Versionen geht man als Ursprung von links oben aus.

Anschließend setzt man die Text, Hintergrund- und Rahmeneigenschaften.

Die Prozedur PositionBerechnen

Der Prozedur PositionBerechnen werden als Argumente zum Einen der Längen- und zum Anderen der Breitengrad des darzustellenden Objektes jeweils als Dezimalzahl übergeben.

Die Abmessungen und die Position des Bildes stehen ja bereits fest, ebenso die Koordinaten aller vier Eckpunkte. Die Schwierigkeit besteht nun darin, die Position des darzustellenden Objektes auf dem Tabellenblatt in der Maßeinheit Punkt zu finden. Das ist leichter gesagt als getan, denn ein Längengrad in einer nach Norden ausgerichteten Karte schneidet die X-Achse oben und unten an unterschiedlichen Positionen. Ist die Karte nicht exakt nach Norden ausgerichtet, schneidet auch ein Breitengrad die Y-Achse links und rechts an unterschiedlichen Stellen.

Für die weitere Betrachtung wird der Einfachheit halber angenommen, dass die virtuellen Verbindungslinien (Isobaren) der Längen- bzw. Breitengrade gradlinig verlaufen. Die Realität sieht zwar etwas anders aus, die dadurch entstehenden Fehler werden aber bewusst in Kauf genommen.

Das folgende Bild stellt die Lage schematisch dar, der Übersichtlichkeit halber aber etwas überzogen:

Der Punkt B auf dem Dreieck A-B-C mit den Seiten a, b, c und den Winkeln Alpha, Beta, Gamma stellt den gesuchten Punkt dar.

Bekannt ist die Differenz des Objektlängengrades zwischen dem oberen und unteren Ende der Karte, ebenso die Differenz des Objektbreitengrades zwischen dem linken und rechten Ende. Mit Hilfe der Kartenbreite und –höhe  und der trigonometrischen Funktion Sinus kann man die Winkel der Zeiger zur Horizontalen, bzw. Vertikalen (violettes Dreieck, Winkel 2) berechnen.

Da zwei Seiten des blauen, rechtwinkligen Dreiecks bekannt sind, kann man auch dessen Winkel und die Hypotenuse berechnen. Nun hat man genug Informationen, um auch die Winkel Alpha, Beta und Gamma des Dreiecks A-B-C auszurechnen. Nun kommt der Sinussatz (sin(Alpha)/a = sin(Beta)/b = sin(Gamma)/c) zum Einsatz, mit dessen Hilfe man die zwei Zeiger in Richtung auf den Punkt B berechnen kann. Mit dem Winkel eines Zeigers und dessen Länge kann man nun die relative Position zum Punkt A bzw. B ausrechnen.  Zur Berechnung der absoluten Position wird auch noch die Position der Karte auf dem Tabellenblatt einbezogen.

Die Initialisierungsroutine Class_Initialize

Diese Prozedur wird beim Erzeugen der Klasse abgearbeitet und belegt einige Klassenweit gültige Variablen mit frei wählbaren Standardwerten. Das ist wichtig, da das Setzen der meisten Klasseneigenschaften von außen optional ist.

Die Eigenschaftsprozeduren HeightPercent und WidthPercent

Durch das Setzen dieser Eigenschaften wird die Breite und Höhe des Textfeldes einer Fahne in Prozent von der Kartenbreite- und höhe festgelegt.

Die Eigenschaftsprozedur HeightArrowPercent

Durch das Setzen dieser Eigenschaften wird die Länge der Pfeilspitze in Prozent der Kartenhöhe festgelegt.

Die Eigenschaftsprozeduren Transparency, BackColor, TextColor, TextUnderline, TextItalic, TextBold, TextSize, BorderWeight

Durch das Setzen dieser Eigenschaften werden Eigenschaften der Fahne festgelegt.

Transparency ist ein Wert zwischen 0 und 1, wobei 0=Undurchsichtig und 1=Transparent ist. Back- und Textcolor sind RGB-Werte, welche die Hintergrund- und Textfarbe beschreiben. TextItalic und TextBold nehmen Wahrheitswerte auf, welche darüber bestimmen, ob der Text Fett und/oder Kursiv dargestellt wird. TextUnderline nimmt einen Wert der Aufzählung (Enum) XlUnderlineStyle auf und bestimmt die Form des Unterstreichens. Die Eigenschaften TextSize bestimmt die Textgröße und BorderWidth die Breite des Rahmens.

Die Eigenschaftsprozedur ShowText

Durch das Setzen dieser Eigenschaften wird festgelegt, dass statt der Anzahl der Einträge pro Position der Text angezeigt wird.

Die Eigenschaftsprozedur ShowCount

Durch das Setzen dieser Eigenschaften wird festgelegt, dass statt Text die Anzahl der Einträge pro Position angezeigt werden.

Die Eigenschaftsprozeduren LonLeftBotton, LatLeftBotton, LonRightBotton, LatRightBotton, LonLeftTop, LatLeftTop, LonRightTop, LatRightTop

Durch das Setzen dieser Eigenschaften werden die Koordinaten der 4 Ecken der Karte festgelegt. Lon steht für Längengrad (Longitude), Lat für Breitengrad (Latitude), Botton für unten, Top für oben, left für links und right für rechts.

Die Methode AddItem

Diese Methode erwartet als Argument den Längen- und Breitengrad, sowie den Text eines darzustellenden Objekts. Bei jedem Aufruf dieser Methode erfolgt ein neuer Eintrag in einer modulweit gültigen Collection, welcher die relevanten Informationen enthält.

Die Methode ClearItems

Durch das Ausführen dieser Methode werden alle bereits übergebenen Objekte, die dargestellt werden sollen, gelöscht.

Die Eigenschaftsprozedur Map

Diese Eigenschaft nimmt ein Kartenobjekt als Shape-Objekt entgegen. Über die Parent-Eigenschaft des Objektes wird das zugehörige Tabellenblatt ermittelt und als Objekt in einer klassenweit gültigen Variablen gespeichert. Außerdem wird der Name des Objektes ausgelesen und in einer weiteren Variablen gespeichert.