3dSolid长度。
这是一种通过圆柱体中心画线的方法它使用了一个相当简单的子绘图CylinderCenterLine和几个函数，这些函数可以进行一些数学运算
主方向是关键，它包括实体的x、y、z向量。z向量是法线，并给出挤出方向。（这个项目的帮助是了解一下你父亲的情况。）；在cad vba中没有太多可用信息，主方向与边界框相结合为我们提供了更多信息。在变换对象之前，边界框没有多大用处，然后您知道z差将是对象的高度
Option Explicit
'Bryco Swamp code 5-26-07
Sub DrawCylinderCenterlineLine(oCylinder As Acad3DSolid)
Dim Xaxis(2) As Double, Yaxis(2) As Double, Zaxis(2) As Double
Dim Pd As Variant
Dim i As Integer
Dim min As Variant, max As Variant
Dim oUcs As AcadUCS
Dim m As Variant
Dim oLine As AcadLine
Dim StartPt As Variant, EndPt As Variant
Dim Ht As Double
Dim Zero(2) As Double
'Debug.Print vbAssoc(oCylinder, 1)
Pd = oCylinder.PrincipalDirections
For i = 0 To 2
Xaxis(i) = Pd(i)
Yaxis(i) = Pd(i + 3)
Zaxis(i) = Pd(i + 6)
Next i
Set oUcs = ThisDrawing.UserCoordinateSystems.Add(Zero, Xaxis, Yaxis, "3d")
oUcs.Origin = oCylinder.Centroid
m = oUcs.GetUCSMatrix
oCylinder.TransformBy (InverseMatrix(m))
oCylinder.GetBoundingBox min, max
Ht = (max(2) - min(2)) / 2
StartPt = Zero
StartPt(2) = StartPt(2) - Ht
EndPt = Zero
EndPt(2) = EndPt(2) + Ht
Set oLine = ThisDrawing.ModelSpace.AddLine(StartPt, EndPt)
oLine.TransformBy m
oCylinder.TransformBy m
End Sub
Sub Test()
Dim Ent As AcadEntity, V, C As Acad3DSolid
ThisDrawing.Utility.GetEntity Ent, V, "Pick"
If TypeOf Ent Is Acad3DSolid Then
Set C = Ent
DrawCylinderCenterlineLine C
End If
End Sub
Function Rd(num1 As Variant, num2 As Variant) As Boolean
Dim dRet As Double
dRet = num1 - num2
If Abs(dRet)0 Then
pivot = Matrix(i, J)
iP = J
Exit For
End If
Next J
For k = 0 To RowCt
If Not k = i Then
PC = Matrix(k, iP)
If PC = 0 Then GoTo skip
Sign = 1
If pivot0 Then
Sign = -1
End If
End If
Dim n1 As Double, n2 As Double
n1 = Abs(pivot): n2 = Abs(PC)
Den = LCD(n1, n2)
For J = 0 To ColCt
dTemp = Matrix(k, J) * n1 / Den + (Matrix(i, J) * n2 / Den * Sign)
If Rd(dTemp, 0) Then
Matrix(k, J) = 0
Else
Matrix(k, J) = dTemp
End If
Next J
End If
skip:
Next k
Next i
For i = 0 To RowCt
For J = 0 To ColCt
If Matrix(i, J)0 Then
pivot = 1 / Matrix(i, J)
Exit For
End If
Next J
For J = 0 To ColCt
Matrix(i, J) = Matrix(i, J) * pivot
Next J
Next i
MPivot = Matrix
End Function
Function OrderMatrix(Matrix As Variant) As Variant
Dim i As Integer, J As Integer
Dim k As Integer, l As Integer
Dim RowCt As Integer, ColCt As Integer
RowCt = UBound(Matrix, 1)
ColCt = UBound(Matrix, 2)
ReDim tempRow(ColCt) As Double
'ij is row,column
For i = 0 To RowCt
For J = 0 To ColCt
If J = i Then
If Not Rd(Matrix(i, J), 1) Then
For k = 0 To RowCt
If Not k = i Then
If Rd(Matrix(k, J), 1) Then
For l = 0 To ColCt
tempRow(l) = Matrix(k, l)
Matrix(k, l) = Matrix(i, l)
Matrix(i, l) = tempRow(l)
Next l
End If
End If
Next k
End If
End If
Next J
Next i
OrderMatrix = Matrix
End Function
Function Transpose(Matrix As Variant) As Variant
Dim iCnt As Integer, jCnt As Integer
Dim transMat(0 To 3, 0 To 3) As Double
Dim i As Integer, J As Integer
iCnt = UBound(Matrix, 1)
jCnt = UBound(Matrix, 2)
For i = 0 To iCnt
For J = 0 To jCnt
transMat(i, J) = Matrix(J, i)
Next J
Next i
Transpose = transMat
End Function
Function LCD(n1, n2) As Integer
'LowestCommonDenominator
Dim iCt As Integer, i As Integer
Dim Ans As Integer
Ans = 1
If n11 Then
For i = 1 To iCt
If (n1 Mod i = 0 And n2 Mod i = 0) Then Ans = i
Next i
End If
LCD = Ans
End Function
进一步检查的是dxf代码信息是打印出来的SomeCallMeDave'；s函数vbassoc（它在本网站上）。mi似乎暗示了一个椭圆形（即椭圆、圆或多圆），而mogoo gi m o似乎暗示了盒子。可以使用此信息和线长度与体积特性的关系的组合来生成一类基本实体
我调查了主方向的使用，但结果不一致 ；我不得不说，你的例行程序比我的尝试表现得好得多，但它确实遇到了在“中创建的圆柱体的问题。”；奇数“；UCS#039；s（至少在我的设置中） ；随附的文件，如何为您画线
圆柱体是用；UCSDuringCyl“；ucs激活。 在更仔细地审视这个问题之后，它应该#039；确认哪一个向量最长并不麻烦，并相应地进行操作 
谢谢你的钥匙 ；它将允许完成一些已经过时的BOM编码。 非常好的方法从VB。谢谢你分享的代码。这是非常令人印象深刻的。我肯定会学习它，以了解更多有关使用矩阵的信息
无论方向和对称性如何，我目前正在使用ARX返回边界框。一旦我做到了，我就差不多完了。你、米克和其他一些人的所有想法都很有趣。他们当然有不同的价值观。我发现很难清楚地看到任何东西，我对你的代码和Mick缺乏理解；s、 了解我真正需要或想要的东西，以及如何在我的原始代码中部署它们。事实上，我在很大程度上已经过了这个问题。当然，有很多方法可以改进我所做的，但我现在做的非常好。我不愿意在没有看到明显的好处和进行更改的领域的情况下，破坏现有代码，并承担现有用户的所有后果。你的帖子肯定会教我更多关于矩阵问题的知识，我希望我能在不久的将来部署一个更快的例程，不带任何假设。谢谢
我的问题是提升业务，典型的业务问题就是问题所在。我们可以更便宜地建造它，因为我们部署的技术可行。但是，我们是扩大这一领域以实现更多利润，还是朝着将技术出售给其他人的方向发展？这些都与VB无关。我的大脑太满了。 Dave it#039；很难知道软件在哪里或多久有用一次
仅仅因为公司的结构不同，同一个软件可能无法在其他类似情况下工作
至于使用这段代码，肖特提出了一个很好的观点，即我'；我还在看，它需要一些工作
矩阵-我学习#039；在网上谈论他们，他们需要一段时间才能掌握窍门，但他们是值得的。我花了一些时间将C代码等的位和段转换为vba，但现在它35;039；矩阵和平移公式一样容易使用。 我不处理3D对象，但请记住，它有一个ACIS解码器，可以很容易地使用，例如，在一篇文章中提取图形样本的长度，使用解码器，您可以得到：
然后，只需让读者为两点提取正确的值：
我记得前一段时间我和罗布·基什在解决这个问题的时候玩过主要方向。我们不能#039；没有得到一致的结果，我认为如果你做一些修改，比如在一端的一个角度上切片，它没有#039；没有像预期的那样工作
也可以使用固体的其他属性，但同样，任何修改都会影响结果，因此它只是不#039；t工作。问题是，acis实体需要足够通用，以处理任何类型的建模，而这些额外信息可能会阻碍其他类型的应用
当时我的回溯并不是最好的解决方案，但最终是最简单的，我不得不将数据存储在实体上。为此，我只存储#039；世界#039；扩展数据中作为我的轴向量的点（作为向量和点基本上是相同的东西），更新和复制等；实体#039；无论何时移动、旋转对象，都会使用更新扩展数据方法，因此这是我们所做工作的最佳解决方案，而且是可靠的
可以在创建时或稍后通过在面上拾取3个点或设置ucs并获取这些值I'来添加点；d存储；点x=（1.0,0.0，0.0）等等。要使用它，我将提取点，使用它们构建矩阵，并将实体转换为wcs，获取bbox值，然后在后台将其旋转回来，以便使用户不#039；我什么也看不见。因为我只对长度感兴趣（本例中为z轴）I'；d只需使用最大最小bbox z值，因为我已经从目录中新建了宽度和高度
Dave有一些有趣的方法可以做到这一点，不需要挑选点，而是在最终用户的某个地方#039；039年5月；需要指定或选择哪个轴是哪个轴。上述方法是一种“置而不置”的版本，使用目录类型系统（例如，型钢）可能会更加优雅，而Dave'；s有点复杂，但有点自由，因为他可以选择任何类型的实体并提取数据，它更适合用户正在做的工作类型
与Dave一起获得丰厚奖金'；他也可以使用传统实体，而如果我想使用上述方法，我必须将数据添加到每个实体中，虽然这并不难，但在一个有很多方向的实体的模型上，这可能会很乏味
尽管这两种方法都受益于使用向量和矩阵将实体获取到wcs以获得正确的bbox。本人'；我不确定是什么#039；它在vba中可用，但是arx（因此现在也是.net）几何库非常好，并且有比您需要的更多的这类东西，在这里'；Kerry Brown在本文中列出了一个清单->； 米克，这看起来确实是一场失败的战斗，当然很有趣。我一直在扮演一个角色，直到我发现在moogoo中的gi没有'；t表示长方体，但表示任何挤出的四边形对象。主方向似乎从质心开始；然后从该点将物体切成两半。这就解释了你有时会遇到的愚蠢的角度
路易斯，谢谢你，但我不知道；我想我'；我要走那么远
我用固体，但不经常用
这里有一个更新供感兴趣的人使用
'Bryco Swamp code 5-28-07
Const pi As Double = 3.14159265358979
Sub DrawCylinderCenterlineLine(oCylinder As Acad3DSolid)
Dim Xaxis(2) As Double, Yaxis(2) As Double, Zaxis(2) As Double
Dim Zero(2) As Double
Dim Pd As Variant
Dim i As Integer
Dim min As Variant, max As Variant
Dim oUcs As AcadUCS
Dim m As Variant
Dim oLine As AcadLine
Dim StartPt As Variant, EndPt As Variant
Dim Width As Double, Depth As Double, Height As Double
Dim dp As Double, Rad As Double, Vol As Double
Dim sType As String
Dim sMessage As String
Dim sName As String
sName = vbAssoc(oCylinder, 1)
Debug.Print sName
sName = Mid(sName, 7, 2)
Debug.Print sName
Pd = oCylinder.PrincipalDirections
For i = 0 To 2
Xaxis(i) = Pd(i)
Yaxis(i) = Pd(i + 3)
Zaxis(i) = Pd(i + 6)
Next i
retry:
Set oUcs = ThisDrawing.UserCoordinateSystems.Add(Zero, Xaxis, Yaxis, "3d")
oUcs.Origin = oCylinder.Centroid
m = oUcs.GetUCSMatrix
oCylinder.TransformBy (InverseMatrix(m))
oCylinder.GetBoundingBox min, max
StartPt = Zero
EndPt = Zero
Depth = (max(2) - min(2))
dp = Depth / 2
StartPt(2) = StartPt(2) - dp
EndPt(2) = EndPt(2) + dp
Select Case sName
Case "gi"
sType = "Box"
Width = max(0) - min(0)
Height = max(1) - min(1)
'Vol = Width * Height * Depth
Vol = oCylinder.Volume
sMessage = "Type: box." & vbCrLf & "Width=" & Width _
& vbCrLf & "Height=" & Height & vbCrLf & "Depth=" & Depth _
& vbCrLf & "Volume=" & Vol
Case "kg"
sType = "extruded pline"
MsgBox "Type: extruded pline"
Case "kg"
sType = "non primitive"
sMessage = "This is not a primitive solid"
GoTo NonPrimitive
Case "i "
sType = "Sphere"
Rad = (max(0) - min(0)) / 2
Vol = pi * Rad * Rad * Rad * 4 / 3
sMessage = "Type: Sphere " & vbCrLf & "Rad=" & Rad & vbCrLf & "Volume=" & Vol
Case "mi" 'Ovaloids
Width = (max(0) - min(0)) / 2
Height = (max(1) - min(1)) / 2
If Abs(Width - Height) > 0.00000001 Then
'Here we are asking if height=width then it is a cylinder
'else it is an ellipse, with the extra check for
'messed up PrincipalDirections, if the height=depth.
If Abs(Width - dp)0.00000001 Then
If Abs(Width - dp)Width Then
'Cap is larger than a hemisphere so the width is the sphere's radius.
Rad = Width
baseRad = Sqr(Depth * (2 * Rad - Depth))
'Debug.Print "baseRad", baseRad, Depth, Rad
Else
baseRad = Width
Rad = ((baseRad * baseRad) + (Depth * Depth)) / (2 * Depth)
End If
Vol = (pi / 6) * ((3 * baseRad * baseRad) + (Depth * Depth)) * Depth
sMessage = "Type " & sType & vbCrLf & "Sphere's radius=" & Rad _
& vbCrLf & "Base radius=" & baseRad _
& vbCrLf & "Depth=" & Depth & vbCrLf & "Volume=" & Vol
dp = 3 * (2 * Rad - Depth) * ((2 * Rad) - Depth) / (4 * ((3 * Rad) - Depth))
StartPt(2) = (Rad - Depth) - dp
EndPt(2) = Rad - dp
Case Else
GoTo NonPrimitive
End Select
If Abs(Vol - oCylinder.Volume) > 0.00000001 Then
Yaxis(0) = Zaxis(0): Yaxis(1) = Zaxis(1): Yaxis(2) = Zaxis(2)
oCylinder.TransformBy m
GoTo retry
End If
NonPrimitive:
MsgBox sMessage
Set oLine = ThisDrawing.ModelSpace.AddLine(StartPt, EndPt)
oLine.TransformBy m
oCylinder.TransformBy m
End Sub
'SomeCallMeDave
'http://www.vbdesign.net/expresso/showthread.php?postid=83887#post83887
'Changed pAcadObj As AcadObject to pAcadObj As Object to access imagedef as well
'Modified by Jeff Mishler, March 2006, to get the Block table object, not Block_Record table object
Public Function vbAssoc(pAcadObj, pDXFCode As Integer) As Variant
Dim VLisp As Object
Dim VLispFunc As Object
Dim varRetVal As Variant
Dim obj1 As Object
Dim obj2 As Object
Dim strHnd As String
Dim strVer As String
Dim lngCount As Long
Dim i As Long
Dim J As Long
On Error GoTo vbAssocError
Set VLisp = ThisDrawing.Application.GetInterfaceObject("VL.Application.16")
'Check your version ("VL.Application.1")
Set VLispFunc = VLisp.ActiveDocument.Functions
If Not TypeOf pAcadObj Is AcadBlock Then
strHnd = pAcadObj.Handle
Else
Dim lispStr As String
lispStr = "(cdr (assoc 5 (entget (tblobjname " & Chr(34) & "Block" & Chr(34) & Chr(34) & pAcadObj.Name & Chr(34) & "))))"
Set obj1 = VLispFunc.Item("read").Funcall(lispStr)
strHnd = VLispFunc.Item("eval").Funcall(obj1)
End If
Set obj1 = VLispFunc.Item("read").Funcall("pDXF")
varRetVal = VLispFunc.Item("set").Funcall(obj1, pDXFCode)
Set obj1 = VLispFunc.Item("read").Funcall("pHandle")
varRetVal = VLispFunc.Item("set").Funcall(obj1, strHnd)
Set obj1 = VLispFunc.Item("read").Funcall("(vl-princ-to-string (cdr (assoc pDXF (entget (handent pHandle)))))")
varRetVal = VLispFunc.Item("eval").Funcall(obj1)
vbAssoc = varRetVal
'clean up the newly created LISP symbols
Set obj1 = VLispFunc.Item("read").Funcall("(setq pDXF nil)")
varRetVal = VLispFunc.Item("eval").Funcall(obj1)
Set obj1 = VLispFunc.Item("read").Funcall("(setq pHandle nil)")
varRetVal = VLispFunc.Item("eval").Funcall(obj1)
'release the objects or Autocad gets squirrely (no offense RR)
Set obj2 = Nothing
Set obj1 = Nothing
Set VLispFunc = Nothing
Set VLisp = Nothing
Exit Function
vbAssocError:
Set obj2 = Nothing
Set obj1 = Nothing
Set VLispFunc = Nothing
Set VLisp = Nothing
MsgBox "Error occurred " & Err.Description
End Function
除了Mick使用轮廓创建3D OCS的基本等效物外，当对象既不对称又未与WCS对齐时，ACSI和parasolids建模引擎都存在舍入误差。在那一点上，你不能指望ACAD计算出的任何东西。为质心和主方向返回的所有值都基于实体的体积，该数字是错误的。物体越大，误差越大。如果您选择2 x 4；1 1/2“；x 3 1/2“；x 48“；将一端切成45度角，2 x 4仍为48“；很长，但ACAD认为是3.5/8“；宽，实际上只有3 1/2“；宽的为了避免这个错误，我花了175000.00美元！是的，我被程序员骗了一眼，应该不到20000.00美元。这是一笔大买卖。直到今天，我还在为它付款
我对你们感兴趣的地方'；s代码是冗余的。除了2个区域#039；s、 第一个是在对象非常复杂且未与WCS对齐时获得正确的3个DIM。我的测量程序有时会提供错误的数字。他们就像一个受伤的拇指。我一直都能得到它们，但在首先遍历每个3D实体的每个面和例程的长度之间，速度不够快。我们放松了速度，但其中一些物体会流血。另一个问题是，我的例程比较了长度#039；在一个大于/小于的声明中，双方的相互信任。当对象具有大小相同的边（2或3）时，如果更改了与另一侧相等的任何边，则我的endcommand事件无法自动更新方向标记。我确实对此有一些处理，因为方向字母被删除，并且在导出时会警告您，或者您可以始终确保您的对象侧面略有不同。即便如此，我在这方面花了很长时间，以至于添加冗余检查来填补我的最后一个漏洞的想法就像一个很好的抛光剂。但不知道怎么做。事实上，我只看里面有什么。我只写回3个字母作为方向标记来解析返回的3个值。使用Mick#039添加冗余；s代码，我需要创建一个配置文件数据库和一个例程来将其写入对象扩展数据代码。做这一切可能会使事情进展太慢。这是一个昂贵的测试，只是为了有时间的测试
感谢更新的代码。我期待着去看看。看起来你做得很好！ 有没有机会上传一个带有一些基本3D对象的样例图形（现在，如果可能的话），我正在用C++/ARX玩ACIS解码器
谢谢！
页:
[1]
2