pipe.lsp

Autocad-2005-简体中文-解密版.zip

;;;--------------------------------------------------------------------;
;;;       Function:  CHANGE-PIPE-LIST                                  ;
;;;                                                                    ;
;;;    Description:  This function will be called inside a             ;
;;;                  :vlr-modified event and is invoked by             ;
;;;                  reactor-pipe-circle reactor call back. Its        ;
;;;                  purpose is to modify the reactor which            ;
;;;                  was invoked.                                      ;
;;;                                                                    ;
;;;                  Required Functions:                               ;
;;;                     change-pipe                                    ;
;;;                                                                    ;
;;;      Arguments:                                                    ;
;;;         reactor = a valid vlr object reactor. Filled in by the     ;
;;;                   calling reactor.                                 ;
;;;        arg-list = argument list filled in by the calling reactor.  ;
;;;                   Filled in by the calling reactor.                ;
;;;                                                                    ;
;;; Returned Value:  A valid vlr reactor object.                       ;
;;;                                                                    ;
;;;          Usage:  Intended to be called from a reactor call back.   ;
;;;                 (change-pipe-list reactor arg-list)                ;
;;;--------------------------------------------------------------------;
(defun change-pipe-list	(reactor arg-list)
  (foreach pipe	(VLR-Data reactor)
    (change-pipe pipe)
  )
  (VLR-Data-Set reactor nil)
)

;;;--------------------------------------------------------------------;
;;;       Function:  CHANGE-PIPE                                       ;
;;;                                                                    ;
;;;    Description:  This function will modify the pipe created        ;
;;;                  from the path line.                               ;
;;;                                                                    ;
;;;                  Required Functions:                               ;
;;;                     make-pipe                                      ;
;;;                                                                    ;
;;;      Arguments:                                                    ;
;;;         vla-obj = a valid vla object.                              ;
;;;                                                                    ;
;;; Returned Value:  A valid vla object.                               ;
;;;                                                                    ;
;;;          Usage:                                                    ;
;;;                 (change-pipe vla-obj)                              ;
;;;--------------------------------------------------------------------;
(defun change-pipe (vla-obj)
  (if (and vla-obj (not (vlax-erased-p vla-obj)))
    (progn
      (foreach extrudion (vlax-ldata-get vla-obj "extrude-list")
	(if (not (vlax-erased-p extrudion))
	  (vla-Erase extrudion)
	)
      )
      (if (not (vlax-erased-p vla-obj))
	(vlax-ldata-put
	  vla-obj
	  "extrude-list"
	  (make-pipe vla-obj (vlax-ldata-get vla-obj "circle"))
	)
      )
    )
  )
)

;;;--------------------------------------------------------------------;
;;;       Function:  MAKE-PIPE-REACTOR                                 ;
;;;                                                                    ;
;;;    Description:  This function will modify the pipe created        ;
;;;                  from the path line.                               ;
;;;                                                                    ;
;;;                  Required Functions:                               ;
;;;                     change-pipe                                    ;
;;;                     reactor-pipe-line                              ;
;;;                     reactor-pipe-circle                            ;
;;;                                                                    ;
;;;      Arguments:                                                    ;
;;;            line = a valid vla line object.                         ;
;;;          circle = a valid vla circle object.                       ;
;;;                                                                    ;
;;; Returned Value:  A valid vlr object reactor                        ;
;;;                                                                    ;
;;;          Usage:                                                    ;
;;;                 (make-pipe-reactor                                 ;
;;;                        vla-line-object vla-circle-Object)          ;
;;;--------------------------------------------------------------------;
(defun make-pipe-reactor (line circle)
  (vlax-ldata-put line "circle" circle)
  (vlax-ldata-put circle "line" line)
  (change-pipe line)
  (list
    (VLR-Object-reactor
      (list line)
      nil
      (list (cons :vlr-modified (function reactor-pipe-line)))
    )
    (VLR-Object-reactor
      (list circle)
      nil
      (list (cons :vlr-modified (function reactor-pipe-circle)))
    )
  )
)

;;;--------------------------------------------------------------------;
;;;       Function:  GET-PIPE-BASE                                     ;
;;;                                                                    ;
;;;    Description:  This function is responsible for building an      ;
;;;                  ActiveX circle object for the pipe base.          ;
;;;                                                                    ;
;;;                  Note: It's possible use (entsel).                 ;
;;;                                                                    ;
;;;                  Required Functions:                               ;
;;;                     get-model-space                                ;
;;;                                                                    ;
;;;      Arguments:  none                                              ;
;;;                                                                    ;
;;; Returned Value:  A valid vla circle object.                        ;
;;;                                                                    ;
;;;          Usage:                                                    ;
;;;                 (get-pipe-base)                                    ;
;;;--------------------------------------------------------------------;
(defun get-pipe-base (/ obj)
  (setq	obj (VLA-addCIRCLE
	      (get-model-space)
	      (vlax-3d-point '(5.0 5.0 0.0))
	      5
	    )
  )
  (vla-put-Normal obj (vlax-3d-point '(0.0 0.0 1.0)))
  (vla-put-Color obj acred)
  obj
)

;;;--------------------------------------------------------------------;
;;;       Function:  GET-PIPE-EXTRUDE                                  ;
;;;                                                                    ;
;;;    Description:  This function is responsible for building an      ;
;;;                  ActiveX object for the pipe extrusion.            ;
;;;                                                                    ;
;;;                  Note: It's possible use (entsel).                 ;
;;;                                                                    ;
;;;                  Required Functions:                               ;
;;;                     get-model-space                                ;
;;;                                                                    ;
;;;      Arguments:  none                                              ;
;;;                                                                    ;
;;; Returned Value:  A valid vla polyline object.                      ;
;;;                                                                    ;
;;;          Usage:                                                    ;
;;;                 (get-pipe-extrude)                                 ;
;;;--------------------------------------------------------------------;
(defun get-pipe-extrude (/ obj Points ptlstlen PointDataA PointData)

(setq Points (mapcar 'float '(0 0 0  0 10 0  -7 23 0  -10 30 0)))
(setq ptlstlen (length Points))
(setq PointDataA (vlax-make-safearray vlax-vbDouble (cons 0 (1- ptlstlen))))
(vlax-safearray-fill PointDataA Points)
(setq PointData (vlax-make-variant PointDataA (logior vlax-vbarray vlax-vbDouble)))

  (setq obj (vla-Addpolyline
              (get-model-space)
              ;; all points need to be reals
              PointData
            )
  )
  ;;; all normals need to be reals
  (vla-put-Normal obj (vlax-3d-point '(0.0 1.0 0.0)))
  (vla-put-Color obj acred)
  obj
)


;;;--------------------------------------------------------------------;
;;;       Function:  C:PIPE-TST                                        ;
;;;                                                                    ;
;;;    Description:  This function aids in the creation of a circle    ;
;;;                  object and a path which will create a "smart"     ;
;;;                  pipe able to be modified.                         ;
;;;                                                                    ;
;;;                  Required Functions:                               ;
;;;                    get-pipe-extrude                                ;
;;;                    get-pipe-base                                   ;
;;;                    make-pipe-reactor                               ;
;;;                                                                    ;
;;;                                                                    ;
;;;      Arguments:  none                                              ;
;;;                                                                    ;
;;; Returned Value:  A valid vla object reactor.                       ;
;;;                                                                    ;
;;;          Usage: (C:PIPE-TST) or PIPE-TST from                      ;
;;;                 the ACAD Command: prompt.                          ;
;;;--------------------------------------------------------------------;
(defun C:PIPE-TST (/ line circle)
  (setq line (get-pipe-extrude))
  (setq circle (get-pipe-base))
  (if (and line circle)
    (make-pipe-reactor line circle)
  )
(princ)
  )

;;;--------------------------------------------------------------------;
;;;       Function:  C:PIPE-INFO                                       ;
;;;                                                                    ;
;;;    Description:  This function displays a help file in the ACAD    ;
;;;                  Command: prompt.                                  ;
;;;                                                                    ;
;;;      Arguments:  none                                              ;
;;;                                                                    ;
;;; Returned Value:  none                                              ;
;;;                                                                    ;
;;;          Usage: (C:COPYSELF-INFO) or COPYSELF-INFO from            ;
;;;                 the ACAD Command: prompt.                          ;
;;;--------------------------------------------------------------------;
(defun C:PIPE-INFO ()
  (textscr)
    (princ "\nThis file contains a demonstration of a path based on a polyline.")
    (princ "\nCreates a path - polyline and a base curve - circle. ")
    (princ "\n")
    (princ "\nThe 3d figure will be created as an extrusion of the circle ")
    (princ "\nalong the polyline (they are colored red). When you change the ")
    (princ "\npath or the circle the 3d figure will be updated.")
  (princ)
)

;;;--------------------------------------------------------------------;
;;; Add the functions within this file to the global functions list    ;
;;; to be used by the C:REACT-TEST-INFO function in R-INFO.LSP         ;
;;;--------------------------------------------------------------------;
(setq *REACT-TEST-COMMANDS-INFO*
       (cons (list "PIPE-TST" "PIPE-INFO")
	     *REACT-TEST-COMMANDS-INFO*
       )
)