Author Topic: Zero elevation.  (Read 2212 times)

0 Members and 1 Guest are viewing this topic.

Bryco

  • Water Moccasin
  • Posts: 1849
Zero elevation.
« on: June 01, 2006, 09:53:40 AM »
I cant get a region normal to write, acad 2006. I know regions are goofy but it seems they are a planar entity and can and do assume a single normal. I am making a sub to send everything to zero z and so far this is the first entity that does't read/write on the normal.
The dims are  looking tricky as well.

Arizona

  • Guest
Re: Zero elevation.
« Reply #1 on: June 01, 2006, 11:54:30 AM »
I wrote this one at one time but it does not deal with regios or dimensions

Bryco

  • Water Moccasin
  • Posts: 1849
Re: Zero elevation.
« Reply #2 on: June 01, 2006, 12:56:04 PM »
Thanks Arizona, I have pretty well been doing the exact same as you, but with a normal check added as if say a circle is on a tilt I would rather set it manually or make an ellipse if reqd. than have it be set to zero. Normal works good most of the time. This must be a bug for the regions.

Bryco

  • Water Moccasin
  • Posts: 1849
Re: Zero elevation.
« Reply #3 on: June 02, 2006, 09:45:08 AM »
Has anyone managed to flatten a dim or do I need to use lisp?

Bryco

  • Water Moccasin
  • Posts: 1849
Re: Zero elevation.
« Reply #4 on: June 04, 2006, 12:23:39 PM »

I guess this is a lost and useless cause.
What is a dimension?
It's like a blockreference with a name starting with *d that you cannot find in vba
The dimension block has a lot of good info,
(the start,end and dimline pts)  but updates to the block (Like attributes) don't seem to update the dimension.
So I seem to have to make a new dimension and therefore new block since a block can only be used once.-(hopefully this is wrong)
The xdata(All the dimstyle overrides are in here) copies easily with getxdata->setxdata
The extensiondictionary has 1 item in it whenever the dim is attached to an object rather than clicking 2 empty points on the screen. However the item is empty rather than giving up say the objects handle or id which would be handy.


Jeff_M

  • King Gator
  • Posts: 3944
  • C3D user & customizer
Re: Zero elevation.
« Reply #5 on: June 04, 2006, 02:18:15 PM »
Bryco,
Since I don't use 3d for much, could you post a sample drawing with before & after objects of what you are wanting to do? I'm sure you've covered all the basics, but it sometimes helps to have others look at the same thing you are.

Bryco

  • Water Moccasin
  • Posts: 1849
Re: Zero elevation.
« Reply #6 on: June 04, 2006, 02:29:19 PM »
This is a really simple drawing. The dim is nicely in the world ucs but the start and end points are  touching the poly at its elevation. I would like to set those points to z=0, and retain the assocativety.

Bryco

  • Water Moccasin
  • Posts: 1849
Re: Zero elevation.
« Reply #7 on: June 04, 2006, 02:38:16 PM »
Running the flatten sub will bring the poly to 0 elev. (The sub is in pretty good shape)
Now if you stretch a poly vertex the dim adjusts perfectly whereas if you move a vertex the dim moves down in elev.

Code: [Select]
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

  • Water Moccasin
  • Posts: 1849
Re: Zero elevation.
« Reply #8 on: June 04, 2006, 02:50:01 PM »
And here is the beginnings of a dim flatten.
Code: [Select]
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

So far it looks good but isn't associative.
This usage of the block was started by Randall but noone could figure out the block handle. So I've mangled, thrown in some lisp. Perhaps if the Dxf 10,13,14,15 codes are read write they can be adjusted that way (I dont know how to set them)
Perhaps there is a way to set the extension dictionary

Jeff_M

  • King Gator
  • Posts: 3944
  • C3D user & customizer
Re: Zero elevation.
« Reply #9 on: June 04, 2006, 09:27:14 PM »
I'm just back from my Granddaughter's 2nd BD party, so I'll be taking a look now......