Office: Makro erzeugt Sprechblasen und soll aber Punkte setzen

Hallo liebe Leute,

ich habe eine Vorlage mit einem Makro, das Postleitzahlen in geographische Punkte auf einer Deutschlandkarte übersetzen kann. Nur sind diese Punkte leider Sprechblasen, in denen der Ortsname steht. Am besten wäre es doch, wenn die graphische Darstellung mit Punkten (kleine bis große, je nach Anzahl der dargestellten Quellwerte) erfolgen würde. Ich habe nämlich 1300 Einträge (bisher Sprechblasen)...

Kann mir einer die Sprechblasen zu Punkten machen?

Hier ist das Makro:

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

Vielen Dank im Voraus und viele Grüße
Fin

 

Hallo!

Die Art des Objektes wird hier definiert:
Set objZiel = Worksheets(strBlatt).Shapes.AddShape( _
msoShapeRoundedRectangularCallout, _
0, 0, _
100, 20)

Was es sonst noch für Shapes gibt, kannst du in der VBA-Hilfe unter "AutoShapeType" nachlesen.

 

Vielen Dank, ich habe es inzwischen mit einem RightArrow ersetzt, bin aber immer noch nicht zufrieden. Ballungszentren werden nicht so richtig deutlich... Ich schau mal weiter...