Round all polylines to nearest Z value

Hello,

I need to make one selectionset to all lines (lines and polylines) and round them to nearest Z value.

How can i do that?

Best regards,
Antonio Miranda

PS- I'm new in this world of VBA.

 

Antonio,
What do you have so far? I don't have time to write the whole thing but
I'll try to help.
Do you have your selection set code done yet?
Can you post what you have and we'll try to flesh it out?
The rounding function I sent you the other day should take care of the
rounding part.
This should get you going with the selection set part...if you don't already
have that.

'this function courtesy of Frank Oquendo - www.acadx.com

Public Function CreateSelectionSet(Optional ssName As String = "ss") As
AcadSelectionSet

Dim ss As AcadSelectionSet

On Error Resume Next
Set ss = ThisDrawing.SelectionSets(ssName)
If Err Then Set ss = ThisDrawing.SelectionSets.Add(ssName)
ss.Clear
Set CreateSelectionSet = ss

End Function


Sub RoundLinesZValue()


Dim lineset As AcadSelectionSet
Set lineset = CreateSelectionSet("lineset")


Dim dxfcode(0) As Integer
Dim dxfdata(0) As Variant

dxfcode(0) = 0
dxfdata(0) = "LINE,LWPOLYLINE,POLYLINE"


lineset.Select acSelectionSetAll, , , dxfcode, dxfdata

Dim setcount As Integer
setcount = lineset.count
Debug.Print "there are " & setcount & " LINES, LWPLINES, OR PLINES in
lineset"

if setcount > 0 then
'round z values here
'use select case on object types to handle each one accordingly as
required
end if


End Sub
hth
Mark

 

ok, here's a start with lines, now maybe you can work out the plines and
lwplines

'this function courtesy of Frank Oquendo - www.acadx.com

Public Function CreateSelectionSet(Optional ssName As String = "ss") As
AcadSelectionSet

Dim ss As AcadSelectionSet

On Error Resume Next
Set ss = ThisDrawing.SelectionSets(ssName)
If Err Then Set ss = ThisDrawing.SelectionSets.Add(ssName)
ss.Clear
Set CreateSelectionSet = ss

End Function


Sub RoundLinesZValue()


Dim lineset As AcadSelectionSet
Set lineset = CreateSelectionSet("lineset")


Dim dxfcode(0) As Integer
Dim dxfdata(0) As Variant

dxfcode(0) = 0
dxfdata(0) = "LINE,LWPOLYLINE,POLYLINE"


lineset.Select acSelectionSetAll, , , dxfcode, dxfdata

Dim setcount As Integer
setcount = lineset.count
Debug.Print "there are " & setcount & " LINES, LWPLINES, OR PLINES in
lineset"
Dim oEntity As AcadEntity
Dim startpoint As Variant
Dim endpoint As Variant
Dim newstartpoint(2) As Double
Dim newstartpointZ As Double
Dim newendpoint(2) As Double

Dim oLine As AcadLine
Dim oLWPline As AcadLWPolyline
Dim oPline As AcadPolyline

If setcount > 0 Then
For Each oEntity In lineset
Select Case TypeName(oEntity)
Case Is = "IAcadLine"
Debug.Print "line"
Set oLine = oEntity

startpoint = oLine.startpoint
endpoint = oLine.endpoint
Debug.Print "z startpoint begins: " & startpoint(2)
Debug.Print "z endpoint begins: " & endpoint(2)
newstartpointZ = SymArith(startpoint(2), 1)
newstartpoint(0) = startpoint(0)
newstartpoint(1) = startpoint(1)
newstartpoint(2) = newstartpointZ
oLine.startpoint = newstartpoint

newendpointZ = SymArith(endpoint(2), 1)
newendpoint(0) = endpoint(0)
newendpoint(1) = endpoint(1)
newendpoint(2) = newendpointZ
oLine.endpoint = newendpoint
oLine.Update
startpoint = oLine.startpoint
endpoint = oLine.endpoint
Debug.Print "z startpoint ends: " & startpoint(2)
Debug.Print "z endpoint ends: " & endpoint(2)


Case Is = "IAcadPolyline"
Debug.Print "Heavy pline"
Set oPline = oEntity
Debug.Print "Now fix Heavy pline"
Case Is = "IAcadLWPolyline"
Debug.Print "Light pline"
Set oLWPline = oEntity
Debug.Print "Now fix Light pline"
Case Else
Debug.Print TypeName(oEntity)
Debug.Print "What's he doing here? "
End Select
Next
End If
End Sub

'this function courtesty of
http://support.microsoft.com/default.aspx?scid=kb;;Q196652
Function SymArith(ByVal X As Double, Optional ByVal Factor As Double = 1) As
Double
SymArith = Fix(X * Factor + 0.5 * Sgn(X)) / Factor
End Function