Offset 3dpoly

How Offset 3d Polyline With Vba Code ?

Offset method don't work with 3D-Poly. You can extract coordinates with Coordinates property and write your own geometrical code to draw new 3D-Poly.

'SubName: Offset3dPoly

'Author: Joe Kycek, Date: 3/24/02

'Scope: Offset a 3dPoly with horizontal and vertical distances.

'

'

' Requirements:

'

' a) A 3dpoly object

' b) A horizontal offset distance from the 3dpoly to

' the new 3dpoly.

' c) A vertical offset distance from the 3dpoly to

' the new 3dpoly.

' d) A layer for the new 3dpoly.

'

'Return:

'

' i) A new 3dpoly object.

'

'Notes:

' 1) A positive horizontal distance value offsets to the Right.

' 2) A positive vertical distance value offsets vertically Up.

' 3) Just like the regular Offset command in AutoCad: Offsets

' that do not mathematically fit, may bring unexpected results.

' This sub uses the AutoCad offset function to achieve a part

' of its goals. So the rules regarding the standard

' AutoCad offset command apply.

'

Sub Offset3dPoly( _

o3dpoly As Acad3DPolyline, _

dDistanceHorizontal As Double, _

dDistanceVertical As Double, _

s3dPolyLayer As String, _

o3dpolynew As Acad3DPolyline)

Dim v2dPoly As Variant

Dim v3dPoly As Variant

Dim v3dPolyFlat As Variant

Dim o2dPoly As AcadPolyline

Dim o2dPolyOffset As AcadPolyline

Dim StartX As Double

Dim StartY As Double

Dim StartZ As Double

Dim EndX As Double

Dim EndY As Double

Dim EndZ As Double

Dim i As Integer

On Error GoTo 10

'Get the 3dpolys' coordinate array.

v3dPoly = o3dpoly.Coordinates

v3dPolyFlat = o3dpoly.Coordinates

'With the 3dpolys' coordinate array; flatten

'the z elevations to 0, so we can create a 2dpoly.

For i = 0 To ((UBound(v3dPolyFlat) + 1) / 3) - 1

v3dPolyFlat(3 * i + 2) = 0

Next

'get the 3dpolys starting and ending coordinates

'to be used later for checking.

StartX = v3dPoly(0)

StartY = v3dPoly(1)

StartZ = v3dPoly(2)

EndX = v3dPoly(UBound(v3dPoly) - 2)

EndY = v3dPoly(UBound(v3dPoly) - 1)

EndZ = v3dPoly(UBound(v3dPoly))

'Create a 2dPoly with the same x,y coordinates as the 3dpoly.

'Use this object later; for offsetting.

Set o2dPoly = ThisDrawing.ModelSpace.AddPolyline(v3dPolyFlat)

'If the 3dpoly is closed, or the 3dpoly's start and end coordinates are the same;

'then close the 2dpoly object: for offseting.

If o3dpoly.Closed = True _

Or _

StartX = EndX And StartY = EndY And StartZ = EndZ Then

o2dPoly.Closed = True

End If

'The api does not support a zero 2dpoly offset. But we could

'be creating a new 3dpoly that is vertically straight up or down from the

'original 3dpoly, with no offset,

'so... an if statement is needed here;

If dDistanceHorizontal 0 Then

'Create a 2dpoly object array; by the offset distance supplied.

v2dPoly = o2dPoly.offSet(dDistanceHorizontal)

'Create a new 2dPoly object from the object array.

Set o2dPolyOffset = v2dPoly(0)

'Get the offsetted 2dpoly coordinates

v2dPoly = o2dPolyOffset.Coordinates

'delete the offsetted 2dpoly.

o2dPolyOffset.Delete

Set o2dPolyOffset = Nothing

Else

'the horizontal offset is 0, so use the non-offsetted

'coordinates from the the new 2dpoly.

v2dPoly = o2dPoly.Coordinates

End If

'Next, Modify the offsetted 2dpolys' coordinates; by adding the original

'3dpoly z elevations plus the supplied Vertical additive.

For i = 0 To ((UBound(v2dPoly) + 1) / 3) - 1

v2dPoly(3 * i + 2) = v3dPoly(3 * i + 2) + dDistanceVertical

Next

'Create the new 3dPoly.

Set o3dpolynew = ThisDrawing.ModelSpace.Add3DPoly(v2dPoly)

'if the 2dpoly is closed, then close the new 3dpoly

If o2dPoly.Closed = True Then

o3dpolynew.Closed = True

End If

'Set the layer for the new 3dPoly.

o3dpolynew.Layer = s3dPolyLayer

10:

'delete the 2dpoly.

o2dPoly.Delete

Set o2dPoly = Nothing

End Sub

Private Sub CreateAWall()

Dim o3dpoly As Acad3DPolyline

Dim o3dpolynew As Acad3DPolyline

'This is just one example on how to use the

'Offset3dPoly sub, from a form.

'Lets create a 10' foot high wall that is 1' foot thick and is

'5' feet away from the original 3dpoly picked; and follows

'the picked 3dpolys' elevations.

frmMain.hide

On Error GoTo 10

'Pick the 3dpoly (I am using my own custom getentity utility)

Set o3dpoly = GetEntityByFilter("3D PolyLine", "3DPOLYLINE")

'let the Offset3dPoly sub do the work:

Offset3dPoly o3dpoly, 5, 0, "0", o3dpolynew

Offset3dPoly o3dpolynew, 0, 10, "0", o3dpolynew

Offset3dPoly o3dpolynew, 1, 0, "0", o3dpolynew

Offset3dPoly o3dpolynew, 0, -10, "0", o3dpolynew

10:

Set o3dpoly = Nothing

Set o3dpolynew = Nothing

frmMain.Show

End Sub