I noticed this some time ago, but only recently had time to try it. Hopefully you can still make use of this, though I learned a lot while doing it anyway. 
Code:
;;; AUTOSECT CREATES A NEW DRAWING FROM
;;; THE SECTION OF A 3DSOLID.
;;; ARGUMENTS: THE 3DSOLID
;;; THREE 3D POINTS
;;; DWG FILE NAME (EX. "C:\\TEMP\\FOO.DWG")
(defun autosect (3dob p1 p2 p3 f-nm / ACTIVEDOC ACTVIEW ADD2BLK AUTOSECTERR AUTOSECTPREVERR
BLOCKS BOOL-AREA CRUSHREG GC:TMATRIXFROMTO HATCH I-LOOPS MAXPT MINPT N
O-LOOPS OBJ P-AV REG REG-BITS REG-BOOL REG-EXPL REG-N REG-NM REG-NORM
REG-OCSNM REG-ORDR REG-UCS REG-VECS RMS SCSESS T-BLK-1 TMP_DNM UCSS
WRLD-UCS X)
(vl-load-com)
;; gc:TMatrixFromTo [obtained from THESWAMP.org, written by Gile]
;; Returns the 4x4 transformation matrix form a coordinate system
;; to another one.
;;
;; Arguments
;; from an to: the same arguments as for the trans function.
(defun gc:TMatrixFromTo (from to)
(append
(mapcar
(function
(lambda (v o)
(append (trans v from to T) (list o))
)
)
(list '(1. 0. 0.) '(0. 1. 0.) '(0. 0. 1.))
(trans '(0. 0. 0.) to from)
)
(list '(0. 0. 0. 1.))
)
)
;; ADD2BLK COPIES AN OBJECT (OB) INTO A BLOCK (BL).
;; DELETES ORIGINAL IF NON-NIL FLG
;; RETURNS: THE COPY OF THE VLA-OBJECT
(defun add2blk (ob bl flg / BLOB XFRARR)
(setq xfrarr (vlax-make-safearray vlax-vbObject '(0 . 0)))
(vlax-safearray-put-element xfrarr 0 ob)
(setq blob (car
(vlax-safearray->list
(vlax-variant-value
(vla-copyobjects
(vla-get-document ob)
xfrarr
bl
)
)
)
)
)
(if flg
(vla-delete ob)
)
blob
)
(setq activedoc (vla-get-activedocument (vlax-get-acad-object)))
(setq ucss (vla-get-usercoordinatesystems activedoc))
(setq blocks (vla-get-blocks activedoc))
(vla-startundomark activedoc)
(vlax-invoke activedoc 'setvariable "NOMUTT" 1)
(vlax-invoke activedoc 'setvariable "CMDECHO" 0)
;; AUTOSECTERR IS A BASIC ERROR HANDLER FOR AUTOSECT
(defun autosecterr (errmsg / )
(if (= 8 (logand 8 (vlax-invoke activedoc 'getvariable "UNDOCTL")))
(vla-endundomark activedoc)
); if
(vl-cmdf "undo" 1)
(setq rms errmsg)
(if autosectpreverr
(setq *error* autosectpreverr)
); if
(princ rms)
(princ)
); defun
;; CRUSHREG ACCEPTS A REGION, OR A LIST CONTAINING REGIONS.
;; RETURNS LIST OF OBJECTS OBTAINED BY EXPLODING THEM.
(defun crushreg (ob / OBS RGN)
(cond ((listp (setq rgn ob))
(if (vl-member-if
'(lambda (x) (= "AcDbRegion" (vla-get-objectname x)))
rgn
)
(foreach n rgn (setq obs (append obs (crushreg n))))
(setq obs rgn)
)
)
((= "AcDbRegion" (vla-get-objectname rgn))
(setq obs (append obs (crushreg (vlax-invoke rgn 'explode))))
)
(t (setq obs (list rgn)))
)
obs
)
(setq obj (if (equal (type 3dob) 'ENAME)
(vlax-ename->vla-object 3dob)
3dob
); if
autosectpreverr *error*
*error* autosecterr
)
(if (and (= 'VLA-OBJECT (type obj))
(= "AcDb3dSolid" (vla-get-objectname obj))
(vl-file-directory-p (vl-filename-directory f-nm))
(not (vl-member-if
'vl-catch-all-error-p
(mapcar
'(lambda (x) (vl-catch-all-apply 'vlax-3d-point (list x)))
(list p1 p2 p3)
)
)
)
(setq reg (vlax-invoke obj 'sectionsolid p1 p2 p3))
)
(progn
(setq n 0
reg-nm (vla-get-handle reg)
)
(while (not (vl-catch-all-error-p
(vl-catch-all-apply
'vla-item
(list
ucss
(setq reg-ocsnm (strcat reg-nm (itoa n)))
)
)
)
)
(setq n (1+ n))
)
(setq reg-norm (if (minusp (caddr (setq reg-norm (vlax-get reg 'normal))))
(mapcar '* reg-norm (list -1.0 -1.0 -1.0))
reg-norm
)
reg-vecs (mapcar '(lambda (x) (trans x reg-norm 0))
(list (list 1.0 0.0 0.0) (list 0.0 1.0 0.0))
)
p-av (mapcar '/ (mapcar '+ p1 p2 p3) (list 3.0 3.0 3.0))
reg-ucs (vlax-invoke ucss
'add
p-av
(mapcar '+ p-av (car reg-vecs))
(mapcar '+ p-av (cadr reg-vecs))
reg-ocsnm
)
)
(vlax-put activedoc 'activeucs reg-ucs)
(if (vl-catch-all-error-p
(setq wrld-ucs (vl-catch-all-apply 'vla-item (list ucss "world-ucs")))
)
(setq wrld-ucs (vlax-invoke ucss
'add
(list 0.0 0.0 0.0)
(list 1.0 0.0 0.0)
(list 0.0 1.0 0.0)
"world-ucs"
)
)
(progn
(vl-catch-all-apply 'vla-delete (list wrld-ucs))
(setq wrld-ucs (vlax-invoke ucss
'add
(list 0.0 0.0 0.0)
(list 1.0 0.0 0.0)
(list 0.0 1.0 0.0)
"world-ucs"
)
)
)
)
(vla-transformby reg (vlax-tmatrix (gc:tmatrixfromto 1 0)))
(vlax-put activedoc 'activeucs wrld-ucs)
(vl-catch-all-apply 'vla-delete (list reg-ucs))
(setq reg (add2blk reg
(setq t-blk-1 (vlax-invoke
blocks
'add
'(0.0 0.0 0.0)
"*u"
)
)
"Y"
)
)
(vla-getboundingbox reg 'minpt 'maxpt)
(vlax-safearray-put-element minpt 2 0.0)
(vlax-safearray-put-element maxpt 2 0.0)
(setq minpt (vlax-safearray->list minpt)
maxpt (vlax-safearray->list maxpt)
)
(vlax-invoke reg 'move minpt (mapcar '/
(mapcar '+ minpt maxpt)
(list 2.0 2.0 2.0)
)
)
(vla-update reg)
(setq reg-expl (crushreg reg)
reg-bits (vlax-invoke t-blk-1 'addregion reg-expl)
reg-ordr (vl-sort-i (mapcar 'vla-get-area reg-bits) '>)
o-loops (append o-loops (list (nth (car reg-ordr) reg-bits)))
reg-bool (vla-copy (car o-loops))
n 1
)
(while (< n (length reg-bits))
(progn
(setq bool-area (vla-get-area reg-bool)
reg-n (nth (nth n reg-ordr) reg-bits)
)
(vla-boolean reg-bool acUnion (vla-copy reg-n))
(if (> (vla-get-area reg-bool) bool-area)
(setq o-loops (append o-loops (list reg-n)))
(progn
(vla-boolean reg-bool acSubtraction (vla-copy reg-n))
(setq i-loops (append i-loops (list reg-n)))
)
)
(setq n (1+ n))
)
)
(setq hatch (vlax-invoke
t-blk-1
'addhatch
achatchpatterntypepredefined
"SOLID"
:vlax-false
achatchobject
)
)
(foreach n o-loops (vlax-invoke hatch 'appendouterloop (list n)))
(foreach n i-loops (vlax-invoke hatch 'appendinnerloop (list n)))
(vla-put-associativehatch hatch :vlax-false)
(vla-evaluate hatch)
(vlax-for x t-blk-1
(if (= "AcDbRegion" (vla-get-objectname x))
(vl-catch-all-apply 'vla-delete (list x))
(progn
(vl-catch-all-apply 'vla-put-layer (list x "0"))
(vl-catch-all-apply 'vla-put-linetype (list x "Continuous"))
(vl-catch-all-apply 'vla-put-color (list x 8))
)
)
)
(vl-catch-all-apply 'vla-put-color (list hatch 8))
(setq tmp_dnm (vl-filename-mktemp (strcat (vl-filename-base f-nm) ".dwg"))
f-nm (strcat (vl-filename-directory f-nm) (vl-filename-base f-nm) ".dwg")
actview (vla-get-activeviewport activedoc)
)
(vlax-put actview 'direction (list 0.0 0.0 1.0))
(vla-put-activeviewport activedoc actview)
(vl-cmdf "-wblock" tmp_dnm (vla-get-name t-blk-1))
(if (or (not (findfile f-nm))
(vl-file-delete (findfile f-nm))
)
(setq scsess (not (null (vl-file-copy tmp_dnm f-nm))))
)
)
)
(setq *error* autosectpreverr)
(vla-endundomark activedoc)
(vl-cmdf "undo" 1)
scsess
); defun
Note that this is not set up as a command, as I don't know your precise requirements. You can write a separate lisp or macro to call it with appropriate arguments.
sections
Reply With Quote
Re: sections
