[编程交流] 指向VB线。净额

    <CommandMethod("LRInt")> _
Public Sub LineRayIntersect()
       Dim db As Database = HostApplicationServices.WorkingDatabase
       Dim ed As Editor = Application.DocumentManager.MdiActiveDocument.Editor
       db.Pdmode = 66 'just to make the points more visible
       Dim peo As PromptEntityOptions = New PromptEntityOptions("Select a Line: ")
       peo.SetRejectMessage("Select only a line!")
       peo.AddAllowedClass(GetType(Line), False)
       Dim tr As Transaction = db.TransactionManager.StartTransaction()
       Using tr
           Try
               Dim per As PromptEntityResult = ed.GetEntity(peo)
               If per.Status <> PromptStatus.OK Then Exit Sub
               Dim ln As Line = tr.GetObject(per.ObjectId, OpenMode.ForRead)
               peo.SetRejectMessage("Select only a Ray!")
               peo.Message = "Select a Ray: "
               peo.RemoveAllowedClass(GetType(Line))
               peo.AddAllowedClass(GetType(Ray), False)
               per = ed.GetEntity(peo)
               If per.Status <> PromptStatus.OK Then Exit Sub
               Dim ry As Ray = tr.GetObject(per.ObjectId, OpenMode.ForRead)
               Dim ptc As Point3dCollection = New Point3dCollection()
               Dim intthis As Integer
               Dim intThat As Integer
               ln.IntersectWith(ry, Intersect.OnBothOperands, ln.GetPlane(), ptc, intthis, intThat)
               If ptc.Count < 1 Then Exit Sub
               Dim ptAtInters As DBPoint = New DBPoint(ptc(0))
               Dim btr As BlockTableRecord = tr.GetObject(db.CurrentSpaceId, OpenMode.ForWrite)
               btr.AppendEntity(ptAtInters)
               tr.AddNewlyCreatedDBObject(ptAtInters, True)
               tr.Commit()
           Catch
               ed.WriteMessage("Error during execution!")
               tr.Abort()
           End Try
       End Using
   End Sub

<CommandMethod("pts")> _
   Public Sub pts()
       Dim lineCmd As Editor = Application.DocumentManager.MdiActiveDocument.Editor
       Dim acadBaza As Database = lineCmd.Document.Database
       Dim trans As Transaction = acadBaza.TransactionManager.StartTransaction
       Dim opPoint As PromptPointOptions = New PromptPointOptions("Kliknij srodek pomieszczenia :")
       Dim rePoint As PromptPointResult = lineCmd.GetPoint(opPoint)
       ' confstruction of filter
       Dim typeValue() As TypedValue = {New TypedValue(0, "line")}
       Dim selFilter As SelectionFilter = New SelectionFilter(typeValue)
       Dim selectResult As PromptSelectionResult = lineCmd.SelectAll(selFilter)
       If rePoint.Status = PromptStatus.OK Then
           Dim rePoint2 As Point3d = New Point3d(rePoint.Value.X + 10, rePoint.Value.Y, 0)
           Dim prosta As Ray = New Ray()
           prosta.BasePoint = rePoint.Value
           prosta.SecondPoint = rePoint2
           Try
               Dim btr As BlockTableRecord = trans.GetObject(acadBaza.CurrentSpaceId, OpenMode.ForWrite)
               btr.AppendEntity(prosta)
               trans.AddNewlyCreatedDBObject(prosta, True)
               If selectResult.Status = PromptStatus.OK Then
                   Dim ss As SelectionSet = selectResult.Value
                   Dim idTab() As ObjectId = ss.GetObjectIds()
                   Dim ra As Ray = CType(trans.GetObject(prosta.Id, OpenMode.ForRead), Ray)
                   Dim ptc As Point3dCollection = New Point3dCollection()
                   Dim intthis As Integer
                   Dim intThat As Integer
                   Dim objId As ObjectId
                   For Each objId In idTab
                       Dim ln As Line = CType(trans.GetObject(objId, OpenMode.ForRead), Line)
                       ln.IntersectWith(ra, Intersect.OnBothOperands, ln.GetPlane(), ptc, intthis, intThat)
                   Next
                   Dim pts As Point3d
                   Dim tmpPt As Point3d
                   tmpPt = ptc.Item(0)
                   Dim i As Integer
                   If ptc.Count > 1 Then
                       For i = 0 To ptc.Count - 1
                           pts = ptc(i)
                           If pts.X < tmpPt.X Then
                               tmpPt = pts
                           End If
                       Next
                   End If
                   lineCmd.WriteMessage(tmpPt.ToString)
               End If
               trans.Commit()
           Catch ex As Exception
               lineCmd.WriteMessage("Wywalilo sie jakis wyjatek" + ex.Message)
           Finally
               trans.Dispose()
           End Try
       End If
   End Sub

    <CommandMethod("pts")> _
       Public Sub pts()
       Dim lineCmd As Editor = Application.DocumentManager.MdiActiveDocument.Editor
       Dim acadBaza As Database = lineCmd.Document.Database
       Dim trans As Transaction = acadBaza.TransactionManager.StartTransaction
       Dim opPoint As PromptPointOptions = New PromptPointOptions("Kliknij srodek pomieszczenia :")
       Dim rePoint As PromptPointResult = lineCmd.GetPoint(opPoint)
       Dim crvDict As Dictionary(Of Double, Line) = New Dictionary(Of Double, Line)()
       ' confstruction of filter
       Dim typeValue() As TypedValue = {New TypedValue(0, "line")}
       Dim selFilter As SelectionFilter = New SelectionFilter(typeValue)
       Dim selectResult As PromptSelectionResult = lineCmd.SelectAll(selFilter)
       If rePoint.Status = PromptStatus.OK Then
           Dim rePoint2 As Point3d = New Point3d(rePoint.Value.X + 10, rePoint.Value.Y, 0)
           Dim prosta As Ray = New Ray()
           Dim tmpPt As Point3d
           prosta.BasePoint = rePoint.Value
           prosta.SecondPoint = rePoint2
           Try
               Dim btr As BlockTableRecord = trans.GetObject(acadBaza.CurrentSpaceId, OpenMode.ForWrite)
               btr.AppendEntity(prosta)
               trans.AddNewlyCreatedDBObject(prosta, True)
               If selectResult.Status = PromptStatus.OK Then
                   Dim ss As SelectionSet = selectResult.Value
                   Dim idTab() As ObjectId = ss.GetObjectIds()
                   Dim ra As Ray = CType(trans.GetObject(prosta.Id, OpenMode.ForRead), Ray)
                   Dim ptc As Point3dCollection = New Point3dCollection()
                   Dim intthis As Integer
                   Dim intThat As Integer
                   Dim objId As ObjectId
                   Dim x As Double
                   For Each objId In idTab
                       Dim tempptc As Point3dCollection = New Point3dCollection()
                       Dim ln As Line = CType(trans.GetObject(objId, OpenMode.ForRead), Line)
                       ln.IntersectWith(ra, Intersect.OnBothOperands, ln.GetPlane(), tempptc, intthis, intThat)
                       If tempptc.Count > 0 Then
                           For Each pt As Point3d In tempptc
                               x = Math.Round(pt.X, 6)
                               crvDict.Add(x, ln) 'add line to dictionary with X coordinate as Key
                               ptc.Add(pt)
                           Next
                       End If
                   Next
                   trans.Commit()
                   If crvDict.Count > 0 Then
                       Dim pts As Point3d
                       tmpPt = ptc.Item(0)
                       Dim i As Integer
                       If ptc.Count > 1 Then
                           For i = 0 To ptc.Count - 1
                               pts = ptc(i)
                               If pts.X < tmpPt.X Then
                                   tmpPt = pts
                               End If
                           Next
                       End If
                       lineCmd.WriteMessage(tmpPt.ToString)
                       crvDict(Math.Round(tmpPt.X, 6)).Highlight() 'Retrieve line based on X coordinate Key equal to tmpPt.X
                       lineCmd.WriteMessage(" ObjectId: " & crvDict(Math.Round(tmpPt.X, 6)).ObjectId.ToString())
                   Else
                       lineCmd.WriteMessage("No intersections")
                   End If
               End If
           Catch ex As Exception
               lineCmd.WriteMessage("Wywalilo sie jakis wyjatek" + ex.Message)
           Finally
               trans.Dispose()
           End Try
       End If
   End Sub