[编程交流] 三维实体管道需要Lisp

(defun c:sumsweeplengths ( / TMatrixFromTo ss i sum ent dir1 dir2 dir3 pm zdir tmat ll ur len )
 (vl-load-com)
 
 (defun 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.))
   )
 )
 (command "_.ucs" "_w")
 (prompt "\nSelect 3D SOLIDS created with SWEEP command")
 (setq ss (ssget '((0 . "3DSOLID"))))
 (setq i -1 sum 0.0)
 (while (setq ent (ssname ss (setq i (1+ i))))
   (if ent (setq ent (vlax-ename->vla-object ent)))
   (if (vlax-property-available-p ent 'SolidType)
     (if (eq (vla-get-SolidType ent) "Sweep")
       (progn
         (setq dir1 (mapcar '+ (vlax-safearray->list (vlax-variant-value (vla-get-principaldirections ent))) '(0.0 0.0 0.0)))
         (setq dir2 (cdddr (mapcar '+ (vlax-safearray->list (vlax-variant-value (vla-get-principaldirections ent))) '(0.0 0.0 0.0 0.0 0.0 0.0))))
         (setq dir3 (cdddr (cdddr (mapcar '+ (vlax-safearray->list (vlax-variant-value (vla-get-principaldirections ent))) '(0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0)))))
         (setq pm (vlax-safearray->list (vlax-variant-value (vla-get-principalmoments ent))))
         (cond 
           ( (equal (cadr pm) (caddr pm) 1.0) 
             (setq zdir dir1)
           )
           ( (equal (car pm) (caddr pm) 1.0)
             (setq zdir dir2)
           )
           ( (equal (car pm) (cadr pm) 1.0) 
             (setq zdir dir3)
           )
         )
         (command "_.ucs" "_za" '(0.0 0.0 0.0) zdir)
         (setq tmat (TMatrixFromTo 1 0))
         (vla-transformby ent (vlax-tmatrix tmat))
         (vla-getboundingbox ent 'll 'ur)
         (setq ll (vlax-safearray->list ll))
         (setq ur (vlax-safearray->list ur))
         (cond 
           ( (and (> (caddr ur) 0) (> (caddr ll) 0) (> (caddr ur) (caddr ll)))
             (setq len (abs (- (caddr ur) (caddr ll))))
           )
           ( (and (> (caddr ur) 0) (> (caddr ll) 0) (< (caddr ur) (caddr ll)))
             (setq len (abs (- (caddr ll) (caddr ur))))
           )
           ( (and (< (caddr ur) 0) (< (caddr ll) 0) (< (caddr ur) (caddr ll)))
             (setq len (abs (- (caddr ur) (caddr ll))))
           )
           ( (and (< (caddr ur) 0) (< (caddr ll) 0) (> (caddr ur) (caddr ll)))
             (setq len (abs (- (caddr ll) (caddr ur))))
           )
           ( (and (< (caddr ur) 0) (> (caddr ll) 0))
             (setq len (abs (- (caddr ll) (caddr ur))))
           )
           ( (and (> (caddr ur) 0) (< (caddr ll) 0))
             (setq len (abs (- (caddr ur) (caddr ll))))
           )
         )
         (setq tmat (TMatrixFromTo 0 1))
         (vla-transformby ent (vlax-tmatrix tmat))
         (command "_.ucs" "_p")
       )
     )
   )
   (setq sum (+ len sum))
 )
 (prompt "\nSum of all lengths of 3D SOLIDS created with SWEEP command is : ")(princ (rtos sum 2 20))
 (princ)
)
(defun c:ssl nil (c:sumsweeplengths))

(defun c:xpipe(/ ACTDOC ACTLAY ACTSP BASELINE 
         BASESET CIRENT DICOUNT DIVDID 
         EXCIR LAYST OBJTYPE OLDDIA 
         OLDECHO STARTPT XORD YORD 
         ZORD *ERROR*) 
 (vl-load-com) 
 (defun *error* (msg) 
   (vla-put-Lock actLay laySt) 
   (setvar "CMDECHO" oldEcho) 
   (vla-EndUndoMark actDoc) 
   (princ) 
   ); end of *error* 
 (if(not pipe:exDia)(setq pipe:exDia 40.0)) 
 (setq actDoc 
   (vla-get-ActiveDocument 
     (vlax-get-Acad-object)) 
  actLay(vla-get-ActiveLayer actDoc) 
       oldDia pipe:exDia 
       oldEcho(getvar "CMDECHO") 
  ); end setq 
 (vla-StartUndoMark actDoc) 
 (setvar "CMDECHO" 0) 
 (if(= 0(vla-get-ActiveSpace actDoc)) 
   (setq actSp(vla-get-PaperSpace actDoc)) 
   (setq actSp(vla-get-ModelSpace actDoc)) 
   ); end if 
 (setq laySt(vla-get-Lock actLay)) 
 (vla-put-Lock actLay :vlax-false) 
 (setq pipe:exDia 
   (getreal 
     (strcat 
       "\nSpecify pipe diameter <"(rtos pipe:exDia)">: "))) 
 (if(null pipe:exDia)(setq pipe:exDia oldDia))
 (initget "Yes No") 
  (setq delFlag 
         (getkword "\nDelete extrude path(s)? [Yes/No] <No>: ")) 
   (if(null delFlag)(setq delFlag "No")) 
 (princ "\n<<< Select objects to extrude and press Enter >>>") 
 (if 
   (setq baseSet 
     (ssget '((-4 . "<OR")(0 . "*LINE")(0 . "CIRCLE") 
          (0 . "ARC")(0 . "ELLIPSE")(-4 . "OR>") 
          (-4 . "<NOT")(-4 . "<OR")(0 . "SPLINE") 
               (0 . "MLINE")(-4 . "OR>")(-4 . "NOT>")))) 
   (progn 
     (setq baseSet(vl-remove-if 'listp 
                             (mapcar 
           'cadr 
           (ssnamex baseSet)))) 
     (foreach pathEnt baseSet 
     (setq baseLine 
       (vlax-ename->vla-object pathEnt) 
      objType(vla-get-ObjectName baseLine) 
           startPt(vlax-curve-getStartPoint baseLine) 
           3dPos 
       (vlax-curve-getFirstDeriv baseLine 
         (vlax-curve-getParamAtPoint baseLine startPt)) 
          diCount(strlen 
           (itoa 
        (apply 'max 
         (mapcar 'abs 
          (mapcar 'fix startPt))))) 
      divDid "1" 
      ); end setq 
     (repeat diCount 
  (setq divDid(strcat divDid "0")) 
  ); end repeat 
     (setq divDid(atoi divDid)) 
     (if(/= 0.0(car 3dPos)) 
  (setq XOrd(/(car 3dPos)divDid)) 
  (setq XOrd (car 3dPos)) 
  ); end if 
     (if(/= 0.0(cadr 3dPos)) 
  (setq YOrd(/(cadr 3dPos)divDid)) 
  (setq YOrd (cadr 3dPos)) 
  ); end if 
     (if(/= 0.0(nth 2 3dPos)) 
  (setq ZOrd(/(nth 2 3dPos)divDid)) 
  (setq ZOrd (nth 2 3dPos)) 
  ); end if 
     (setq 3dPos(list XOrd YOrd ZOrd)) 
 (setq exCir 
   (vla-addCircle actSp 
     (vlax-3d-Point startPt) 
     (/ pipe:exDia 2))) 
 (vla-put-Normal exCir(vlax-3D-point 3dPos)) 
 (setq cirEnt(vlax-vla-object->ename exCir)) 
 (command "_.extrude" cirEnt "" "_p" pathEnt) 
 (command "_.erase" cirEnt "")
(if(= "Yes" delFlag) 
   (vla-delete baseLine) 
      ); end if 
  ); end foreach 
     (vla-put-Lock actLay laySt) 
     (setvar "CMDECHO" oldEcho) 
     (vla-EndUndoMark actDoc) 
      ); end progn 
     ); end if 
   (princ) 
   ); end  of c:xpipe