Jump to content
Sign in to follow this  
Pat Stanford

Extrude Polygons to 3D Locus Point

Recommended Posts

This script checkes each 2D Polygon on the active layer to see if there is exactly one 3D locus point within its boundaries. If there is exactly 1 loci, then a duplicate of the polygon is made and extruded. The original polygon and the locus point are deleted. At the end of the script all of the remaining polygons and locus points are selected.

I origianlly tried to use ForEveryObject to do this, but it seemed that the handle to the new Extrude was somehow getting placed into the stack and being handled in the routine designed to handle the loci. It was easier to write my own handlers and use global variables than to troubleshoot the ForEveryObject problem.

Use as you see fit, but please credit me if you use this.



Procedure ExtrudePolygonTo3DLoci;

{? 2007, Coviana, Inc - Pat Stanford pat@coviana.com}

{Licensed unde the GNU Lesser General Public License}

{This procedure steps through each 2D Polygon}

{on the active layer looking for 3D Loci located}

{with the boundary of the poly. If there is }

{exactly one 3D Loci within the Poly boundary}

{the polygon is extruded to the Z-Height of}

{the Loci and the Loci is deleted. If there are}

{no 3D Loci or more than 1 3D Loci, the polgon}

{is left untouched. Any remaining 2D Polygons}

{and 3D Loci will be selected at the end of}

{the procedure.}

Var PolyHandle, LocusHandle: Handle;



PolyArray:DynArray of Handle;

Procedure LocusHandler(LH_Locus, LH_Poly:Handle);

{This procedure takes the locus handle and}

{uses the Z+Height of the locus as the height}

{to extrude a copy ofthe polygon pointed to by}

{PolyHandle. The original polygon and the locus}

{point are then deleted.}

Var X1,Y1,LocusZ:Real; {X1,Y1 are dummy variables, we only need the LocusZ}

NewExtrude:Handle; {Dummy Variable for Duplicate}


GetLocus3D(LH_Locus,X1,Y1,LocusZ); {Get Height to extrude to}

BeginXtrd(0,LocusZ); {Start the extrude}

NewExtrude:=CreateDuplicateObject(LH_Poly,Nil); {Need a new object to extude}

EndXtrd; {End the extude}

DelObject(LH_Poly); {Delete the original polygon}

DelObject(LH_Locus); {Delete the locus point}


Procedure PolyHandler(PH_Poly:Handle); {PH_Poly is a handle to the polygon}

{This procedure gets the name of the polygon}

{changes it to one we can use. It then counts}

{the number of 3D Loci in the area of the}

{Polygon. If there is exactly 1 Loci, it passes}

{the Loci's handle to the LocusHandler procedure.}

Var S1,S2,S3,S4:String; {Strings to hold the criteria and polygon name}


S1:=GetName(PH_Poly); {Store the existing name}

S2:='COV_123-456-789'; {Set the temp name}

S3:=concat('Loc=',S2); {Set up the criteria for the poly area}

S4:=concat('(T=LOCUS3D) & (Loc=',CHR(39),S2,CHR(39),')');

SetName(PH_Poly,S2); {Set the poly name to the temp name}

If Count(S4)=1 then {If only one poly then}


DSelectAll; {DSelectAll}

SelectObj(S4); {Select the one locus point}

LocusHandler(FSActLayer,PH_Poly); {Call the LocusHandler procedure with the handle to the locus point}


SetName(PH_Poly,S1); {Restore the original poly name}


Begin {Main Procedure}





Allocate PolyArray[1..PolyCount];

{Make list of polys before we begin}

While PolyHandle<> Nil do

If GetType(PolyHandle)=5 then






Else PolyHandle:=NextObj(PolyHandle);

{Use List of Polys to handle Areas}

PolyIndex :=1;

While PolyIndex <= PolyCount do


PolyHandler(PolyArray[PolyIndex]); {call PolyHandler Procedure}

PolyIndex := PolyIndex + 1;






End; {Main Procedure}



Share this post

Link to post

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

Sign in to follow this  


7150 Riverwood Drive, Columbia, Maryland 21046, USA   |   Contact Us:   410-290-5114


© 2018 Vectorworks, Inc. All Rights Reserved. Vectorworks, Inc. is part of the Nemetschek Group.

  • Create New...