指向VB线。净额
你好我有一个简单的问题，我想，但我是vba的新手，所以我问
我画了一条线，我选了一个点，我想画一条从我的点到这条线的水平线，但我不知道怎么画
希望有人能帮忙 我想我可以用光线在点和线之间画一条线，但是我怎么才能找到它穿过另一条线的点呢？在lisp中，类似inters的东西，但在vb中，我不知道如何使用 在给出可能不合适的建议之前：你对哪种口味的vb感兴趣，VBA/VB6还是vb。网络？
我想一个示例文件（最好是2007年格式）说明之前和之后也会很有帮助。 我试着在vb网络中写（很抱歉vba），我在绘图中有一条线，我知道如何使用宏绘制光线，但我不知道如果它们相交，我怎么能找到相交点
thx回复 直线和光线都派生自数据库曲线类，而数据库曲线类又派生自数据库实体。作为实体，两者都可以使用该实体。与方法相交。
<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 谢谢你的帮助，但我想知道是否有可能不用用户选择线，通过射线本身找到该点 这是可能的，但必须设置例程以迭代活动空间中满足所需标准的所有曲线。请参阅：
编辑SelectAll方法（SelectionFilter）
然后，将在所有以光线为基础的过滤曲线上使用我上一篇文章中所示的相同过程。i、 e.，ry.IntersectWith（curve，Intersect.OnBothOperands，ry.GetPlane（），ptc，intThis，intThat）。
如果您在设置时遇到问题，请发布您的代码，我们将尽力提供建议。 好的，谢谢你的帮助，但我会尽力自己做。如果我失败了，我会回来的；] 您好，我再一次做了这样的事情，光线在它的路上找到了第一条线（一条线上的点）。任何建议，我怎么能得到那条线的id，这就是我写的
<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
页:
[1]
2