Auswahlsatz | Excel (Autodesk/AutoCAD VBA)

Hallo,
ich habe folgendes Problem:
Ich greife von Excel aus auf acad zu um dort die blauen Polylinien (siehe Bild) die auf dem Layer Blk-Flaeche liegen mit fortlaufenden Buchstaben zu versehen und die darin befindlichen grauen Polylinien die auf dem Layer Par-Flaeche liegen mit dem Buchstaben der blauen Polylinie sowie einer fortlaufenden Nummer zu beschriften.
Um die grauen Polylinien auszuwählen versetze ich die umgrenzende blaue Polylinie, lese die Stützpunkte der versetzten Polylinie aus, füge ein Z-Wert(3.Dimension) an die einzelnen Stützpunkte hinzu und verwende diese um damit einen Auswahlsatz (acSelectionSetWindowPolygon) zu definieren (siehe Code). Leider erfasst der Auswahlsatz nicht alle grauen Polylinien (siehe Bild / rote Beschriftungen innerhalb der grauen Polylinie). Die an den Auswahlsatz übergebenen Koordinaten stimmen mit denen der Polylinie überein (x und y). Die nicht beschrifteten grauen Polylinien fehlen bereits im Auswahlsatz.
Ich hoffe, dass ich das Problem einigermaßen verständlich beschrieben habe und bin für eure Hilfe dankbar.

PS: Alles was im Code mit Block beschrieben wird hat nichts mit acad-Blöcken zu tun kommt von Häuserblock.

Public Sub NeueParzellenBlocknummernErstellen() 'erstellt neue Block und Parzellennummern

Dim FilterType(1) As Integer
Dim FilterData(1) As Variant
Dim AcSSet As AcadSelectionSet
Dim AuswahlsatzVorhanden As Boolean
Dim BoundingboxMin As Variant
Dim BoundingboxMax As Variant
Dim abc(26)
Dim Einfuegepunkt As Variant
Dim EinfuegepunktMtext(2) As Double
Dim NeuerMtext As AcadMText
Dim Textbreite As Double

abc(1) = "A"
abc(2) = "B"
abc(3) = "C"
abc(4) = "D"
abc(5) = "E"
abc(6) = "F"
abc(7) = "G"
abc(8) = "H"
abc(9) = "I"
abc(10) = "J"
abc(11) = "K"
abc(12) = "L"
abc(13) = "M"
abc(14) = "N"
abc(15) = "O"
abc(16) = "P"
abc(17) = "Q"
abc(18) = "R"
abc(19) = "S"
abc(20) = "T"
abc(21) = "U"
abc(22) = "V"
abc(23) = "W"
abc(24) = "X"
abc(25) = "Y"
abc(26) = "Z"

UFParzellenumgrenzungPruefen.ProgressBar1.Min = 0

FilterType(0) = 0
FilterData(0) = "LWPOLYLINE"
FilterType(1) = 8
FilterData(1) = "Blk-Flaeche"

AuswahlsatzVorhanden = False

Textbreite = "8"

For ialpha = 0 To ACAD.ActiveDocument.SelectionSets.Count - 1 'prüft ob der Auswahlsatz bereits vorhanden ist
If ACAD.ActiveDocument.SelectionSets.Item(ialpha).Name = "Auswahlsatz3" Then
AuswahlsatzVorhanden = True
End If
Next

If AuswahlsatzVorhanden = False Then ACAD.ActiveDocument.SelectionSets.Add ("Auswahlsatz3") 'erstellt neuen Auswahlsatz

Set AcSSet = ACAD.ActiveDocument.SelectionSets("Auswahlsatz3")
AcSSet.Clear
AcSSet.Select acSelectionSetAll, , , FilterType, FilterData 'fügt die Objekte in den Auswahlsatz ein

UFParzellenumgrenzungPruefen.ProgressBar1.Max = AcSSet.Count

For ibeta = 0 To AcSSet.Count - 1
AcSSet.Item(ibeta).Highlight (True)
AcSSet.Item(ibeta).GetBoundingBox BoundingboxMin, BoundingboxMax
ACAD.ZoomWindow BoundingboxMin, BoundingboxMax
Einfuegepunkt = SchwerpunktErmitteln_Funk(AcSSet.Item(ibeta).Handle)
EinfuegepunktMtext(0) = Einfuegepunkt(0)
EinfuegepunktMtext(1) = Einfuegepunkt(1)
Set NeuerMtext = ACAD.ActiveDocument.ModelSpace.AddMText(EinfuegepunktMtext, Textbreite, abc(ibeta + 1))
ACAD.ActiveDocument.ModelSpace.Item(ACAD.ActiveDocument.ModelSpace.Count - 1).Highlight (True)
ACAD.ActiveDocument.ModelSpace.Item(ACAD.ActiveDocument.ModelSpace.Count - 1).Height = "8"
ACAD.ActiveDocument.ModelSpace.Item(ACAD.ActiveDocument.ModelSpace.Count - 1).StyleName = "STANDARD1"
ACAD.ActiveDocument.ModelSpace.Item(ACAD.ActiveDocument.ModelSpace.Count - 1).Layer = "Blk-Nummer"
Call NeueParzellennummerErstellen(AcSSet.Item(ibeta).Handle, abc(ibeta + 1))

ACAD.ActiveDocument.Regen (acActiveViewport)
ACAD.ZoomAll
UFParzellenumgrenzungPruefen.ProgressBar1 = ibeta
UFParzellenumgrenzungPruefen.ProgressBar1.Refresh
Next

UFParzellenumgrenzungPruefen.ProgressBar1 = UFParzellenumgrenzungPruefen.ProgressBar1.Max
UFParzellenumgrenzungPruefen.ProgressBar1.Refresh

End Sub

Public Sub NeueParzellennummerErstellen(UebergabePolylinie As String, Blockbezeichnung) 'erstellt die einzelnen Parzellenbezeichnungen

Dim FilterType(1) As Integer
Dim FilterData(1) As Variant
Dim AcSSet As AcadSelectionSet
Dim AuswahlsatzVorhanden As Boolean
Dim Einfuegepunkt As Variant
Dim EinfuegepunktMtext(2) As Double
Dim NeuerMtext As AcadMText
Dim Textbreite As Double
Dim AuswahlpunkteSelection As Variant
Dim StelleEins As Integer
Dim StelleZwei As Integer
Dim polylinie As AcadObject

StelleEins = 0
StelleZwei = 0

FilterType(0) = 0
FilterData(0) = "LWPOLYLINE"
FilterType(1) = 8
FilterData(1) = "Par-Flaeche"

AuswahlsatzVorhanden = False

Textbreite = "1"

Set polylinie = ACAD.ActiveDocument.HandleToObject(UebergabePolylinie)

End Sub

Public Sub NeueParzellennummerErstellen(UebergabePolylinie As String, Blockbezeichnung) 'erstellt die einzelnen Parzellenbezeichnungen

For ialpha = 0 To ACAD.ActiveDocument.SelectionSets.Count - 1 'prüft ob der Auswahlsatz bereits vorhanden ist
If ACAD.ActiveDocument.SelectionSets.Item(ialpha).Name = "Auswahlsatz5" Then
AuswahlsatzVorhanden = True
End If
Next

If AuswahlsatzVorhanden = False Then ACAD.ActiveDocument.SelectionSets.Add ("Auswahlsatz5") 'erstellt neuen Auswahlsatz

ACAD.ActiveDocument.SendCommand ("_offset" & vbCr & "20" & vbCr & "(handent " & Chr(34) & polylinie.Handle & Chr(34) & ")" & vbCr & "10000,10000,0" & vbCr & vbCr) 'erstellt eine um 1.00 Meter versetzte Kopie der Polylinie
Application.Wait Now + TimeSerial(0, 0, 1)
AuswahlpunkteSelection = ZweiDArrayInDreiDArrayUmwandeln_Funk(ACAD.ActiveDocument.ModelSpace.Item(ACAD.ActiveDocument.ModelSpace.Count - 1).Handle) 'erstellt die Auswahlpunkte für den Selection Set
ACAD.ActiveDocument.ModelSpace.Item(ACAD.ActiveDocument.ModelSpace.Count - 1).Delete 'löscht die Polylinie

Set AcSSet = ACAD.ActiveDocument.SelectionSets("Auswahlsatz5")
AcSSet.Clear
AcSSet.SelectByPolygon acSelectionSetWindowPolygon, AuswahlpunkteSelection, FilterType, FilterData 'fügt die Objekte in den Auswahlsatz ein

For ibeta = 0 To AcSSet.Count - 1
StelleEins = StelleEins + 1
If StelleEins = 10 Then
StelleEins = 0
StelleZwei = StelleZwei + 1
End If
Einfuegepunkt = SchwerpunktErmitteln_Funk(AcSSet.Item(ibeta).Handle)
EinfuegepunktMtext(0) = Einfuegepunkt(0)
EinfuegepunktMtext(1) = Einfuegepunkt(1)
Set NeuerMtext = ACAD.ActiveDocument.ModelSpace.AddMText(EinfuegepunktMtext, Textbreite, Blockbezeichnung & StelleZwei & StelleEins)
ACAD.ActiveDocument.ModelSpace.Item(ACAD.ActiveDocument.ModelSpace.Count - 1).Highlight (True)
ACAD.ActiveDocument.ModelSpace.Item(ACAD.ActiveDocument.ModelSpace.Count - 1).Height = "3"
ACAD.ActiveDocument.ModelSpace.Item(ACAD.ActiveDocument.ModelSpace.Count - 1).StyleName = "STANDARD1"
ACAD.ActiveDocument.ModelSpace.Item(ACAD.ActiveDocument.ModelSpace.Count - 1).Layer = "Par-Nummer"
Next
End Sub

Public Function SchwerpunktErmitteln_Funk(UebergabePolylinie)

Dim polylinie As AcadObject
Set polylinie = ACAD.ActiveDocument.HandleToObject(UebergabePolylinie)
Dim Ersatzkoordinaten(1)
Dim Polyliniekoordinaten

ACAD.ActiveDocument.SendCommand ("_offset" & vbCr & "0.1" & vbCr & "(handent " & Chr(34) & polylinie.Handle & Chr(34) & ")" & vbCr & "10000,10000,0" & vbCr & vbCr) 'erstellt eine Kopie der Polylinie
ACAD.ActiveDocument.SendCommand ("_region" & vbCr & "(handent " & Chr(34) & ACAD.ActiveDocument.ModelSpace.Item(ACAD.ActiveDocument.ModelSpace.Count - 1).Handle & Chr(34) & ")" & vbCr & vbCr) 'erstellt eine region
Application.Wait Now + TimeSerial(0, 0, 1)
If ACAD.ActiveDocument.ModelSpace.Item(ACAD.ActiveDocument.ModelSpace.Count - 1).ObjectName <> "AcDbRegion" Then
Polyliniekoordinaten = polylinie.Coordinates
Ersatzkoordinaten(0) = Polyliniekoordinaten(0)
Ersatzkoordinaten(1) = Polyliniekoordinaten(1)
SchwerpunktErmitteln_Funk = Ersatzkoordinaten
Else
SchwerpunktErmitteln_Funk = ACAD.ActiveDocument.ModelSpace.Item(ACAD.ActiveDocument.ModelSpace.Count - 1).Centroid 'ermittelt den Schwerpunkt der Region
ACAD.ActiveDocument.ModelSpace.Item(ACAD.ActiveDocument.ModelSpace.Count - 1).Delete
End If

End Function

Public Function ZweiDArrayInDreiDArrayUmwandeln_Funk(UebergabePolylinie As String) 'Liefert 3d umgerechnete Stützpunktkoordinaten einer Polylinie

Dim polylinie As AcadObject
Dim AuswahlpunkteSelection As Variant
Dim KoordinatenpunktePolylinie As Variant
Set polylinie = ACAD.ActiveDocument.HandleToObject(UebergabePolylinie)

ReDim AuswahlpunkteSelection((((UBound(polylinie.Coordinates) + 1) / 2) * 3) - 1) As Double 'Dimensionierung des 3dArrays

KoordinatenpunktePolylinie = polylinie.Coordinates

ibeta = 0 'counter für 3d
igamma = 0 'counter für 2d

For ialpha = 0 To UBound(AuswahlpunkteSelection)
ibeta = ibeta + 1
If ibeta = 3 Then
AuswahlpunkteSelection(ialpha) = 0
ibeta = 0
Else
AuswahlpunkteSelection(ialpha) = Round(KoordinatenpunktePolylinie(igamma), 0)
'Round(KoordinatenpunktePolylinie(igamma), 0)
igamma = igamma + 1
End If
Next

ZweiDArrayInDreiDArrayUmwandeln_Funk = AuswahlpunkteSelection

End Function

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP