[编程交流] 删除Dcl

 
;Tip1662c:   POFFSET.LSP    Piping Utilities    (c)2000, Mitch Thaxter
(defun C:POFFSET ()
 (setq OLD_BLIPMODE (getvar "blipmode"))
 (setvar "blipmode" 0)
 (setq FILE_FOUND_DCL (findfile "poffset.dcl"))
 (if (= FILE_FOUND_DCL NIL)
   (ANGLE_FILE_NOT_FOUND)
 ) ;_ end of if
 (setq DCL_ID (load_dialog FILE_FOUND_DCL))
 (if (not (new_dialog "poffset" DCL_ID))
   (exit)
 ) ;_ end of if
 (action_tile "cancel" "(exit)")
 (action_tile "pipe_size" "(setq pipe_size $value)")
 (if (= 1 (start_dialog))
   (start_dialog)
   (exit)
 ) ;_ end of if
;;;Nominal
 (if (= PIPE_SIZE "0")
   (setq PIPE_SIZE 0.405)
 ) ;_ end of if
;;;  1/8"
 (if (= PIPE_SIZE "1")
   (setq PIPE_SIZE 0.540)
 ) ;_ end of if
;;;  1/4"
 (if (= PIPE_SIZE "2")
   (setq PIPE_SIZE 0.675)
 ) ;_ end of if
;;;  3/8"
 (if (= PIPE_SIZE "3")
   (setq PIPE_SIZE 0.840)
 ) ;_ end of if
;;;  1/2"
 (if (= PIPE_SIZE "4")
   (setq PIPE_SIZE 1.050)
 ) ;_ end of if
;;;  3/4"
 (if (= PIPE_SIZE "5")
   (setq PIPE_SIZE 1.315)
 ) ;_ end of if
;;;   1"
 (if (= PIPE_SIZE "6")
   (setq PIPE_SIZE 1.660)
 ) ;_ end of if
;;; 1 1/4"
 (if (= PIPE_SIZE "7")
   (setq PIPE_SIZE 1.900)
 ) ;_ end of if
;;; 1 1/2"
 (if (= PIPE_SIZE "8")
   (setq PIPE_SIZE 2.375)
 ) ;_ end of if
;;;   2"
 (if (= PIPE_SIZE "9")
   (setq PIPE_SIZE 2.875)
 ) ;_ end of if
;;; 2 1/2"
 (if (= PIPE_SIZE "10")
   (setq PIPE_SIZE 3.500)
 ) ;_ end of if
;;;   3"
 (if (= PIPE_SIZE "11")
   (setq PIPE_SIZE 4.000)
 ) ;_ end of if
;;; 3 1/2"
 (if (= PIPE_SIZE "12")
   (setq PIPE_SIZE 4.500)
 ) ;_ end of if
;;;   4"
 (if (= PIPE_SIZE "13")
   (setq PIPE_SIZE 5.563)
 ) ;_ end of if
;;;   5"
 (if (= PIPE_SIZE "14")
   (setq PIPE_SIZE 6.625)
 ) ;_ end of if
;;;   6"
 (if (= PIPE_SIZE "15")
   (setq PIPE_SIZE 8.625)
 ) ;_ end of if
;;;   8"
 (if (= PIPE_SIZE "16")
   (setq PIPE_SIZE 10.75)
 ) ;_ end of if
;;;  10"
 (if (= PIPE_SIZE "17")
   (setq PIPE_SIZE 12.75)
 ) ;_ end of if
;;;  12"
 (setq DIST   (/ PIPE_SIZE 2)
       PICBOX ""
 ) ;_ end of setq
 (princ "\nCurrent offset < ")
 (princ DIST)
 (setq ENT (entsel "\nSelect line: "))
 (setq POINT (cadr ENT))
 (setq SIDE (getpoint "\nSelect side: "))
 (setq DIS1 (distance SIDE POINT))
 (setq ANG (angle SIDE POINT))
 (if (or (or (< ANG 0.78) (> ANG 5.5))
         (and (> ANG 2.35) (< ANG 3.92))
     ) ;_ end of or
   (setq ANG (- 0 ANG))
   (setq ANG (- pi ANG))
 ) ;end if
 (setq OTHER (polar POINT ANG DIST))
 (command "offset" DIST ENT SIDE ENT OTHER "")
 (prin1)
) ;_ end of defun

          ;Tip1662c:   POFFSET.LSP    Piping Utilities    (c)2000, Mitch Thaxter
; Modified 11/17/08
(defun C:POFFSET (/ ANG DAT DIS1 DIST ENT OTHER PIPE_SIZE POINT SIDE)
 (and
   (setq PIPE_SIZE (getint "\nEnter Pipe Size: "))
   (setq dat (assoc Pipe_size
                    '((0  0.405)
                      (1  0.540) ;  1/4"
                      (2  0.675) ;  3/8"
                      (3  0.840) ;  1/2"
                      (4  1.050) ;  3/4"
                      (5  1.315) ;   1"
                      (6  1.660) ; 1 1/4"
                      (7  1.900) ; 1 1/2"
                      (8  2.375) ;   2"
                      (9  2.875) ; 2 1/2"
                      (10 3.500) ;   3"
                      (11 4.000) ; 3 1/2"
                      (12 4.500) ;   4"
                      (13 5.563) ;   5"
                      (14 6.625) ;   6"
                      (15 8.625) ;   8"
                      (16 10.75) ;  10"
                      (17 12.75) ;  12"
                     )
             )
   )
   (setq DIST   (/ (cadr dat) 2.))
   (princ "\nCurrent offset < ")
   (princ DIST)
   (setq ENT (entsel "\nSelect line: "))
   (setq POINT (cadr ENT))
   (setq SIDE (getpoint "\nSelect side: "))
   (setq DIS1 (distance SIDE POINT))
   (setq ANG (angle SIDE POINT))
   (if (or (or (< ANG 0.78) (> ANG 5.5))
           (and (> ANG 2.35) (< ANG 3.92))
       ) ;_ end of or
     (setq ANG (- 0 ANG))
     (setq ANG (- pi ANG))
   )     ;end if
   (setq OTHER (polar POINT ANG DIST))
   (command "offset" DIST ENT "non" SIDE ENT "non" OTHER "")
 )
 (prin1)
) ;_ end of defun

 
;Tip1714:  ATTUPDATE.LSP    Attribute update      (c)2001, Brian Iwaskewycz
(defun C:ATTUPDATE  (/ NEXTENTTYPE ENTTYPE BLOCKNAME SSET ENTNAME
                    SELECTION FILENAME INDEX1 NEWBLOCKNAME MAINENTNAME
                    SUBENTNAME ATTLIST INSPOINT XSCALE YSCALE ZSCALE
                    ROTATION ENTDATA INDEX2 VALUE LOSSFLAG LAYERNAME)
 (while (or (/= "ATTRIB" NEXTENTTYPE) (/= "INSERT" ENTTYPE))
   (setq BLOCKNAME "")
   (setq BLOCKNAME
          (getstring
            "\nEnter name of block to update or <ENTER> to select: "))
   (if (/= "" BLOCKNAME)
     (progn
       (setq SSET
              (ssget "x"
                     (list (cons 0 "INSERT") (cons 2 BLOCKNAME))))
       (if SSET
         (progn
           (setq ENTNAME (ssname SSET 0))
           (setq ENTTYPE (cdr (assoc 0 (entget ENTNAME))))
           (if (entnext ENTNAME)
             (setq NEXTENTTYPE
                    (cdr
                      (assoc 0
                             (entget (entnext ENTNAME)))))
             (princ "\nThe selected block has no attributes.")
             )
           )
         (progn
           (princ (strcat "\nBlock name "
                          (strcase BLOCKNAME)
                          " not found."))
           (setq NEXTENTYPE NIL
                 ENTTYPE NIL)
           )
         )
       )
     (progn
       (setq SELECTION NIL)
       (while (not SELECTION)
         (setq SELECTION (entsel "\nSelect block to update:"))
         )
       (setq ENTNAME (car SELECTION))
       (setq ENTTYPE (cdr (assoc 0 (entget ENTNAME))))
       (if (entnext ENTNAME)
         (setq NEXTENTTYPE
                (cdr (assoc 0 (entget (entnext ENTNAME))))))
       (if (/= "INSERT" ENTTYPE)
         (princ "\nThe selected entity is not a block.")
         (if (/= "ATTRIB" NEXTENTTYPE)
           (princ "\nThe selected block has no attributes."))
         )
       )
     )
   )
 (if (= "" BLOCKNAME)
   (setq BLOCKNAME (cdr (assoc 2 (entget ENTNAME)))))
 (setq SSET (ssget "x" (list (cons 0 "INSERT") (cons 2 BLOCKNAME))))
 (princ (strcat "\n"
                (itoa (sslength SSET))
                " occurrence(s) of block "
                (strcase BLOCKNAME)
                " found.\n"))
 (setq FILENAME (getfiled "Select New Block Name" "" "dwg" 0))
 (setq INDEX1 (strlen FILENAME))
 (while (/= "\" (substr FILENAME INDEX1 1))
   (setq INDEX1 (1- INDEX1))
   )
 (setq BLOCKNAME (strcase BLOCKNAME))
 (setq NEWBLOCKNAME
        (strcase (substr FILENAME
                         (1+ INDEX1)
                         (- (- (strlen FILENAME) INDEX1) 4))))
 (setvar "attdia" 0)
 (setvar "attreq" 0)
 (setvar "cmdecho" 0)
 (if (and (tblsearch "block" NEWBLOCKNAME)
          (/= NEWBLOCKNAME BLOCKNAME))
   (progn
     (princ
       (strcat "A block named "
               NEWBLOCKNAME
               " already exists.  Using local copy instead."))
     (command "insert" NEWBLOCKNAME "0,0,0" "" "" "")
     )
   (progn
     (if (/= BLOCKNAME NEWBLOCKNAME)
       (command "rename" "b" BLOCKNAME NEWBLOCKNAME))
     (command "insert"
              (strcat NEWBLOCKNAME "=" FILENAME)
              "0,0,0"
              ""
              ""
              "")
     )
   )
 (setq MAINENTNAME (entlast))
 (setq SUBENTNAME (entnext MAINENTNAME))
 (while (= "ATTRIB" (cdr (assoc 0 (entget SUBENTNAME))))
   (setq
     ATTLIST (append ATTLIST
                     (list (cdr (assoc 2 (entget SUBENTNAME))))))
   (setq SUBENTNAME (entnext SUBENTNAME))
   )
 (entdel MAINENTNAME)
 (setvar "attreq" 1)
 (setq INDEX1 0)
 (command "ucs" "w")
 (princ "\n")
 (while (setq MAINENTNAME (ssname SSET INDEX1))
   (setq SUBENTNAME (entnext MAINENTNAME))
   (setq INSPOINT (cdr (assoc 10 (entget MAINENTNAME))))
   (setq XSCALE (cdr (assoc 41 (entget MAINENTNAME))))
   (setq YSCALE (cdr (assoc 42 (entget MAINENTNAME))))
   (setq ZSCALE (cdr (assoc 43 (entget MAINENTNAME))))
   (setq ROTATION
          (* (/ 180.0 pi) (cdr (assoc 50 (entget MAINENTNAME)))))
   (setq LAYERNAME (cdr (assoc 8 (entget MAINENTNAME))))
   (while (= "ATTRIB"
             (cdr (assoc 0 (setq ENTDATA (entget SUBENTNAME)))))
     (set (read (cdr (assoc 2 ENTDATA))) (cdr (assoc 1 ENTDATA)))
     (setq SUBENTNAME (entnext SUBENTNAME))
     )
   (setq INDEX2 0)
   (command "insert" NEWBLOCKNAME INSPOINT "xyz" XSCALE YSCALE ZSCALE
            ROTATION)
   (while (< INDEX2 (length ATTLIST))
     (setq VALUE (eval (read (nth INDEX2 ATTLIST))))
     (if VALUE
       (command VALUE)
       (progn
         (command "")
         (setq LOSSFLAG t)
         )
       )
     (set (read (nth INDEX2 ATTLIST)) NIL)
     (setq INDEX2 (1+ INDEX2))
     )
   (entmod (subst (cons 8 LAYERNAME)
                  (assoc 8 (entget (entlast)))
                  (entget (entlast))))
   (entdel MAINENTNAME)
   (setq INDEX1 (1+ INDEX1))
   (princ (strcat "\r"
                  (itoa INDEX1)
                  "/"
                  (itoa (sslength SSET))
                  " blocks updated."))
   )
 (command "ucs" "p")
 (setvar "cmdecho" 1)
 (setvar "attdia" 1)
 (if LOSSFLAG
   (princ
     "\nWARNING! Due to non-identical tag names, some data may have been lost."))
 (princ (strcat "\n"
                (itoa (sslength SSET))
                " occurrences of block "
                BLOCKNAME
                " updated successfully."))
 (if (/= BLOCKNAME NEWBLOCKNAME)
   (princ (strcat "\nBlock was renamed to " NEWBLOCKNAME ".")))
 (princ)
 )
(princ "ATTUPDATE ver 1.0 loaded.")
(princ)