社区 › VB › 零海拔。

Bryco 发表于 2006-6-1 09:53:40

零海拔。

我找不到一个正常的区域来写作，acad 2006。我知道区域是愚蠢的，但是看起来它们是一个平面实体，并且可以假设一个单一的法线。我正在创建一个sub来发送所有的东西到zero z，到目前为止，这是第一个不能正常读/写的实体。
昏暗看起来也很棘手。
**** Hidden Message *****

Arizona 发表于 2006-6-1 11:54:30

我曾经写过这个，但它不涉及区域或维度

Bryco 发表于 2006-6-1 12:56:04

谢谢亚利桑那州，我一直在做和你完全相同的事情，但是添加一个正常的检查，就好像说一个圆圈在倾斜时，我宁愿手动设置它，或者如果reqd.做一个椭圆，而不是把它设置为零。正常大部分时间效果很好。这一定是区域的错误。

Bryco 发表于 2006-6-2 09:45:08

是否有人成功地将dim展平，或者我需要使用lisp？

Bryco 发表于 2006-6-4 12:23:39

我想这是一个徒劳无益的事业。
什么是维度？
这就像一个名称以*d开头的块引用，在vba中是找不到的
尺寸块有很多有用的信息，
(开始、结束和尺寸线点)，但是对块(如属性)的更新似乎不会更新尺寸。
因此，我似乎必须创建一个新的维度和新的块，因为块只能使用一次。-(希望这是错误的)
使用getxdata->setxdata可以轻松复制扩展数据(所有dimstyle覆盖都在这里)
每当将dim附加到对象时，extensiondictionary中都有1个项目，而不是单击屏幕上的2个空点。然而，该项目是空的，而不是放弃说，对象句柄或id，这将是方便的。

Jeff_M 发表于 2006-6-4 14:18:15

Bryco，
因为我不怎么使用3d，你能不能贴一张你想做的之前和之后对象的样图？我相信你已经涵盖了所有的基础知识，但有时让别人看着和你一样的东西会有所帮助。

Bryco 发表于 2006-6-4 14:29:19

这是一个非常简单的绘图。昏暗在世界ucs中很好，但是起点和终点在它的高度接触到多边形。我想将这些点设置为z=0，并保持一致性。

Bryco 发表于 2006-6-4 14:38:16

现在，如果你拉伸一个多边形顶点，dim会完美调整，而如果你移动一个顶点，dim会在elev中向下移动。
Sub Flatten()
    Dim Ent As AcadEntity
    Dim obj As AcadEntity
    Dim oLine As AcadLine
    Dim oMline As AcadMLine
    Dim oCirc As AcadCircle
    Dim oArc As AcadArc
    Dim oEll As AcadEllipse
    Dim oPline As AcadLWPolyline
    Dim oHatch As AcadHatch
    Dim oSpline As AcadSpline
    Dim oReg As AcadRegion
    Dim oPoint As AcadPoint
    Dim oBref As AcadBlockReference
    Dim oMt As AcadMText
    Dim oLeader As AcadLeader
    Dim Atts, Att
    Dim P1, P2, P3
    Dim Min, Max
    Dim Zero(2) As Double, El(2) As Double
   
    For Each Ent In ThisDrawing.ModelSpace
      If TypeOf Ent Is AcadLine Then
            Set oLine = Ent
            oLine.StartPoint = Z0(oLine.StartPoint)
            oLine.EndPoint = Z0(oLine.EndPoint)
            If oLine.Length = 0 Then oLine.Delete
      End If
      If TypeOf Ent Is AcadMLine Then
            Set oMline = Ent
            P1 = oMline.Coordinates
            If P1(2) = P1(5) Then
                El(2) = P1(2)
                oMline.Move El, Zero
            End If
   
      End If
      
      If TypeOf Ent Is AcadCircle Then
            Set oCirc = Ent
            If N1(oCirc) Then
                oCirc.Center = Z0(oCirc.Center)
            End If
      End If
      If TypeOf Ent Is AcadArc Then
            Set oArc = Ent
            If N1(oArc) Then
                oArc.Center = Z0(oArc.Center)
            End If
      End If
      If TypeOf Ent Is AcadEllipse Then
            Set oEll = Ent
            If N1(oEll) Then
                oEll.Center = Z0(oEll.Center)
            End If
      End If
      If TypeOf Ent Is AcadLWPolyline Then
            Set oPline = Ent
            If N1(oPline) Then
                oPline.Elevation = 0
            End If
      End If
      If TypeOf Ent Is AcadHatch Then
            Set oHatch = Ent
            If N1(oHatch) Then
                oHatch.Elevation = 0
            End If
      End If
      If TypeOf Ent Is AcadSpline Then
            Set oSpline = Ent
            If oSpline.IsPlanar Then
                P1 = oSpline.FitPoints
                If P1(2) = P1(5) Then
                  El(2) = P1(2)
                  oSpline.Move El, Zero
                End If
            End If
      End If
      If TypeOf Ent Is Acad3DPolyline Then
            Dim oP3 As Acad3DPolyline
            'yada
      End If
      If TypeOf Ent Is AcadRegion Then
            Set oReg = Ent
            If N1(oReg) Then
                Ent.GetBoundingBox Min, Max
                If Rd(Min(2), Max(2)) Then
                  Max = Min
                  Max(2) = 0
                  Ent.Move Min, Max
                End If
            End If
      End If
      If TypeOf Ent Is AcadPoint Then
            Set oPoint = Ent
            oPoint.Coordinates = Z0(oPoint.Coordinates)
      End If
      If TypeOf Ent Is AcadBlockReference Then
            Set oBref = Ent
            If N1(oBref) Then
                oBref.InsertionPoint = Z0(oBref.InsertionPoint)
                If oBref.HasAttributes Then
                  Atts = oBref.GetAttributes
                  For Each Att In Atts
                        Att.InsertionPoint = Z0(Att.InsertionPoint)
                        'Att.TextAlignmentPoint = Z0(Att.TextAlignmentPoint)
                  Next
                End If
            End If
      End If
      If TypeOf Ent Is AcadMText Or TypeOf Ent Is AcadText Then
            If N1(Ent) Then
                Ent.InsertionPoint = Z0(Ent.InsertionPoint)
            End If
      End If
      If TypeOf Ent Is AcadLeader Then
            Set oLeader = Ent
            P1 = oLeader.Normal
            If N1(oLeader) Then
                El(2) = oLeader.Coordinate(0)(2)
                oLeader.Move El, Zero
            End If
      End If
      If TypeOf Ent Is AcadDimension Then
   
      
      End If
    Next
End Sub
Function Z0(P1 As Variant) As Variant
    P1(2) = 0
    Z0 = P1
End Function
Function N1(Ent As AcadEntity) As Boolean
    Dim n As Variant, Norm(2) As Double
    Norm(2) = 1
    n = Ent.Normal
    If Rd(n(0), 0) Then
      If Rd(n(1), 0) Then
            If Rd(n(2), 1) Then
                N1 = True
                If TypeOf Ent Is AcadRegion Or _
                     TypeOf Ent Is AcadLeader Then
                  Else
                  Ent.Normal = Norm
                End If
            ElseIf Rd(n(2), -1) Then
                If TypeOf Ent Is AcadCircle Then
                  Ent.Normal = Norm
                  N1 = True
                End If
            End If
      End If
    End If
End Function
Function MoveByBB(Ent As AcadEntity)
    Dim Min, Max
    Ent.GetBoundingBox Min, Max
    If Rd(Min(2), Max(2)) Then
      Max = Min
      Max(2) = 0
      Ent.Move Min, Max
    End If
End Function
Function Rd(num1 As Variant, num2 As Variant) As Boolean
    Dim dRet As Double
    dRet = num1 - num2
    If Abs(dRet) < 0.00000001 Then Rd = True
End Function

Bryco 发表于 2006-6-4 14:50:01

这是暗淡变平的开始。
Sub DimPointsToZero()
    Dim StartPoint As Variant
    Dim EndPoint As Variant
    Dim DimLinePoint As Variant
    Dim DimBlock As AcadBlock
    Dim sName As String
    Dim Ent As AcadEntity
    Dim oPoint As AcadPoint
    Dim oDim As AcadDimension
    Dim i As Integer, j As Integer
    Set oDim = EntSel
    sName = vbAssoc(oDim, 2)
    Set DimBlock = ThisDrawing.Blocks(sName)
    For i = 0 To DimBlock.Count - 1
      Set Ent = DimBlock(i)
      If TypeOf Ent Is AcadPoint Then
            Set oPoint = Ent
            Select Case j
                Case 0
                  StartPoint = oPoint.Coordinates
                  StartPoint(2) = 0
                  oPoint.Coordinates = StartPoint
                Case 1
                  EndPoint = oPoint.Coordinates
                  EndPoint(2) = 0
                  oPoint.Coordinates = EndPoint
                Case 2
                  DimLinePoint = oPoint.Coordinates
                  DimLinePoint(2) = 0
                     oPoint.Coordinates = DimLinePoint
            End Select
            j = j + 1
            oPoint.Update
      End If
    Next i
Debug.Print oDim.Rotation
Debug.Print vbAssoc(oDim, 50)
Dim newDim As AcadDimension
Dim Cs As AcadBlock
Set Cs = CurrentSpace
Dim xT, xV
oDim.GetXData "", xT, xV
Set newDim = Cs.AddDimRotated(StartPoint, EndPoint, DimLinePoint, vbAssoc(oDim, 50))
newDim.Layer = oDim.Layer
newDim.TrueColor = oDim.TrueColor
If Not IsEmpty(xV) Then
    newDim.SetXData xT, xV
End If
newDim.StyleName = oDim.StyleName
oDim.Delete
End Sub
到目前为止，它看起来不错，但没有联想。
块的这种用法是由Randall开始的，但是没有人能找出块句柄。所以我咬断了，加上一些口齿不清的话。也许如果Dxf 10，13，14，15代码是可读写的，它们可以这样调整(我不知道如何设置)
也许有一种方法可以设置扩展字典

Jeff_M 发表于 2006-6-4 21:27:14

我刚从我孙女的第二次BD派对回来，所以我现在要看看......

查看完整版本: 零海拔。