在paperspace中自动添加尺寸。
大家好，我正在寻找创建一个可以自动调整视口中显示的3D实体尺寸的例程。
在我开始之前，我需要了解您如何知道视口上方的纸质空间中的相对坐标与模型空间中的真实坐标之间的相关性。
欢迎任何建议、代码、需要我澄清的问题等。
仅供参考。我注意到Express Tools、Layout Tools、Change Space将携带从模型空间转移到纸质空间的对象的xdata。这很有趣，因为它可用于在纸质空间中创建最终用户可以访问的对象以进行气球膨胀。您还应该注意到，欧特克制作的这个实用程序清楚地表明他们理解并拥有在纸空间中找到等效位置的代码。
谢谢，
David Wishengrad
MillLister， Inc.
**** Hidden Message ***** 我想你可能必须使用边界框来确定你正在使用哪个视口。
Public Sub ModeltoPaperSpacePoint()
Dim vp As AcadPViewport, Ent As AcadEntity, VarPick
Dim util As AcadUtility, M1, P1
Dim i As Integer, dblScale As Double
Dim VpCol As New Collection
Dim PSpt As AcadPoint, MSpt As AcadPoint
Set util = ThisDrawing.Utility
If ThisDrawing.ActiveSpace = acModelSpace Then
MsgBox "Command not allowed unless TILEMODE is set to 0"
Exit Sub
End If
For Each Ent In ThisDrawing.PaperSpace
If TypeOf Ent Is AcadPViewport Then
i = i + 1
VpCol.Add Ent
End If
Next
If i = 1 Then
MsgBox "Please add a viewport"
Exit Sub
End If
'Debug.Print i
If ThisDrawing.MSpace = False Then
If i > 2 Then
util.GetEntity Ent, VarPick, "Pick a viewport:"
If TypeOf Ent Is AcadPViewport Then
Set vp = Ent
Else
Exit Sub
End If
Else
Set vp = VpCol(2)
End If
vp.Display True
ThisDrawing.MSpace = True
ThisDrawing.ActivePViewport = vp
Else
Set vp = ThisDrawing.ActivePViewport
End If
vp.DisplayLocked = True
M1 = util.GetPoint(, "Pick a point:")
Set MSpt = ThisDrawing.ModelSpace.AddPoint(M1)
MSpt.Color = acBlue
P1 = util.TranslateCoordinates(M1, acWorld, acDisplayDCS, False)
P1 = util.TranslateCoordinates(P1, acDisplayDCS, acPaperSpaceDCS, False)
ThisDrawing.MSpace = False
Set PSpt = ThisDrawing.PaperSpace.AddPoint(P1)
PSpt.Color = acGreen
Set vp = Nothing
End Sub
Public Sub PapertoModelSpacePoint()
Dim Ent As AcadEntity, VarPick
Dim util As AcadUtility, M1, P1
Dim PSpt As AcadPoint, MSpt As AcadPoint
Set util = ThisDrawing.Utility
ThisDrawing.ActiveSpace = acPaperSpace
ThisDrawing.MSpace = False
P1 = util.GetPoint(, "Pick a point:")
Set PSpt = ThisDrawing.PaperSpace.AddPoint(P1)
PSpt.Color = acGreen
P1 = util.TranslateCoordinates(P1, acPaperSpaceDCS, acDisplayDCS, False)
M1 = util.TranslateCoordinates(P1, acDisplayDCS, acWorld, False)
Set MSpt = ThisDrawing.ModelSpace.AddPoint(M1)
MSpt.Color = acBlue
End Sub
当视口有扭曲时，这会更好一点。
没有简单的方法来获取与视口关联的ucs，
所以简单的方法是设置active eviewport。这会在翻译之前更新Ucs
。
Public Sub PapertoModelSpacePoint()
Dim Pv As AcadPViewport, Ent As AcadEntity, VarPick
Dim util As AcadUtility
Dim PSpt As AcadPoint, MSpt As AcadPoint
Dim M1, P1, Orig
Set util = ThisDrawing.Utility
ThisDrawing.ActiveSpace = acPaperSpace
ThisDrawing.MSpace = False
P1 = util.GetPoint(, "Pick a point:")
Set PSpt = ThisDrawing.PaperSpace.AddPoint(P1)
PSpt.Color = acGreen
Set Pv = EntSel
ThisDrawing.MSpace = True
ThisDrawing.ActivePViewport = Pv
P1 = util.TranslateCoordinates(P1, acPaperSpaceDCS, acDisplayDCS, False)
M1 = util.TranslateCoordinates(P1, acDisplayDCS, acWorld, False)
Set MSpt = ThisDrawing.ModelSpace.AddPoint(M1)
MSpt.Color = acBlue
ThisDrawing.ActiveSpace = acPaperSpace
End Sub
David，这是一个困难的问题，虽然你可以从mspace到pspace（Bryco是这方面的老手）获得一个点，但我发现对于3d实体，拥有拓扑是不够的
如果您可以将对象以某种格式存储在文件和模型中，从该文件中您可以获得在任何空间中标注对象所需的一切，您可以使用Bryco的代码获得初始“开始”或插入点<这不容易，但可以做到 谢谢。你的代码看起来很有希望。
保重，
戴夫 嘿伙计们，
谢谢你的代码。我真的很想摆弄那些东西，但我已经偏离了将Rhino创建的SAT文件转换为ACAD实体的轨道。他们在实体中的所有实体都是脊柱，我们正试图将它输出到CNC，在那里所有的实体都必须是直线、圆弧、圆和直线。真是一团糟，但是我快好了。我想接下来我会把我网格移植到Rhino，并在之后的构建中添加特性识别。
总之....我需要为一家对我的软件感兴趣的公司做这项工作，我没有机会用上面的代码工作，但我会的。非常感谢，
戴夫 我上面的代码使用点的位置作为所有引线的起点，以及用户选择堆叠文本数据的位置。
有没有办法让代码允许引线和气球文本的可见视图可见，并根据十字准线的位置进行更新，以便用户可以在提交之前查看和调整文本的位置？
任何帮助是值得赞赏的。我以前从未见过任何VB代码这样做，所以我不知道它是否可以通过vb.
我正在寻找这种拖曳效果，但找不到任何人或任何东西在VB中做到这一点。在此期间，我将查看是否有人创建了一个我可以通过VB代码访问的arx。
谢谢。 好了，伙计们，再次感谢大家
我对上面的代码做了很多修改，但对于任何想开始做类似事情的人来说，这是一个很好的起点
以下是完成的实用程序的功能（使用windows media9编解码器编码的10兆avi）：
http://SmartLister.com/Files/Balloon1.avi
视频质量是公平的。引线在视频中仅显示为虚线<如果有人在任何一项日常活动中需要帮助，请直接询问。 戴夫看起来不错。因此，当您这样做时，您是否想出了从图纸空间到模型以编程方式提供关联标注的方法？
谢谢。
我还没有走到那一步。这段代码花了很长一周的时间，也花了很多时间。我甚至不是程序员。
我对PS和MS之间的积分转换有了更好的理解。
自动标注将需要它，但我可能需要引入一个2D投影并使其变暗，然后删除它。我还在考虑要用的概念。
页:
[1]
2