Code:
Option Explicit On' ###################################################################################################
' # #
' # Methoden um anhand einer Messungslinie orthogonale Punkte zu konstruieren #
' # Der Benutzer kann auswählen ob die orthogonalen Punkte die anhand von Abszisse und Ordinate #
' # eingegeben werden durch Punkte, Kreise oder Linienverbindungen dargestellt werden sollen #
' # #
' # Funktionen #
' # - createIntersectionWithPolyline() #
' # #
' # - setLastPunktNr() As Exception #
' # #
' # Stand: 02.03.2009 #
' ###################################################################################################
Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.EditorInput
Imports Autodesk.AutoCAD.Geometry
Imports Autodesk.AutoCAD.Runtime
' Verringern der Ladezeit beim Kompilieren
<Assembly: CommandClass(GetType(LaOs_AutoCAD_Werkzeuge.SmallTools.createIntersectionWithPolyline))>
Namespace LaOs_AutoCAD_Werkzeuge.SmallTools
Module createIntersectionWithPolyline
' Konstante für den Blocknamen der für die konstruierten Punkte verwendet wird
Private Const BLOCKNAME As String = "4440"
' Variable für die nächste freie Punktnummer
Dim lastPunktNR As Long = Nothing
' Variable ob Höhen bzw. welche Höhen exportiert werden sollen - Vorgabe: exportHeightModes.BlockattributHoehen
Dim heightMode As exportHeightModes = exportHeightModes.BlockattributHoehen
' Aufruf der Methode über 'createIntersectionWithPolyline' möglich
' Methode um die Höhen von Blöcken auf eine Polylinie zu übertragen
' - Prüfen ob die Blockdefinition für die konstruierten Punkte existiert
' - Bestimmen der letzten verwendeten Punktnummer
' - Auswahl der Polylinie und des Höhenmoduses
' - Endlosschleife zur Auswahl der Blöcke für die Schnittberechnung
<CommandMethod("createIntersectionWithPolyline")> _
Public Sub createIntersectionWithPolyline()
Dim editor As Editor = Application.DocumentManager.MdiActiveDocument.Editor
'---------------------------------------------------------------
' Prüfen ob die Blockdefinition für die konstruierten Punkte existiert
'---------------------------------------------------------------
If Not (LaOs_AutoCAD_Werkzeuge.Functions.checkBlockExistence(BLOCKNAME)) Then
editor.WriteMessage(ControlChars.CrLf & "Keine Blockdefinition für den Block '" & BLOCKNAME & "' gefunden" & ControlChars.CrLf & "Bitte legen Sie ihn vor dem Neustart des Programmes an")
' Beenden der Methode
Exit Sub
End If
'---------------------------------------------------------------
' Bestimmen der letzten verwendeten Punktnummer
'---------------------------------------------------------------
Dim exception As Exception = setLastPunktNr()
' Fehler beim Bestimmen der letzten verwendeten Punktnummer
If Not IsNothing(exception) Then
editor.WriteMessage(ControlChars.CrLf & "Fehler beim Bestimmen der letzten verwendeten Punktnummer" & ControlChars.CrLf & exception.Message & ControlChars.CrLf & "Funktion: setLastPunktNr() As Exception")
' Beenden der Methode
Exit Sub
' Wenn keine Punktnummer im Bereich bis 91000 mehr frei ist
ElseIf (lastPunktNR = 90999) Then
editor.WriteMessage(ControlChars.CrLf & "Keine freie Punktnummer mehr verfügbar" & ControlChars.CrLf & "Alle Punktnummern im Bereich 90001 bis 90999 bereits vergeben")
' Beenden der Methode
Exit Sub
End If
'---------------------------------------------------------------
' Auswahl der Polylinie
'---------------------------------------------------------------
' Polylinien auch auf gesperrten Layern
Dim getPolylineOptions As New PromptEntityOptions(ControlChars.CrLf & "Bitte die Polylinie auswählen: ")
getPolylineOptions.SetRejectMessage(ControlChars.CrLf & "Es sind nur Polylinien erlaubt")
' Alle 3 Typen von unterstützten Polylinien
getPolylineOptions.AddAllowedClass(GetType(Polyline), False)
getPolylineOptions.AddAllowedClass(GetType(Polyline2d), False)
getPolylineOptions.AddAllowedClass(GetType(Polyline3d), False)
getPolylineOptions.AllowObjectOnLockedLayer = True
' Auswahl der Polylinie durch den Benutzer
Dim getPolylineResult As PromptEntityResult = editor.GetEntity(getPolylineOptions)
' Abbruch der Methode durch den Benutzer
If (getPolylineResult.Status = PromptStatus.Cancel) Then
' Beenden der Methode
Exit Sub
' Ungültige Eingabe des Benutzers
ElseIf Not (getPolylineResult.Status = PromptStatus.OK) Then
editor.WriteMessage(ControlChars.CrLf & "Keine gültige Polyline ausgewählt")
' Beenden der Methode
Exit Sub
End If
'---------------------------------------------------------------
' Abfrage des Höhenmodus
'---------------------------------------------------------------
' Schlüsselwörter (ObjektHoehen, BlockattributHoehen) und leere Eingabe
Dim getHeightModeOptions As New PromptKeywordOptions(ControlChars.CrLf & "Welche Höhen sollen verwendet werden: <" & [Enum].GetName(GetType(exportHeightModes), heightMode) & ">")
getHeightModeOptions.AllowNone = True
' Objekthoehen und Blockattributhoehen
getHeightModeOptions.Keywords.Add([Enum].GetName(GetType(exportHeightModes), exportHeightModes.ObjektHoehen))
getHeightModeOptions.Keywords.Add([Enum].GetName(GetType(exportHeightModes), exportHeightModes.BlockattributHoehen))
' Auswahl des Höhenmodus durch den Benutzer
Dim getHeightModeResult As PromptResult = editor.GetKeywords(getHeightModeOptions)
' Abbruch der Methode durch den Benutzer
If (getHeightModeResult.Status = PromptStatus.Cancel) Then
' Beenden der Methode
Exit Sub
' Nichts ausgewählt -> Behalten des alten Wertes
ElseIf (getHeightModeResult.Status = PromptStatus.None) Then
' Nothing
' Falsche Eingabe vom Benutzer
ElseIf Not (getHeightModeResult.Status = PromptStatus.OK) Then
editor.WriteMessage(ControlChars.CrLf & "Sie haben kein gültiges Schlüsselwort eingegeben.")
' Beenden der Methode
Exit Sub
' Eingabe eines Keywords
Else
' Speichern des ausgewählten Moduses
For Each i In [Enum].GetValues(GetType(exportHeightModes))
If ([Enum].GetName(GetType(exportHeightModes), i) = getHeightModeResult.StringResult) Then
heightMode = i
' Abbruch der Schleife
Exit For
End If
Next
End If
' Warnung keine Punktkoordinaten von Hand einzugeben falls nicht im WCS
If (System.Convert.ToInt16(Application.GetSystemVariable("WORLDUCS")) <> 1) Then
MsgBox("Sie befinden Sich nicht im Weltkoordinatensystem" & ControlChars.CrLf & ControlChars.CrLf & "Punktkoordinaten die durch die Tastatur eingegeben werden führen höchstwahrscheinlich zu falschen Ergebnissen", MsgBoxStyle.Information, "Tastaturpunkteingaben führen zu falschen Ergebnissen")
End If
'---------------------------------------------------------------
' Endlosschleife
'---------------------------------------------------------------
While True
' Wenn keine Punktnummer im Bereich bis 91000 mehr frei ist
If (lastPunktNR = 69999) Then
editor.WriteMessage(ControlChars.CrLf & "Keine freie Punktnummer mehr verfügbar" & ControlChars.CrLf & "Alle Punktnummern im Bereich 60001 bis 60999 bereits vergeben")
' Beenden der Methode
Exit Sub
End If
'---------------------------------------------------------------
' Endlosschleife für die Auswahl des ersten Blockes
'---------------------------------------------------------------
' Variablen für den ersten Block
Dim positionFirstBlock As Point3d = Nothing
Dim firstBlock As VermPoint = Nothing
' Bis ein gültiger erster Block ausgewählt wurde
While True
' Nur Punkte
Dim getFirstPointOptions As New PromptPointOptions(ControlChars.CrLf & "Bitte den Einfügepunkt des ersten Blockes auswählen: ")
' Auswahl des ersten Punktes durch den Benutzer
Dim getFirstPointResult As PromptPointResult = editor.GetPoint(getFirstPointOptions)
' Abbruch der Methode durch den Benutzer
If (getFirstPointResult.Status = PromptStatus.Cancel) Then
' Beenden der Methode
Exit Sub
' Falsche Eingabe vom Benutzer
ElseIf Not (getFirstPointResult.Status = PromptStatus.OK) Then
editor.WriteMessage(ControlChars.CrLf & "Sie haben keinen gültigen Einfügepunkt ausgewählt.")
' Beenden der Methode
Exit Sub
' Gültiger Punkt
Else
'---------------------------------------------------------------
' Überprüfen ob ein Block an der ausgewählten Stelle liegt
'---------------------------------------------------------------
Dim blockIDs As New ObjectIdCollection
exception = LaOs_AutoCAD_Werkzeuge.Functions.getBlockReferencesOnPoint(getFirstPointResult.Value.TransformBy(editor.CurrentUserCoordinateSystem), 0.001, blockIDs)
' Fehler beim Bestimmen des Blockes an der ausgewählten Stelle
If Not IsNothing(exception) Then
editor.WriteMessage(ControlChars.CrLf & "Fehler beim beim Bestimmen des Blockes am ausgewählten Punkt" & ControlChars.CrLf & exception.Message & ControlChars.CrLf & "Funktion: getBlockReferencesOnPoint(ByVal point As Point3d, ByVal tolerance As Double, ByRef blockIDs As ObjectIdCollection) As Exception")
' Beenden der Methode
Exit Sub
' Kein Block an der ausgewählten Stelle gefunden
ElseIf (blockIDs.Count = 0) Then
editor.WriteMessage(ControlChars.CrLf & "Es konnte kein Block am ausgewählten Punkt gefunden werden")
' Neustarten der Schleife
Continue While
' Mehrere Blöcke an der ausgewählten Stelle gefunden
ElseIf (blockIDs.Count > 1) Then
editor.WriteMessage(ControlChars.CrLf & "Es wurden mehrere Blöcke an der ausgewählten gefunden. Auswahl nicht eindeutig")
' Neustarten der Schleife
Continue While
' Nur ein Block an der Stelle gefunden
Else
'---------------------------------------------------------------
' Bestimmen der Attribute der Blockreferenz
'---------------------------------------------------------------
Dim blockAttributes As New Dictionary(Of String, String)
Try
blockAttributes = LaOs_AutoCAD_Werkzeuge.Functions.getBlockReferenceAttributes(blockIDs(0), positionFirstBlock)
Catch ex As Exception
editor.WriteMessage(ControlChars.CrLf & "Fehler beim beim Auslesen der Blockattribute" & ControlChars.CrLf & exception.Message & ControlChars.CrLf & "Funktion: getBlockReferenceAttributes(ByVal blockID As ObjectId, ByRef blockAttributes As Dictionary(Of String, String), ByRef position As Point3d) As Exception")
' Beenden der Methode
Exit Sub
End Try
' Erstellen des Vermessungpunktes
firstBlock = New VermPoint(positionFirstBlock.X, positionFirstBlock.Y, positionFirstBlock.Z)
' Füllen der retlichen Werte mit den Blockattributen
If (blockAttributes.ContainsKey("PNR")) Then
firstBlock.PunktNr = blockAttributes.Item("PNR")
End If
If (blockAttributes.ContainsKey("VMA")) Then
firstBlock.VMA = blockAttributes.Item("VMA")
End If
If (heightMode = exportHeightModes.BlockattributHoehen) Then
If (blockAttributes.ContainsKey("HOEHE") AndAlso IsNumeric(blockAttributes.Item("HOEHE"))) Then
firstBlock.Hoehe = blockAttributes.Item("HOEHE")
End If
Else
firstBlock.Hoehe = 0
End If
' Verlassen der inneren Endlosschleife
Exit While
End If
End If
End While
'---------------------------------------------------------------
' Endlosschleife für die Auswahl des zweiten Blockes
'---------------------------------------------------------------
' Bis ein gültiger zweiter Block oder ein Schlüsselwort ausgewählt wurde
While True
' Nur Punkte und Keywords: AufLinieÜbertragen
Dim getSecondPointOptions As New PromptPointOptions(ControlChars.CrLf & "Bitte den Einfügepunkt des zweiten Blockes auswählen oder: ")
getSecondPointOptions.Keywords.Add("AufLinieÜbertragen")
getSecondPointOptions.AllowNone = True
' Auswahl des zweiten Punktes durch den Benutzer
Dim getSecondPointResult As PromptPointResult = editor.GetPoint(getSecondPointOptions)
' Abbruch der Methode durch den Benutzer
If (getSecondPointResult.Status = PromptStatus.Cancel) Then
' Beenden der Methode
Exit Sub
' Schlüsselwort eingegeben
ElseIf (getSecondPointResult.Status = PromptStatus.Keyword Or getSecondPointResult.Status = PromptStatus.None) Then
' Wenn der Block nur auf die Linie übertragen werden soll
If (getSecondPointResult.StringResult = "AufLinieÜbertragen" Or IsNothing(getSecondPointResult.StringResult)) Then
' Aufruf der Funktion um die Höhe auf die Polylinie zu übertragen
If Not (blockHeightCarryOver(getPolylineResult.ObjectId, firstBlock)) Then
End If
End If
' Falsche Eingabe vom Benutzer
ElseIf Not (getSecondPointResult.Status = PromptStatus.OK) Then
editor.WriteMessage(ControlChars.CrLf & "Sie haben keinen gültigen Einfügepunkt ausgewählt.")
' Beenden der Methode
Exit Sub
' Gültiger Punkt
Else
End If
End While
' Äußere Endlosschleife
End While
End Sub
' Funktion um die Höhe eines Punktes auf eine Polylinie zu übertragen
' - Fügt am Lotfusspunkt des übergebenen Punktes zur Polylinie eine Blockreferenz ein
' - Gibt TRUE zurück wenn erfolgreich, ansonsten FALSE
Private Function blockHeightCarryOver(ByVal polylineID As ObjectId, ByVal point As VermPoint) As Boolean
Dim editor As Editor = Application.DocumentManager.MdiActiveDocument.Editor
' Anlegen eines Transaktionsobjektes um auf die Zeichnungsdatenbank zugreifen zu können
Dim trans As Transaction = Application.DocumentManager.MdiActiveDocument.Database.TransactionManager.StartTransaction
Dim pointOnCurve As Point3d = Nothing
Try
' Holen des Curve-Objektes - Leserechte
Dim curve As Curve = CType(trans.GetObject(polylineID, OpenMode.ForRead), Curve)
' Abfragen des dichtesten Punktes der Blockreferenz zum Curve-Objekt
pointOnCurve = curve.GetClosestPointTo(point.getVermPointAsPoint3D, True)
' Abfangen eines evtl. aufgetretenen Fehlers
Catch ex As Exception
editor.WriteMessage(ControlChars.CrLf & "Fehler beim beim Berechnen des Lotfußpunktes" & ControlChars.CrLf & ex.Message & ControlChars.CrLf & "Funktion: blockHeightCarryOver(ByVal polylineID As ObjectId, ByVal point As VermPoint) As Boolean")
' Beenden der Funktion
Return False
' Schließen der Transaktion mit der Datenbank
Finally
trans.Dispose()
End Try
' Aufruf der Funktion um eine neue Blockreferenz anzulegen
Dim exception As Exception = LaOs_AutoCAD_Werkzeuge.Functions.createBlockReference(BLOCKNAME, pointOnCurve, 1, 1, 1, point.getAttributesAsDictionary(False))
If Not IsNothing(exception) Then
editor.WriteMessage(ControlChars.CrLf & "Fehler beim beim Erstellen der Blockreferenz" & ControlChars.CrLf & exception.Message & ControlChars.CrLf & "Funktion: createBlockReference(ByVal name As String, ByVal position As Point3d, ByVal scaleX As Double, ByVal scaleY As Double, ByVal scaleZ As Double, ByVal attributes As Dictionary(Of String, String)) As Exception")
' Beenden der Funktion
Return False
Else
' Funktion wurde erfolgreich ausgeführt
Return True
End If
End Function
' Funktion um die letzte verwendete Punktnummer im Bereich 90001 bis 90999 zu finden
' - Durchlaufen aller Blöcke und Überprüfen ob die darin gespeicherte Punktnummer relevant ist und ggf. ersetzten der aktuell höchsten verwendeten Punktnummer
' - Gibt NOTHING zurück wenn erfolgreich ansonsten die aufgetretene Exception
Private Function setLastPunktNr() As Exception
' Vorbelegen auf die letzte verwendete 90000er-Punktnummer
lastPunktNR = 90000
' Anlegen eines Transaktionsobjektes um auf die Zeichnungsdatenbank zugreifen zu können
Dim trans As Transaction = Application.DocumentManager.MdiActiveDocument.Database.TransactionManager.StartTransaction
Try
' Holen des aktuellen Arbeitsbereiches - Leserechte
Dim currentWorkspace As BlockTableRecord = trans.GetObject(Application.DocumentManager.MdiActiveDocument.Database.CurrentSpaceId, OpenMode.ForRead)
' Durchlaufen aller Objekte des aktuellen Arbeitsbereiches
For Each obj As ObjectId In currentWorkspace
' Prüfen ob es sich um eine Blockreferenz handelt
If (obj.ObjectClass.DxfName = "INSERT") Then
' Holen des Elementes aus der Datenbank - Leserechte
Dim blockRef As BlockReference = trans.GetObject(obj, OpenMode.ForRead)
' Solange noch Attribute in der Collection vorhanden sind
For i As Long = 0 To blockRef.AttributeCollection.Count - 1
' Öffnen der BlockAttributReferenz - Leserechte
Dim attributeReference As AttributeReference = blockRef.AttributeCollection(i).GetObject(OpenMode.ForRead)
' Wenn das aktuelle Attribut das "PNR"-Attribut ist
If (attributeReference.Tag.ToUpper = "PNR") Then
' Wenn darin eine Zahl gespeichert ist die größer als die aktuell letzte Punktnummer aber auch kleiner als 91000 ist
If (IsNumeric(attributeReference.TextString) AndAlso CLng(attributeReference.TextString) > lastPunktNR AndAlso CLng(attributeReference.TextString) < 91000) Then
' -> Speichern
lastPunktNR = attributeReference.TextString
End If
End If
Next
End If
Next
' Beenden der Funktion
Return Nothing
' Abfangen eines evtl. auftretenden Fehlers
Catch ex As Exception
Return ex
' Schließen der Transaktion mit der Datenbank
Finally
trans.Dispose()
End Try
End Function
End Module
End Namespace