Jump to content

Remove Dcl

JONTHEPOPE

By JONTHEPOPE
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

JONTHEPOPE Community Regular

JONTHEPOPE

Posted
Posted 

 
;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

CAN SOME ONE SHOW ME HOW TO REMOVE CALL FOR DCL :P

Link to comment
Share on other sites
CAB Proficient

CAB

Posted
Posted

Just what is this crude routine supposed to be doing?

 

          ;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

Link to comment
Share on other sites
JONTHEPOPE Community Regular

JONTHEPOPE

Posted
  • Author
Posted

THANKS FOR THE REPLY I SEEM TO HAVE STUMBLED ON QUITE A FEW CLOUDY ROUTINES IVE USED THIS PROGRAM POFFSET AND THE SIZES WERENT AS SPEICIFIED I GUESS IM JUST SPOILED BY AWSOME PROGRAMMERS HERE AND ALL THEIR HELP. 

 
;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)

 

THIS CODE IS FOR AREA AND WANTED TO KNOW IF IT TO IS OUT OF DATE? COULD YOU ALSO HELP WITH THIS ONE?

Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 Share
Go to topic listing
×
×
  • Create New...