[编程交流] 自动图案填充

;/////////////////////////////////////////////////////////////////////////////////////////
;
; Start-Up.
;
(defun C:ANSI37 (/ CL01 CL02 RAD# DEG# PT01 PT02 PT03 PT04 DLEN E01 CPS SUS HPRP HSCL HWID HANG LNAM LCLR LTYP)
 (ANSI37_SUS)
 (princ))
(princ "\nANSI37.lsp loaded... Type ANSI37 to start.")
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Save User Settings.
;
(defun ANSI37_SUS ()
 (setq SUS_LST (list "cmdecho" "orthomode" "osmode" "blipmode" "angbase" "angdir" "aunits" "clayer")
       SUS     (mapcar 'getvar SUS_LST)
       TERR *error*
      *error* ANSI37_ET)
 (ANSI37_MF)
 (princ))
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Main Function.
;
(defun ANSI37_MF ()
[color=red] (or H:WID (setq H:WID 12))                                                            ;Defualt Hatch Width     = 12[/color]
[color=red] (setq HPRP "ANSI37"                                                                   ;Default Hatch Pattern   = ANSI37[/color]
[color=red]       HSCL 32                                                                         ;Default Hatch Scale     = 32[/color]
[color=red]       HANG 180                                                                        ;Default Hatch Angle     = 0°[/color]
[color=red]       LNAM "DUCT-HA"                                                                  ;Default Layer Name      = DUCT-HA[/color]
[color=red]       LCLR 1                                                                          ;Default Layer Color     = 1 or RED[/color]
[color=red]       LTYP "Continuous")                                                              ;Default Layer Linetype  = Continuous[/color]
 (setq H:WID                                                                           ;Set the hatch width
   (cond                                                                               ;Condition
     ((getint (strcat "\nSpecify hatch width. <"(itoa H:WID)">: ")))(T H:WID)))        ;Get the hatch width
 (setq HWID H:WID)                                                                     ;Set the Hatch Width
 (setvar "osmode" (nth 2 SUS))                                                         ;Turn on Saved User Snaps
 (setq CL01 (getpoint "\nSpecify first point along duct: "))                           ;Get the first point
 (while                                                                                ;While loop
   (if (/= (setq CL02 (getpoint CL01 "\nSpecify next point along duct: ")) nil)        ;Get the next point, if the next point is nil, Go to the Loop Function
     (progn                                                                            ;Then do the following
       (ANSI37_CPS)                                                                    ;Go to Change Program Settings Function
       (setq RAD# (angle CL01 CL02)                                                    ;Get the angle in radians
             DEG# (ANSI37_RTD RAD#)                                                    ;Convert the radians to degrees
             DLEN (distance CL01 CL02)                                                 ;Get the distance from first point to the next point
             CL01 (trans CL01 1 0)                                                     ;Translate coordinate system
             CL02 (trans CL02 1 0)                                                     ;Translate coordinate system
             PT01 CL01                                                                 ;Calculate Point 01
             PT02 (polar PT01 (ANSI37_DTR (+ DEG#  0))  DLEN)                          ;Calculate Point 02
             PT03 (polar PT01 (ANSI37_DTR (+ DEG# 270)) HWID)                          ;Calculate Point 03
             PT04 (polar PT02 (ANSI37_DTR (+ DEG# 270)) HWID))                         ;Calculate Point 04
       (ANSI37_ML LNAM LCLR LTYP)                                                      ;Set layer name, color, linetype
       (setvar "clayer" LNAM)                                                          ;Set layer current
       (setvar "osmode" 0)                                                             ;Turn off snaps
       (command "._pline" PT01 PT02 PT04 PT03 "C")                                     ;Start Polyline command for hatch perimeter
       (setq E01 (entlast))                                                            ;Set polyline as last entity to E01
       (command "._-bhatch" "_a" "_a" "_y" "" "_p" HPRP HSCL HANG "_s" "_l" "" "")     ;Start Hatch command and fill the polyline
       (command "._erase" E01 "")                                                      ;Erase entity E01 or the polyline perimeter
       (setvar "osmode" (nth 2 SUS))                                                   ;Turn on Saved User Snaps
       (setq CL01 CL02))))                                                             ;Set the next point to the first point
 (ANSI37_LF)                                                                           ;Go to the Loop Function
 (princ))                                                                              ;Exit quietly
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Loop Function.
;
(defun ANSI37_LF ()
 (setq LOOP "Y")                                                                       ;Default Loop Y or Yes                                                
 (initget "Y N")                                                                       ;Set the keywords
 (setq LOOP                                                                            ;Set variable LOOP
   (cond                                                                               ;Condition
     ((getkword (strcat "\nContinue? [Y or N] <"LOOP">: ")))(T LOOP)))                 ;Do you wish to continue? Y or N
 (cond                                                                                 ;Condition
   ((= LOOP "N")(ANSI37_RUS))                                                            ;If N or No was selected go to ANSI37_RUS, Restore User Settings function
   ((= LOOP "Y")(ANSI37_MF)))                                                            ;If Y or Yes was selected go to HLIN_MF, Main Function
 (princ))                                                                              ;Exit quietly
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Degrees To Radians.
;
(defun ANSI37_DTR (DEG#)(* pi (/ DEG# 180.0)))                                            ;Convert degrees to radians
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Radians To Degrees.
;
(defun ANSI37_RTD (RAD#)(* 180.0 (/ RAD# pi)))                                            ;Convert radiand to degrees
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Make Layer.
;
(defun ANSI37_ML (L:NAM L:CLR L:TYP)
 (if (null (tblsearch "layer" L:NAM))
   (entmake
     (list
       (cons   0 "LAYER")
       (cons 100 "AcDbSymbolTableRecord")
       (cons 100 "AcDbLayerTableRecord")
       (cons   2  L:NAM)
       (cons  70  0)
       (cons  62  L:CLR)
       (cons   6  L:TYP)
       (cons 290  1))))
 (princ))
(princ)
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Change Program Settings.
;
(defun ANSI37_CPS ()
 (setq CPS (list 0 1 0 0 0 0))
 (mapcar (function setvar)(list "cmdecho" "orthomode" "blipmode" "angbase" "angdir" "aunits") CPS)
 (princ))
(princ)
;
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Restore User Settings.
;
(defun ANSI37_RUS ()
 (setq *error* TERR)
 (if SUS (mapcar 'setvar SUS_LST SUS))
 (princ "\nANSI37.lsp has completed successfully and will now restore your settings.")
 (princ))
(princ)
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Error Trap.
;
(defun ANSI37_ET (ERRORMSG)
 (command nil nil nil)
 (if (not (member ERRORMSG '("console break" "Function cancelled")))
   (princ (strcat "\nError:" ERRORMSG)))
 (if SUS (mapcar 'setvar SUS_LST SUS))
 (princ "\nANSI37.lsp has encountered a user error!")
 (princ "\nProgram will now restore your settings and exit.")
 (terpri)
 (setq *error* TERR)
 (princ))
(princ)
;
;/////////////////////////////////////////////////////////////////////////////////////////

(defun c:HH ( / *error* _StartUndo _EndUndo doc spc ent hobj hl )
 (vl-load-com)
 ;; © Lee Mac 2010
 (setq hl "Duct-HA") ;; Hatch Layer
 (defun *error* ( msg )
   (and doc (_EndUndo doc))
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ)
 )
 (defun _StartUndo ( doc ) (_EndUndo doc)
   (vla-StartUndoMark doc)
 )
 (defun _EndUndo ( doc )
   (if (= 8 (logand 8 (getvar 'UNDOCTL)))
     (vla-EndUndoMark doc)
   )
 )
 (LM:ActiveSpace 'doc 'spc)
 (or (tblsearch "LAYER" hl)
     (vla-add (vla-get-layers doc) hl)
 )
 (if (setq ent (LM:Selectif (lambda ( x ) (vlax-curve-isClosed x)) entsel "\nSelect Object to Hatch: "))
   (progn
     
     (_StartUndo doc)
     
     (if
       (not
         (vl-catch-all-error-p
           (setq hobj
             (vl-catch-all-apply 'vla-AddHatch
               (list spc acHatchPatternTypePredefined "ANSI37" :vlax-false 0)
             )
           )
         )
       )
       (progn
         (vlax-invoke hobj 'AppendOuterLoop (list (vlax-ename->vla-object ent)))
         (mapcar
           '(lambda ( p v ) (vlax-put-property hobj p v))
           '(Layer AssociativeHatch PatternAngle PatternScale) (list hl :vlax-false 0.0 32.0)
         )
         (vla-Evaluate hobj)
         (entdel ent)
       )
       (princ (strcat "\n** Error: " (vl-catch-all-error-message hobj) " **"))
     )
     (_EndUndo doc)
   )
 )
 (princ)
)
;;---------------------=={ Select if }==----------------------;;
;;                                                            ;;
;;  Continuous selection prompts until the predicate function ;;
;;  foo is validated                                          ;;
;;------------------------------------------------------------;;
;;  Author: Lee McDonnell, 2010                               ;;
;;                                                            ;;
;;  Copyright © 2010 by Lee McDonnell, All Rights Reserved.   ;;
;;  Contact: Lee Mac @ TheSwamp.org, CADTutor.net             ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  foo - optional predicate function taking ename argument   ;;
;;  fun - selection function to invoke                        ;;
;;  str - prompt string                                       ;;
;;------------------------------------------------------------;;
;;  Returns:  selected entity ename if successful, else nil   ;;
;;------------------------------------------------------------;;
(defun LM:Selectif ( foo fun str / e )
 ;; © Lee Mac 2010
 (while
   (progn (setq e (car (fun str)))      
     (cond
       ( (eq 'ENAME (type e))
         (if (and foo (not (foo e)))
           (princ "\n** Invalid Object Selected **")
         )
       )
     )
   )
 )
 e
)
;;--------------------=={ ActiveSpace }==---------------------;;
;;                                                            ;;
;;  Retrieves pointers to the Active Document and Space       ;;
;;------------------------------------------------------------;;
;;  Author: Lee McDonnell, 2010                               ;;
;;                                                            ;;
;;  Copyright © 2010 by Lee McDonnell, All Rights Reserved.   ;;
;;  Contact: Lee Mac @ TheSwamp.org, CADTutor.net             ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  *doc - quoted symbol other than *doc                      ;;
;;  *spc - quoted symbol other than *spc                      ;;
;;------------------------------------------------------------;;
(defun LM:ActiveSpace ( *doc *spc )
 ;; © Lee Mac 2010
 (set *spc
   (if
     (or
       (eq AcModelSpace
         (vla-get-ActiveSpace
           (set *doc
             (vla-get-ActiveDocument
               (vlax-get-acad-object)
             )
           )
         )
       )
       (eq :vlax-true (vla-get-MSpace (eval *doc)))
     )
     (vla-get-ModelSpace (eval *doc))
     (vla-get-PaperSpace (eval *doc))
   )
 )
)