3dSolid长度。乐筑天下 - Powered by Discuz! Archiver

Bryco 发表于 2007-5-26 18:49:28

3dSolid长度。

这是一种通过圆柱体中心画一条线的方法。
它使用了一个相当简单的子DrawCylinderCenterlineLine和几个做一些数学运算的函数。
PrincipalDirections是关键，它包括立体的x、y、z向量。z向量是法线，并给出挤出方向。(这一项的帮助有点你爸爸好吗。)你可能已经知道，三维实体在cad vba中没有太多可用的信息，PrincipalDirections结合BoundingBox给了我们更多的信息。在你变换对象之前，边界框没有多大用处，因为你知道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的函数vbassoc的打印输出(在此网站上)。米似乎意味着一个椭圆形(即椭圆，圆或多圆)，而
莫古吉΢似乎意味着一个盒子。使用该信息和线的长度与体积属性的关系的组合，可以创建一类基本实体。
**** Hidden Message *****

SEANT 发表于 2007-5-26 21:04:07

我调查了主方向的使用，但结果不一致。我不得不说您的例程比我的尝试表现得好得多，但它确实遇到了在“奇怪”UCS中创建的圆柱体的问题（至少在我的设置中）。使用附加文件，如何为您绘制线条？
圆柱体是在“UCSDuringCyl”ucs活动的情况下创建的。

SEANT 发表于 2007-5-27 04:06:07

在更仔细地研究了这个问题之后，确认哪个向量是最长的应该不会太麻烦——并相应地进行。
感谢这个密钥。它将允许完成一些一直在衰落的BOM编码。

DaveW 发表于 2007-5-27 14:52:22

非常好的VB方法。感谢您分享该代码。它令人印象深刻。我肯定会学习它以了解更多关于使用矩阵的信息。
我目前正在使用ARX返回边界框，而不管方向和对称性如何。一旦我有了它，我就要完成了。您、Mick和其他一些人的所有这些想法都非常有趣。它们当然以不同的方式具有价值。我发现很难足够清楚地看到任何东西，我对您的代码和Mick的代码缺乏了解，很难看到我真正需要或想要的东西，以及如何在我的原始代码中部署它。实际上，我在很大程度上已经解决了这个问题。当然，有一些方法可以改进我所做的事情，但是我现在的工作非常好。我不愿意在没有看到明显的好处和进行更改的领域的情况下，用存量用户的所有后果来屠宰现有代码。你的帖子肯定会教我更多关于矩阵问题的知识，我希望我能够在不久的将来部署一个更快的例程，没有假设。谢谢。我的问题是以典型的业务问题来加速业务。我们可以更便宜地构建它，因为我们部署的技术有效。但是我们是扩展它来实现更多的利润，还是把技术卖给别人？这些都与VB无关。我的大脑太满了。

Bryco 发表于 2007-5-27 17:46:48

Dave很难知道软件在哪里或多久有用一次。
相同的软件在另一个类似的情况下可能不工作，只是因为公司的结构不同。
至于使用这段代码，Seant提出了一个很好的观点，我仍在考虑，它需要一些工作。
预科——我在网上了解他们，他们需要一段时间来掌握，但他们是值得的。我花了一段时间将C代码等转换成vba，但现在使用矩阵就像使用翻译公式一样简单。

MickD 发表于 2007-5-27 18:52:57

我不使用3D对象，但请记住它是可用的ACIS解码器，可以很容易地使用，例如在其中一个帖子中提取绘图样本的长度，使用解码器，您会得到：
然后，只需制作一个阅读器，您就可以为两点提取正确的值：

Bryco 发表于 2007-5-27 19:54:13

我记得前段时间我和罗布·基什在研究这个问题时玩过主方向。我们无法得到一致的结果，我认为如果你做一些修改，比如在一端的一个角度上做一个切片，它不会像预期的那样工作
也可以使用实体的其他属性，但同样，任何修改都会影响结果，因此它无法工作。问题在于，acis实体需要足够通用，以处理任何类型的建模，而这些额外信息可能会妨碍其他类型的应用程序
我当时的做法不是最好的解决方案，但却是最简单的。最后，我不得不将数据存储在实体上。为此，我只是将“世界”点存储为扩展数据中的轴向量（因为向量和点基本上是相同的东西），这些扩展数据会被更新和复制等。“实体”有一个更新扩展数据方法，每当对象移动、旋转等时都会使用，因此这是我们所做工作的最佳解决方案，而且是可靠的
可以在创建时或稍后添加点，方法是在面上拾取3个点，或设置ucs并获取这些值，我会将点存储为x=（1.0,0.0,1.0），以此类推。
要使用它，我会提取点，使用它们构建矩阵，并将实体转换为wcs，获取bbox值，然后在后台将其旋转回来，这样用户就不会看到任何东西。因为我只对长度感兴趣（在本例中是z轴），所以我只使用max-min bbox z值，因为我已经从我的目录中新建了宽度和高度
Dave有一些有趣的方法可以做到这一点，而无需拾取点，但在某些地方，最终用户“可能”需要分配或选择哪个轴是哪个轴。上面的方法是一种“置而不理”的版本，使用目录类型系统（例如，钢型材）可能会更优雅一些，而Dave的方法则更复杂一些，但更自由一些，因为他可以选择任何类型的实体并提取数据，它更适合用户正在做的工作类型
Dave的一大好处是，他还可以使用传统实体，而如果我想使用上述方法，我必须将数据添加到每个实体中，虽然这并不难做到，但对于一个在多个方向上有大量实体的模型来说，这可能会很乏味 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

DaveW 发表于 2007-5-28 12:04:57

除了米克用轮廓创建3D OCS的基本等价物之外，当对象既不对称又不与WCS对齐时，ACSI和抛物面建模引擎都有舍入误差。您不能指望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"宽。我花了175,000.00美元来规避这个错误！是的，我被程序员骗了，应该不到20,000.00美元。这是一件相当大的事情。直到今天我还在为此付出代价。
我对你的人的代码感兴趣的地方是冗余。我的解决方案除了2个区域之外运行得很好。第一个是当物体非常复杂并且与WCS不对齐时，获得正确的3个暗度。我的测量程序有时会提供错误的数字。它们像拇指一样突出。我一直能够得到它们，但是在首先遍历每个3D实体的每个面和程序的长度之间，速度不够快。我们为了加快速度而放松了它，但是其中一些物体会流血。另一个问题是，我的程序在大于/小于的语句中比较两边的长度。当一个对象有相同大小的边（2条或3条）时，如果任何一条与另一条边相等的边被更改，我的end命令事件无法自动更新方向标签。我确实对此有一些处理，因为方向字母被删除，导出时会收到警告，或者您可以始终确保您的对象边略有不同。即便如此，我在这方面花了很长时间，以至于添加冗余检查来填补我最后一个漏洞的想法就像是一个精细的润色。但不确定是怎么做到的。事实上，我只读取了那里的内容。我只写回3个字母作为方向标签来解析返回的3个值。要使用Mick的代码添加冗余，我需要创建一个配置文件数据库和一个例程来将其写入对象xdata代码。做所有这些可能会减慢速度。仅仅为了进行时间测试，这是一项昂贵的测试。
感谢更新的代码。我期待着检查它。看起来你做得很好！

Bryco 发表于 2007-5-28 13:16:49

搞乱这一个，路易斯，因为它为我做了所有错误的事情，在massprop中出现了一个有趣的向量，我现在要追踪它。

Bryco 发表于 2007-5-28 13:25:39

谢谢;
我正在研究这个：
数据是从实体中提取的，上面写着：“其中一个形状移动到0，0，0”

页: [1] 2

乐筑天下's Archiver

3dSolid长度。