;; POLYDSOLID -Gilles Chanteau- 03/05/07
;; Pour créer des polysolides avec les versions antérieures à autoCAD 2007

(defun c:polysolid (/ erreur make_pline poly2solid AcDoc Space echo loop pt larg haut just ent)

  (vl-load-com)

  ;;===================================================;;

  (defun erreur	(msg)
    (if	(= msg "Fonction annulée")
      (princ)
      (princ (strcat "Erreur: " msg))
    )
    (vla-EndUndoMark
      (vla-get-ActiveDocument (vlax-get-acad-object))
    )
    (setvar "cmdecho" echo)
    (setq *error* m:err
	  m:err	nil
    )
    (princ)
  )

  ;;===================================================;;

  (defun make_pline (pt larg haut just)
    (setvar "cmdecho" 0)
    (command "_.pline" pt)
    (setvar "cmdecho" 1)
    (while (/= 0 (getvar "cmdactive"))
      (command pause)
    )
    (command)
    (poly2solid (entlast) larg haut just)
  )

  ;;===================================================;;

  (defun poly2solid
	 (ent larg haut just / pl1 pl2 l1 l2 reg)
    (setq ent (vlax-ename->vla-object ent))
    (cond
      ((= just "Gauche")
       (setq pl1 (vla-copy ent))
       (vla-offset ent larg)
       (setq pl2 (vlax-ename->vla-object (entlast)))
      )
      ((= just "Centre")
       (vla-offset ent (/ larg 2))
       (setq pl1 (vlax-ename->vla-object (entlast)))
       (vla-offset ent (/ larg -2))
       (setq pl2 (vlax-ename->vla-object (entlast)))
      )
      ((= just "Droite")
       (setq pl1 (vla-copy ent))
       (vla-offset ent (- larg))
       (setq pl2 (vlax-ename->vla-object (entlast)))
      )
    )
    (if	(or
	  (and (member (vla-get-objectName ent)
		       '("AcDbPolyline" "AcDbSpline")
	       )
	       (= (vla-get-Closed ent) :vlax-true)
	  )
	  (= (vla-get-objectName ent) "AcDbCircle")
	  (and (= (vla-get-objectName ent) "AcDbEllipse")
	       (= (vla-get-StartAngle ent) 0.0)
	       (= (vla-get-EndAngle ent) (* 2 pi))
	  )
	)
      (progn
	(setq reg (vlax-invoke Space 'addRegion (list pl1 pl2)))
	(if (< (vla-get-Area (car reg)) (vla-get-Area (cadr reg)))
	  (progn
	    (vla-boolean (cadr reg) acSubtraction (car reg))
	    (setq reg (cadr reg))
	  )
	  (progn
	    (vla-boolean (car reg) acSubtraction (cadr reg))
	    (setq reg (car reg))
	  )
	)
      )
      (setq l1	(vla-addLine
		  space
		  (vlax-3d-point (vlax-curve-getStartPoint pl1))
		  (vlax-3d-point (vlax-curve-getStartPoint pl2))
		)
	    l2	(vla-addLine
		  space
		  (vlax-3d-point (vlax-curve-getEndPoint pl1))
		  (vlax-3d-point (vlax-curve-getEndPoint pl2))
		)
	    reg	(car (vlax-invoke Space 'addRegion (list pl1 pl2 l1 l2)))
      )
    )
    (vla-addExtrudedSolid Space reg haut 0.0)
    (mapcar '(lambda (x) (vl-catch-all-apply 'vla-delete (list x)))
	    (list reg pl1 pl2 l1 l2)
    )
    (or (zerop (getvar "DELOBJ")) (vla-delete ent))
  )

  ;;===================================================;;

  
  (setq	AcDoc (vla-get-ActiveDocument (vlax-get-acad-object))
	Space (if (= 1 (getvar "CVPORT"))
		(vla-get-PaperSpace AcDoc)
		(vla-get-ModelSpace AcDoc)
	      )
	echo (getvar "cmdecho")
	m:err *error*
	*error* erreur
  )
  (vla-StartUndoMark AcDoc)
  (or (vlax-ldata-get "polysolid" "l")
      (vlax-ldata-put "polysolid" "l" 0.25)
  )
  (or (vlax-ldata-get "polysolid" "h")
      (vlax-ldata-put "polysolid" "h" 4.0)
  )
  (or (vlax-ldata-get "polysolid" "j")
      (vlax-ldata-put "polysolid" "j" "Centre")
  )
  (princ (strcat "\nParamètres courants -Largeur: "
		 (rtos (vlax-ldata-get "polysolid" "l"))
		 " -Hauteur: "
		 (rtos (vlax-ldata-get "polysolid" "h"))
		 " -Justification: "
		 (vlax-ldata-get "polysolid" "j")
	 )
  )
  (setq loop T)
  (while loop
    (initget "Objet Largeur Hauteur Justification")
    (setq pt
	   (getpoint
	     "\nSpécifiez le point de départ ou [Objet/Largeur/Hauteur/Justification] <Objet>: "
	   )
    )
    (cond
      ((or (null pt) (= pt "Objet"))
       (if (and
	     (setq ent (car (entsel)))
	     (or
	       (member (cdr (assoc 0 (entget ent)))
		       '("ARC" "CIRCLE" "ELLIPSE" "LWPOLYLINE")
	       )
	       (and (= (cdr (assoc 0 (entget ent))) "SPLINE")
		    (= (logand 8 (cdr (assoc 70 (entget ent)))) 8)
	       )
	     )
	   )
	 (progn
	   (setq larg (vlax-ldata-get "polysolid" "l")
		 haut (vlax-ldata-get "polysolid" "h")
		 just (vlax-ldata-get "polysolid" "j")
		 loop nil
	   )
	   (poly2solid ent larg haut just)
	 )
	 (prompt "\nEntité non valide.")
       )
      )
      ((listp pt)
       (setq larg (vlax-ldata-get "polysolid" "l")
	     haut (vlax-ldata-get "polysolid" "h")
	     just (vlax-ldata-get "polysolid" "j")
	     loop nil
       )
       (make_pline pt larg haut just)
      )
      ((= pt "Largeur")
       (if (setq
	     larg (getdist (strcat
			     "\nSpécifiez la largeur <"
			     (rtos (vlax-ldata-get "polysolid" "l"))
			     ">: "
			   )
		  )
	   )
	 (vlax-ldata-put "polysolid" "l" larg)
       )
      )
      ((= pt "Hauteur")
       (if (setq haut (getdist (strcat
				 "\nSpécifiez la hauteur <"
				 (rtos (vlax-ldata-get "polysolid" "h"))
				 ">: "
			       )
		      )
	   )
	 (vlax-ldata-put "polysolid" "h" haut)
       )
      )
      ((= pt "Justification")
       (initget "Gauche Centre Droite")
       (if (setq just
		  (getkword
		    (strcat
		      "\nEntrez la justification [Gauche/Centre/Droite] <"
		      (vlax-ldata-get "polysolid" "j")
		      ">: "
		    )
		  )
	   )
	 (vlax-ldata-put "polysolid" "j" just)
       )
      )
    )
  )
    (vla-EndUndoMark AcDoc)
    (setvar "cmdecho" echo)
    (setq *error* m:err
	  m:err	nil
    )
  (princ)
)