help with lisp routines
Hi everybody
I am using bricscad linux in my computer and I would like to use a routine similar to extrim, and with the help of two guys from the windows forum, I have two very nicer routines but only work in Windows, it is a shame.
Perhaps you could help me how to fix it, thanks a lot
routine number1:
(defun c:EET (/ *error* initial_set point1 point2 temp_set touching_set counter1)
(defun *error* (message)
(and message
(not (wcmatch (strcase message) "*BREAK*,*CANCEL*,*QUIT*"))
(princ (strcat "\nError: " message))
)
(command "._undo" "end")
)
(defun dxf (1code 1ent) (cdr (assoc 1code 1ent)))
(defun delta (a1 a2 / r1)
(cond
((> a1 (+ a2 pi))
(setq a2 (+ a2 (* 2.0 pi)))
)
((> a2 (+ a1 pi))
(setq a1 (+ a1 (* 2.0 pi)))
)
)
(setq r1 (- a2 a1))
(if (< r1 0.0)
(setq r1 (+ r1 (* 2.0 pi)))
)
r1
)
(defun VxGetTangentAtPoint (Obj Pnt / CurPar PntLst TmpPnt)
(setq PntLst (VxGetEndPoints Obj)
CurPar (cond
((equal Pnt (car PntLst) 1E-5)
(vlax-curve-getStartParam Obj)
)
((equal Pnt (cadr PntLst) 1E-5)
(vlax-curve-getEndParam Obj)
)
((setq TmpPnt (vlax-curve-getClosestPointTo Obj Pnt))
(if (<= (distance TmpPnt Pnt) 1E-5)
(vlax-curve-getParamAtPoint Obj TmpPnt)
)
)
(T nil)
)
)
(if CurPar
(angle '(0.0 0.0 0.0) (vlax-curve-getFirstDeriv Obj CurPar))
)
)
(defun VxGetEndPoints (Obj)
(list
(vlax-curve-getStartPoint Obj)
(vlax-curve-getEndPoint Obj)
)
)
(defun left_test (ls_object ls_point / temp_point temp_point2)
(setq temp_point (vlax-curve-getClosestPointTo
ls_object
ls_point
)
)
(setq normal (- (VxGetTangentAtPoint
ls_object
temp_point
)
(/ pi 2.0)
)
)
(if (< normal 0.0)
(setq normal (+ normal (* pi 2.0)))
)
(setq delta_angle (delta normal (angle temp_point ls_point)))
(if (or (< delta_angle (/ pi 2.0))
(> delta_angle (* 3.0 (/ pi 2.0)))
)
(setq side nil)
(setq side T)
)
side
)
(defun get_point (gp_point gp_object gp_trimmer_object gp_left /)
(entmake (list (cons 0 "CIRCLE") ; make a circle with radius 0.01
(cons 6 "CONTINUOUS")
(cons 8 "POWER")
(cons 10 gp_point)
(cons 39 0.0)
(cons 40 0.01)
; (cons 60 1)
(cons 62 2)
(cons 210 (list 0.0 0.0 1.0))
)
)
(setq bounds (entlast)) ; get the circle
(setq bounds_entity (entget (entlast))) ; get the circle's entity
(setq counter 0)
(setq gp_inters_list (vlax-invoke ; check for intersection object
(vlax-ename->vla-object (dxf -1 bounds_entity))
'IntersectWith
gp_object
acExtendNone
)
)
(entdel bounds)
(setq gp_inters_points nil)
(if gp_inters_list ; if there are intersections ...
(progn
(repeat (/ (length gp_inters_list) 3) ; convert the data to points
(setq gp_inters_points (cons (list (car gp_inters_list)
(cadr gp_inters_list)
(caddr gp_inters_list)
)
gp_inters_points
)
)
(setq gp_inters_list (cdddr gp_inters_list))
)
(setq point1 (car gp_inters_points)) ; there is at least one point
(if (> (length gp_inters_points) 1)
(setq point2 (cadr gp_inters_points)) ; get the second point if there is one ..
(setq point2 nil) ; or set the second point to nil
)
(if (/= point1 nil) ; left_test will error if the point is nil
(if (= (left_test trimmer_object point1) gp_left) ; point1 same side as trim side?
point1 ; yes, return point1
(progn ; no ...
(if point2 ; is there a point2?
point2 ; yes, return point2
nil ; no, return nil
)
)
)
)
)
nil
)
)
(defun do_trim (dt_trimmer_object dt_object_ename dt_intersection_list dt_left_side / )
(setq dt_intersection_list_points nil)
(setq dt_object (vlax-ename->vla-object dt_object_ename))
(if dt_intersection_list ; if there are intersections ...
(progn
(repeat (/ (length dt_intersection_list) 3) ; convert the data to points
(setq dt_intersection_list_points (cons (list (car dt_intersection_list)
(cadr dt_intersection_list)
(caddr dt_intersection_list)
)
dt_intersection_list_points
)
)
(setq dt_intersection_list (cdddr dt_intersection_list))
)
(foreach memb dt_intersection_list_points
(progn
(setq dt_intersection_point memb)
(setq dt_point3 (get_point dt_intersection_point ; intersection point
dt_object ; object to trim
dt_trimmer_object ; "trim to" object
dt_left_side ; "trim to" side
)
)
(if (/= dt_point3 nil)
(progn
(setq dt_trim_list (list (vlax-vla-object->ename dt_object) dt_point3))
(command "trim" (vlax-vla-object->ename dt_trimmer_object) "" dt_trim_list "")
)
)
)
)
)
)
)
(vl-load-com)
(command "._undo" "end")
(command "._undo" "begin")
(setq trimmer_selected nil)
(while (= trimmer_selected nil)
(setq trimmer_selected (entsel "\nSelect trimming edge: ")) ; get the "trim to" selection
(setq trimmer_entity (entget (car trimmer_selected))) ; get the "trim to" entity
(if (and (/= (cdr (assoc 0 trimmer_entity)) "LINE") : only accept these types
(/= (cdr (assoc 0 trimmer_entity)) "ARC")
(/= (cdr (assoc 0 trimmer_entity)) "SPLINE")
(/= (cdr (assoc 0 trimmer_entity)) "LWPOLYLINE")
(/= (cdr (assoc 0 trimmer_entity)) "POLYLINE")
(/= (cdr (assoc 0 trimmer_entity)) "CIRCLE")
(/= (cdr (assoc 0 trimmer_entity)) "ELLIPSE")
)
(setq trimmer_selected nil) ; try again if necessary
)
)
(setq trimmer_ename (cdr (assoc -1 trimmer_entity))) ; get the "trim to" ename
(redraw trimmer_ename 3) ; highlight the "trim to" selection
(setq trimmer_object (vlax-ename->vla-object trimmer_ename)) ; get the "trim to" object
(setq side_point (getpoint "\nSelect trimmed side: "))
(setq left_side (left_test trimmer_object side_point))
(vla-getboundingbox trimmer_object 'point1 'point2) ; get the bounding box for the "trim to" selection
(setq point1 (vlax-safearray->list point1) ; get the bounding box points
point2 (vlax-safearray->list point2)
)
(setq temp_set (ssget "_C" ; get entities in the bounding box into temp_set
(trans (list (car point1) (cadr point2) 0.) 0 1)
(trans (list (car point2) (cadr point1) 0.) 0 1)
'((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))
)
)
(ssdel (car trimmer_selected) temp_set)
(while (> (sslength temp_set) 0) ; while there are entities in temp_set ...
(setq object (vlax-ename->vla-object (ssname temp_set 0))) ; get the first entity
(if (setq intersection_list (vlax-invoke ; check for intersection with the "trim to" entity
trimmer_object
'IntersectWith
object
acExtendNone
)
)
(do_trim trimmer_object (ssname temp_set 0) intersection_list left_side)
; trim the crossing entity
)
(ssdel (ssname temp_set 0) temp_set) ; delete entity from temp_set
)
(command "._undo" "end")
(princ)
)
(defun printss (ss / counter)
(setq counter 0)
(while (< counter (sslength ss))
(print (entget (ssname ss counter)))
(setq counter (1+ counter))
)
)
thanks for the code Martin.
ROUTINE NUMBER2
;; By Joe Burke
<
p>
;; Comments and bug reports may be sent to lowercase@hawaii.rr.com.
;; What does CC2 do which ExpressTools extrim, AKA CookieCutter, doesn't?
;; Works with blocks, hatches and regions by exploding them.
;; Other object types which cannot be trimmed are left intact.
;; Works with objects which do not use a Continuous linetype.
;; Offers an option to delete all objects on visible layers either
;; inside or outside the selected trim object.
;; The interface is similar to extrim.
;; First extrim prompt:
;; Pick a POLYLINE, LINE, CIRCLE, ARC, ELLIPSE, IMAGE or TEXT for cutting edge...
;; Select objects:
;; Confusing because the routine does not allow multiple object selection.
;; Plus it works with some object types not mentioned, like splines.
;; First CookieCutter2 prompt:
;; Select circle or closed polyline, ellipse or spline for trimming edge:
;; The object must be closed or appear to be closed.
;; Second extrim prompt:
;; Specify the side to trim on:
;; Second CookieCutter2 prompt:
;; Pick point on side to trim:
;; Third CookieCutter2 prompt:
;; One of the following depending on whether the point picked is inside
;; or outside the trim object.
;; Erase all objects inside? [Yes/No] <N>:
;; Erase all objects outside? [Yes/No] <N>:
;; If Yes, all objects on visible layers are erased. If No it behaves
;; like extrim.
;; Both CC2 and extrim only operate on objects on visible layers.
;; The routine will display an additional prompt if one or more solid
;; hatches intersects the trim object.
;; Convert solid hatch to lines? [Yes/No] <N>:
;; If Yes, solid hatches are converted to lines using the ANSI31 pattern
;; and the lines are trimmed. If No, solid hatches are not trimmed.
;; Miscellaneous Notes:
;; The routine may be used to simply erase all objects inside or
;; outside the trim object.
;; The routine does not trim annotation objects such as text, mtext,
;; dimensions, leaders, mleaders and tables. The user may choose to
;; explode some of these objects types before running the routine.
;; It ignores xrefs. Bind xrefs beforehand if those block objects
;; should be trimmed.
;; Some cleanup may be needed after the routine ends.
;; The routine offsets the selected trim object inside or outside in
;; order to determine trim points. The offset distance is a variable
;; which depends on the size if the trim object. Likewise, if solid
;; hatches are converted to lines, the scale of the ANSI31 pattern
;; depends on the same variable.
;; The routine will end (exit) if offset fails or offset creates more
;; than one new object. Message at the command line:
;; "Problem detected with selected object. Try another. Exiting... "
;; Self-intersecting trim objects are not allowed. The select object
;; part of the routine checks for this and cycles if a self-intersecting
;; object is selected.
;; Version history:
;;; Version 1.0 posted at the swamp 8/26/2008.
;;; Version 1.1 9/25/2008. Minor bug fix to set the correct layer of
;;; an attribute converted to text after exploding a block.
(defun c:CookieCutter2 ( / error acad doc ps osm as om emode pmode offd
elev locked typ typlst e d notclosed splinetyp
i o intpts lst sc minpt maxpt hidelst dellst
offsetename offsetobj trimename trimobj curcoord
mark postlst coord reg selfinter ext UCSpkpt
UCStrimobjpts WCStrimobjpts delother side
ssinside ssall sscross ssoutside ssintersect
solidflag solidans solidlst CC:GetScreenCoords
CC:TraceObject CC:GetInters CC:SpinBar CC:AfterEnt
CC:CommandExplode CC:ExpNestedBlock CC:FirstLastPts
CC:GetBlock CC:AttributesToText CC:UniformScale
CC:SSVLAList CC:Inside CC:UnlockLayers
CC:RelockLayers CC:ZoomToPointList Extents)
(defun error (msg)
(cond
((not msg))
((wcmatch (strcase msg) "QUIT,CANCEL"))
(T (princ (strcat "\nError: " msg)))
)
(setvar "pickstyle" ps)
(setvar "osmode" osm)
(setvar "autosnap" as)
(setvar "edgemode" emode)
(setvar "projmode" pmode)
(setvar "orthomode" om)
(setvar "elevation" elev)
(setvar "offsetdist" offd)
(setvar "cmdecho" 1)
(if (and offsetobj (not (vlax-erased-p offsetobj)))
(vla-delete offsetobj)
)
(foreach x hidelst
(if (not (vlax-erased-p x))
(vlax-put x 'Visible acTrue)
)
)
(if (and trimobj (not (vlax-erased-p trimobj)))
(vla-highlight trimobj acFalse)
)
(CC:RelockLayers locked)
(vla-EndUndoMark doc)
(princ)
) ;end error
;;;; START SUB-FUNCTIONS ;;;;
;; by Tony Tanzillo
;; Returns the lower left and upper right corners of a point list.
(defun Extents (plist)
(list
(apply 'mapcar (cons 'min plist))
(apply 'mapcar (cons 'max plist))
)
) ;end
;; Argument: WCS point list.
;; In lieu of (command "zoom" "object"...) which requires 2005 or later.
(defun CC:ZoomToPointList (pts)
(setq pts (Extents pts))
(vlax-invoke acad 'ZoomWindow (car pts) (cadr pts))
(vlax-invoke acad 'ZoomScaled 0.85 acZoomScaledRelative)
) ;end
;; Unlock any locked layers in the active file.
;; Returns a list of unlocked layers if any.
(defun CC:UnlockLayers (doc / laylst)
(vlax-for x (vla-get-Layers doc)
;filter out xref layers
(if
(and
(not (vl-string-search "|" (vlax-get x 'Name)))
(eq :vlax-true (vla-get-lock x))
)
(progn
(setq laylst (cons x laylst))
(vla-put-lock x :vlax-false)
)
)
)
laylst
) ;end
;; Argument: a list of layer objects from CC:UnlockLayers.
(defun CC:RelockLayers (lst)
(foreach x lst
(vl-catch-all-apply 'vla-put-lock (list x :vlax-true))
)
) ;end
;Returns the coordinates of the current view, lower left and upper right.
;Works in a rotated view.
(defun CC:GetScreenCoords ( / ViwCen ViwDim ViwSiz VptMin VptMax)
(setq ViwSiz (/ (getvar "VIEWSIZE") 2.0)
ViwCen (getvar "VIEWCTR")
ViwDim (list
(* ViwSiz (apply '/ (getvar "SCREENSIZE")))
ViwSiz
)
VptMin (mapcar '- ViwCen ViwDim)
VptMax (mapcar '+ ViwCen ViwDim)
)
(list VptMin VptMax)
) ;end
;; By John Uhden. Return T if point is inside point list.
;; Check how many intersections found with an "infinite" line (like a ray).
;; If the number intersections is odd, point is inside.
;; If the number intersections is even, point is outside.
(defun CC:Inside (p ptlist / p2 i n #)
;; define a point at a sufficiently large distance from p...
(setq p2 (polar p 0.0 (distance (getvar "extmin")(getvar "extmax"))))
;; Make sure the ptlist is closed...
(if (not (equal (car ptlist) (last ptlist) 1e-10))
(setq ptlist (append ptlist (list (car ptlist))))
)
(setq i 0 # 0 n (1- (length ptlist)))
(while (< i n)
(if (inters p p2 (nth i ptlist)(nth (1+ i) ptlist))
(setq # (1+ #))
)
(setq i (1+ i))
)
(not (zerop (rem # 2)))
) ; end CC:Inside
;Argument: selection set.
;Returns: list of VLA objects.
(defun CC:SSVLAList (ss / obj lst i)
(setq i 0)
(if ss
(repeat (sslength ss)
(setq obj (vlax-ename->vla-object (ssname ss i))
lst (cons obj lst)
i (1+ i)
)
)
)
(reverse lst)
) ;end
;; Returns a list of primary enames after ename ent.
;; Filter out sub-entities and entities not in current space.
(defun CC:AfterEnt (ent / lst entlst)
(while (setq ent (entnext ent))
(setq entlst (entget ent))
(if
(and
(not (wcmatch (cdr (assoc 0 entlst)) "ATTRIB,VERTEX,SEQEND"))
(eq (cdr (assoc 410 entlst)) (getvar "ctab"))
)
(setq lst (cons ent lst))
)
)
(reverse lst)
) ;end
(defun CC:SpinBar (sbar)
(cond ((= sbar "\") "|")
((= sbar "|") "/")
((= sbar "/") "-")
(t "\")
)
) ;end
(defun CC:TraceObject (obj / typlst typ ZZeroList TracePline
TraceCE TraceSpline)
;;;; start trace sub-functions ;;;;
;; Argument: 2D or 3D point list.
;; Returns: 3D point list with zero Z values.
(defun ZZeroList (lst)
(mapcar '(lambda (p) (list (car p) (cadr p) 0.0)) lst)
)
;; Argument: vla-object, a heavy or lightweight pline.
;; Returns: WCS point list if successful.
;; Notes: Duplicate adjacent points are removed.
;; The last closing point is included given a closed pline.
(defun TracePline (obj / param endparam anginc tparam pt blg
ptlst delta inc arcparam flag)
(setq param (vlax-curve-getStartParam obj)
endparam (vlax-curve-getEndParam obj)
;anginc (* pi (/ 7.5 180.0)) ;;;; note 7.5 here vs 2.5 at circle
anginc (* pi (/ 2.5 180.0)) ;; the two should be the same
)
(while (<= param endparam)
(setq pt (vlax-curve-getPointAtParam obj param))
;Avoid duplicate points between start and end.
(if (not (equal pt (car ptlst) 1e-12))
(setq ptlst (cons pt ptlst))
)
;A closed pline returns an error (invalid index)
;when asking for the bulge of the end param.
(if
(and
(/= param endparam)
(setq blg (abs (vlax-invoke obj 'GetBulge param)))
(/= 0 blg)
)
(progn
(setq delta (* 4 (atan blg)) ;included angle
inc (/ 1.0 (1+ (fix (/ delta anginc))))
arcparam (+ param inc)
)
(while (< arcparam (1+ param))
(setq pt (vlax-curve-getPointAtParam obj arcparam)
ptlst (cons pt ptlst)
arcparam (+ inc arcparam)
)
)
)
)
(setq param (1+ param))
) ;while
(if (> (length ptlst) 1)
(progn
(setq ptlst (vl-remove nil ptlst))
(ZZeroList (reverse ptlst))
)
)
) ;end
;; Argument: vla-object, an arc, circle or ellipse.
;; Returns: WCS point list if successful.
(defun TraceCE (obj / startparam endparam anginc
delta div inc pt ptlst)
;start and end angles
;circles don't have StartAngle and EndAngle properties.
(setq startparam (vlax-curve-getStartParam obj)
endparam (vlax-curve-getEndParam obj)
;;;;;;;;;;;;;; note change here, was using 7.5 ;;;;;;;;;;;;;
;anginc (* pi (/ 7.5 180.0))
;; This version is from SuperFlatten.
;; I think it returns a tighter trace.
anginc (* pi (/ 2.5 180.0))
)
(if (equal endparam (* pi 2) 1e-6)
(setq delta endparam)
;added abs 6/23/2007, testing
(setq delta (abs (- endparam startparam)))
)
;Divide delta (included angle) into an equal number of parts.
(setq div (1+ (fix (/ delta anginc)))
inc (/ delta div)
)
;Or statement allows the last point on an open ellipse
;rather than using (<= startparam endparam) which sometimes
;fails to return the last point. Not sure why.
(while
(or
(< startparam endparam)
(equal startparam endparam 1e-12)
;(equal startparam endparam)
)
(setq pt (vlax-curve-getPointAtParam obj startparam)
ptlst (cons pt ptlst)
startparam (+ inc startparam)
)
)
(ZZeroList (reverse ptlst))
) ;end
(defun TraceSpline (obj / startparam endparam ncpts inc param
fd ptlst pt1 pt2 ang1 ang2 a)
(setq startparam (vlax-curve-getStartParam obj)
endparam (vlax-curve-getEndParam obj)
ncpts (vlax-get obj 'NumberOfControlPoints)
inc (/ (- endparam startparam) (* ncpts 6))
param (+ inc startparam)
fd (vlax-curve-getfirstderiv obj param)
ptlst (cons (vlax-curve-getStartPoint obj) ptlst)
)
(while (< param endparam)
(setq pt1 (vlax-curve-getPointAtParam obj param)
ang1 (angle pt1 (mapcar '+ pt1 fd))
param (+ param inc)
pt2 (vlax-curve-getPointAtParam obj param)
fd (vlax-curve-getfirstderiv obj param)
ang2 (angle pt2 (mapcar '+ pt2 fd))
a (abs (@delta ang1 ang2))
)
(if (> a 0.00436332)
(setq ptlst (cons pt1 ptlst))
)
)
;add last point and check for duplicates
(if
(not
(equal
(setq pt1 (vlax-curve-getEndPoint obj)) (car ptlst) 1e-8))
(setq ptlst (cons pt1 ptlst))
)
(ZZeroList (reverse ptlst))
) ;end
;;;; primary trace function ;;;;
(setq typlst '("AcDb2dPolyline" "AcDbPolyline" "AcDbSpline"
"AcDbCircle" "AcDbEllipse")
)
(or
(eq (type obj) 'VLA-OBJECT)
(setq obj (vlax-ename->vla-object obj))
)
(setq typ (vlax-get obj 'ObjectName))
(if (vl-position typ typlst)
(cond
((or (eq typ "AcDb2dPolyline") (eq typ "AcDbPolyline"))
(cond
((or
(not (vlax-property-available-p obj 'Type))
(= 0 (vlax-get obj 'Type))
)
(TracePline obj)
)
)
)
((or (eq typ "AcDbCircle") (eq typ "AcDbEllipse"))
(TraceCE obj)
)
((eq typ "AcDbSpline")
(TraceSpline obj)
)
)
)
) ;end CC:TraceObject
; Arguments:
; firstobj: first object - ename or vla-object
; nextobj: second object - ename or vla-object
; mode - extend options
; acExtendNone: extend neither object
; acExtendThisEntity: extend first object
; acExtendOtherEntity: extend second object
; acExtendBoth: extend both objects
; Returns a WCS point list or nil if intersection not found.
(defun CC:GetInters (firstobj nextobj mode / coord ptlst)
(if (= (type firstobj) 'ENAME)
(setq firstobj (vlax-ename->vla-object firstobj)))
(if (= (type nextobj) 'ENAME)
(setq nextobj (vlax-ename->vla-object nextobj)))
(if
(not
(vl-catch-all-error-p
(setq coord (vl-catch-all-apply 'vlax-invoke
(list firstobj 'IntersectWith nextobj mode)))
)
)
(repeat (/ (length coord) 3)
(setq ptlst (cons (list (car coord) (cadr coord) (caddr coord)) ptlst))
(setq coord (cdddr coord))
)
)
(reverse ptlst)
) ;end
;; Note 7/24/2008, saw the annonymous *E81 block thing again as in
;; SuperFlatten. It happens when trying to explode an NUS block.
;; In this case a grid block (was xref bound) was NUS. The grid lines
;; were exploded, but the column blocks inside it were not.
;; All of them were placed in the *E81 block.
;; I suppose there might be a report about this. At the end you could
;; check the blocks which remain in the drawing. If any has a name
;; like *E81, report, "A non-uniformly scaled block could not be exploded."
(defun CC:CommandExplode (obj / lay mark attlst name exlst newattlst)
(setq mark (entlast))
(if
(and
(not (vlax-erased-p obj))
(eq "AcDbBlockReference" (vlax-get obj 'ObjectName))
)
(progn
(setq lay (vlax-get obj 'Layer)
attlst (vlax-invoke obj 'GetAttributes)
)
(vl-cmdf "._explode" (vlax-vla-object->ename obj))
;; Is this still fixing error in error handler?
;; Yes it is IMPORTANT!
(command)
(if
(and
(not (eq mark (entlast)))
(setq exlst (CC:SSVLAList (ssget "_p")))
)
(progn
(setq newattlst (CC:AttributesToText attlst))
(foreach x exlst
(if (eq "AcDbAttributeDefinition" (vlax-get x 'ObjectName))
(vla-delete x)
)
)
(setq exlst (vl-remove-if 'vlax-erased-p exlst))
(if newattlst (setq exlst (append exlst newattlst)))
;If an exlpoded object is on layer 0, put it on the
;layer of the exploded object. If its color is byBlock,
;change color to byLayer.
(foreach x exlst
(if (eq "0" (vlax-get x 'Layer))
(vlax-put x 'Layer lay)
)
(if (zerop (vlax-get x 'Color))
(vlax-put x 'Color 256)
)
)
)
)
)
) ;if
;(setq exlst (vl-remove-if 'vlax-erased-p exlst))
(foreach x exlst
(if
(and
(not (vlax-erased-p x))
(eq "AcDbBlockReference" (vlax-get x 'ObjectName))
)
(CC:ExpNestedBlock x)
)
)
) ;end CC:CommandExplode
;; Argument: block reference vla-object.
;; Explode the block passed and any nested blocks.
;; Doesn't deal with attributes yet. Convert to text.
;; Based on code by TW-Vacation at theswamp.
;; Leave this function as is. Trying to condense it
;; will only cause problems.
(defun CC:ExpNestedBlock (obj / lay lst attlst)
;; Do SpinBar here because exploding many blocks is what
;; causes the routine to take a long time in some cases.
(princ
(strcat "\rProcessing blocks... "
(setq *sbar (CC:SpinBar *sbar)) "\t")
)
(if
(and
obj
(not (vlax-erased-p obj))
)
(cond
((not (CC:UniformScale obj))
(CC:CommandExplode obj)
)
(T
(setq lay (vlax-get obj 'Layer))
(if (eq "AcDbBlockReference" (vlax-get obj 'ObjectName))
(setq attlst (CC:AttributesToText (vlax-invoke obj 'GetAttributes)))
)
;; This is primarily intended to catch NUS blocks which
&nb
Comments
-
Please surround code with code tags in the future - there's a reason for them. As for your question, I don't have the time right now but if a week or so from now the question is still unanswered then I'll help you out.
Regards,
Daniel
0 -
Dear Jorg,
unfortnately, the Lisp engine as used under Linux is still not yet complete regarding all those COM based VLA/VLAX and VLR functions ...
There are no technical (implementation) problems at all - simply, it needs some time to complete - we hope to get this completed during next 3 months;
then, you Lisp code as provided will work under Linux without any specific problems.
Very sorry for this news - but as said, Lisp will be completed next time.0 -
Please surround code with code tags in the future
Perhaps the forum should have a brief instruction explaining this. I see a little button titled 'insert code' just above the text window, but nothing else and no explantion. Many, perhaps most, forum users are not regulars and have no special inside knowledge.
0 -
Some background: the COM API (also named Active-X) is a typical Windows thing, which only can exist in a MicroSoft Windows OS environment: it is entirely structured around the Windows Registry where applications that offer COM functionality, register all COM classes and methods they support. For an application like Bricscad this concerns many thousands(!) of methods.
So, on non-MSWindows platforms COM is not available, and Lisp VLA/VLAX and VLR functions are COM based. In order to as yet allow Lisp programmers to keep using these valuable functions, for the Linux version we need to create alternative paths that connect from VLA/VLAX functions to the code that would have been called if the COM mechanism existed.
The good news is that it is possible. Bad news is that it requires lots of work, if only by the sheer number of functions that need to be 're-connected'.
Other good news is that the execution time of these re-connected functions strongly improves because we can skip the horribly slow marshalling process that hampers MSWindows COM.
0