[LISP程序]：折断线（物体断开线）程序

402326352 · 发表于 2005-9-21 18:50:19

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

在绘图的时候，总免不了要使某些物体进行断开处理，一般是用曲线或断开符号，但是要时时去画也很麻烦，并且未必合适，现在提供一款合适的给大家使用，他就像绘直线一样的使用。
加载后的命令为“zd”（折断的拼音前一个字母的组合）

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ZD（折段线）CCLISP程序 ;;
;;; By QQ：402326352 二００五年九月 ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
(defun c:zd ( / p1 p2 p3 x1 x2 ss lk flag sca size ds os)
(acet-error-init
(list
(list "HIGHLIGHT" 0
"CMDECHO" 0
"attreq" 0
"limcheck" 0
"osmode" (getvar "osmode")
"celtype" "continuous"
);list
T
);list
);acet-error-init
(sssetfirst nil nil)
(setq lk (acet-layer-unlock-all))
(bns_breakline_blk)
(setq size (bns_breakline_blksize))
(bns_breakline_blkexe)
(bns_breakline_print_settings)
(while (not flag)
(initget "Block Size Extension eXit" 128)
(setq p1 (getpoint "\n指定打断线的第一点或 [块(B)/大小(S)/扩展(E)]: "));setq
(cond
((equal p1 "Block")
(bns_breakline_getblkname nil)
);cond #1
((equal p1 "Size")
(bns_breakline_getblksize)
);cond #2
((equal p1 "Extension")
(bns_breakline_getblkexe)
);cond #3
((equal (type p1) 'LIST)
(setq flag T)
);cond #4
(T
(princ "\n无效。就为点或是块、大小或扩展。")
);cond #5
);cond close
);while
(if (equal (setq ds (getvar "dimscale")) 0.0)
(setq ds 1.0)
);if
(setq ss (bns_breakline_get_blk_info (bns_breakline_blk)) ;returns a list i.e. (ss x1 x2)
x1 (cadr ss)
x2 (caddr ss)
ss (car ss)
sca (/ (* ds size) (distance x1 x2))
);setq
(setq p2 p1)
(while (< (distance p1 p2)
(* (distance x1 x2) (abs sca))
)
(initget 1)
(setq p2 (getpoint p1 "\n指定打断线的第二点: "));setq
(if (<= (distance p1 p2)
(* (distance x1 x2) (abs sca))
)
(princ "\n*Invalid* 要插入打断的点太靠近。")
);if
);while
(if ss
(progn
(setq flag nil
os (getvar "osmode")
)
(if (not (equal 512 (logand 512 os)))
(setq os (+ os 512))
);if
(if (equal 16384 (logand 16384 os)) ;;;osnaps are off
(setq os (- os 16384))
);if
(if (/= os (getvar "osmode"))
(progn
(acet-sysvar-set (list "OSMODE" os))
(setq flag T)
);progn then
);if
(command "_.line" p1 p2 "")
(while (not p3)
(setq p3 (getpoint "\n指定打断的位置 <中点(M)>: "));setq
(if (not p3)
(setq p3 (acet-geom-midpoint p1 p2))
(progn
(setq p3 (bns_perp_inters p1 p2 p3 1))
(if (not p3)
(princ "\n*Invalid* 点不在由点一和点二构成的线段上。")
);if
);progn then
);if
);while
(if flag
(acet-sysvar-restore)
);if
(entdel (entlast))
(bns_breakline p1 p2 p3 ss x1 x2)
);progn then
);if
(if lk
(command "_.layer" "_lock" lk "")
);if
(acet-error-restore)
);defun c:breakline
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun bns_breakline ( p1 p2 p3 ss x1 x2 / d x3 size na na2 sca ds)
(setvar "osmode" 0)
(if (equal (setq ds (getvar "dimscale")) 0.0)
(setq ds 1.0)
);if
(setq size (bns_breakline_blksize))
(setq x3 (acet-geom-midpoint x1 x2));setq
(command "_.move" ss "" x3 p3)
(setq d (acet-geom-delta-vector x3 p3)
x3 (acet-geom-vector-add d x3)
x1 (acet-geom-vector-add d x1)
x2 (acet-geom-vector-add d x2)
);setq
(command "_.rotate" ss "" p3 "_r" x1 x2 p2);command
(setq d (- (angle p1 p2) (angle x1 x2))
x1 (acet-geom-point-rotate x1 x3 d)
x2 (acet-geom-point-rotate x2 x3 d)
sca (/ (* ds size) (distance x1 x2))
);setq
(command "_.scale" ss "" p3 sca);command
(setq x1 (polar x3
(angle x3 x1)
(* sca (distance x1 x3))
);polar
x2 (polar x3
(angle x3 x2)
(* sca (distance x2 x3))
);polar
p1 (polar p1 (angle p2 p1) (* ds #bns_breakline_blkexe))
p2 (polar p2 (angle p1 p2) (* ds #bns_breakline_blkexe))
);setq
(acet-ss-visible ss 0)
(command "_.pline" p1 x1 "")
(setq na (entlast))
(command "_.pline" x2 p2 "")
(setq na2 (entlast))
(command "_.pedit" na "_join" na na2 ss "" "_x")
(command "_.select" na na2 ss "")
(if (and (setq ss (ssget "_p"))
(> (sslength ss) 1)
);and
(acet-group-make-anon (list ss) "BREAKLINE")
);if
);defun bns_breakline
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;initialize the default block name to use.
;performs some checking to ensure the block is valid.
(defun bns_breakline_blk ( / bna dwgna flag ss)
(if (not #bns_breakline_blk)
(progn
(setq #bns_breakline_blk (acet-getvar (list "ACET.BREAKLINE-BLOCK")))
(setq flag T) ;set a flag to show this is the first time this is used this session
);progn
);if
(if (or (not #bns_breakline_blk) ;set the default is non exists.
(equal "" #bns_breakline_blk)
);or
(setq #bns_breakline_blk "BRKLINE.DWG");setq
);if
(acet-setvar (list "ACET.BREAKLINE-BLOCK" #bns_breakline_blk 2)) ;save in profile only
(setq dwgna (xstrcase #bns_breakline_blk)
dwgna (acet-str-space-trim dwgna) ;the dwgname, possibly w/path
dwgna (acet-filename-ext-remove dwgna)
);setq
(if (acet-str-m-find "=" dwgna)
(setq dwgna (acet-str-to-list "=" dwgna)
bna (car dwgna)
dwgna (cadr dwgna)
);setq then
(setq bna (acet-filename-path-remove (acet-filename-ext-remove dwgna)));setq else the base blockname
);if
(if (not (snvalid bna))
(progn
(princ "\n无效的块名。重新设置为默认。 ")
(setq #bns_breakline_blk "BRKLINE.DWG");setq
(bns_breakline_getblkname "BRKLINE.DWG")
);progn then
);if
(if (and (not (member bna (acet-table-name-list "block")))
(not (findfile (strcat dwgna ".DWG")))
(not (findfile (strcat dwgna ".DWT")))
);and
(progn
(princ (strcat "\n不能找到 ""
bna
"" or ""
dwgna ".DWG" "."
);strcat
)
(setq #bns_breakline_blk "BRKLINE.DWG");setq
(bns_breakline_getblkname "BRKLINE.DWG")
);progn then
);if
(acet-setvar (list "ACET.BREAKLINE-BLOCK" #bns_breakline_blk 2))
(if flag
(progn
(setq ss (bns_breakline_get_blk_info #bns_breakline_blk)
ss (car ss)
);setq
(if (and ss
(> (sslength ss) 0)
);and
(command "_.erase" ss "")
);if
);progn
);if
#bns_breakline_blk
);defun bns_breakline_blk
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;initialize the block size to use
(defun bns_breakline_blksize ()
(if (not #bns_breakline_blksize)
(setq #bns_breakline_blksize (acet-getvar (list "ACET.BREAKLINE-BLKSIZE")))
);if
(if (not #bns_breakline_blksize)
(setq #bns_breakline_blksize 0.5);setq
);if
(acet-setvar (list "ACET.BREAKLINE-BLKSIZE" #bns_breakline_blksize 2))
#bns_breakline_blksize
);defun bns_breakline_blksize
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;initialize the extension distance to use
(defun bns_breakline_blkexe ()
(if (not #bns_breakline_blkexe)
(setq #bns_breakline_blkexe (acet-getvar (list "ACET.BREAKLINE-BLKEXE")))
);if
(if (not #bns_breakline_blkexe)
(setq #bns_breakline_blkexe (getvar "dimexe"));setq
);if
(acet-setvar (list "ACET.BREAKLINE-BLKEXE" #bns_breakline_blkexe 2))
#bns_breakline_blkexe
);defun bns_breakline_blkexe
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun bns_breakline_print_settings ( / )
(princ (strcat "\n块= " #bns_breakline_blk
", 大小= " (rtos #bns_breakline_blksize)
", 扩展= " (rtos #bns_breakline_blkexe)
);strcat
);princ
);defun bns_breakline_print_settings
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Handles prompting for breakline block name.
;
(defun bns_breakline_getblkname ( def / lst lst2 a b flag na )
(if (not def)
(setq def (bns_breakline_blk))
);if
(setq lst (acet-table-name-list '("block" 4 16))
lst2 (acet-table-name-list "block")
);setq
(while (not flag)
(setq flag nil
a (strcat "\n输入打断线的块名 <"
def
">: "
);strcat
a (getstring T a)
a (xstrcase (acet-str-space-trim a))
);setq
(if (equal a "")
(setq a def);setq
);if
(cond
((and (acet-str-m-find "=" a) ;the "=" syntax for inserting long filenames
(setq b (acet-str-to-list "=" a))
(setq a (cadr b))
(setq b (car b))
(setq a (acet-str-space-trim a)
b (acet-str-space-trim b)
);setq
(if (equal a "")
(setq a b)
a
);if
(setq a (strcat (acet-filename-ext-remove a) ".DWG"))
(snvalid b)
(acet-file-find a)
);and
(setq flag (strcat b "=" a))
);cond #1 contains =
((and (equal a "~")
(setq a (getfiled "打断线的块:" def "DWG" 0))
(setq a (xstrcase a)
a (acet-filename-ext-remove a)
b (acet-filename-path-remove a)
a (strcat a ".DWG")
);setq
(snvalid b)
(acet-file-find a)
);and
(setq flag a)
);cond #2 enter a block name through filedia
((and a
(not (acet-str-m-find "=" a))
(not (equal a "~"))
(setq a (acet-filename-ext-remove a))
(setq b (acet-filename-path-remove a))
(setq a (strcat a ".DWG"))
(snvalid b)
(or (acet-file-find a)
(member b lst)
);or
);and
(setq flag a)
);cond #3
((and b
(not (snvalid b))
a
(acet-file-find a)
);and
(princ "\n无效的块名。")
(if (member b lst2)
(princ "\n不允许外部参照块。")
(princ (strcat "\n警告: 如果您正试图插入文件: "
a
"\n它必须用语法<块>=<文件名>才能插入。"
);strcat
);princ then
);if
);cond #4
((and a
(not (acet-file-find a))
);and
(princ (strcat "\n不能找到块 " a "。"))
);cond #5
);cond close
(if flag
(progn
(setq na (entlast))
(command "_.insert" flag)
(acet-cmd-exit)
;(while (wcmatch (getvar "cmdnames") "*INSERT*") (command nil))
(if (acet-str-m-find "=" flag)
(setq flag (car (acet-str-to-list "=" flag)))
);if
(entmake (list '(0 . "INSERT") (cons 2 (vl-filename-base flag))
'(60 . 1)
'(10 0.0 0.0 0.0) '(41 . 1.0) '(42 . 1.0) '(43 . 1.0) '(50 . 0.0)
)
);entmake
(if (equal na (entlast))
(setq flag nil)
(progn
(entdel (entlast))
(setq #bns_breakline_blk flag)
(acet-setvar (list "ACET.BREAKLINE-BLOCK" flag 3))
);progn then
);if
);progn then
);if
);while
flag
);defun bns_breakline_getblkname
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;handles prompting for block insert size
;and also places new default value in the registry.
;returns the entered value or the deafult if accepted
(defun bns_breakline_getblksize ( / def a size)
(setq size (bns_breakline_blksize)
def (rtos size)
);setq
(initget 6);non zero and no negative numbers
(setq a (getdist (strcat "\n打断线大小 <"
def
">: "
);strcat
);getdist
);setq
(if (not a)
(setq #bns_breakline_blksize size);setq
(setq #bns_breakline_blksize a);setq
);if
(acet-setvar (list "ACET.BREAKLINE-BLKSIZE" #bns_breakline_blksize 3))
#bns_breakline_blksize
);defun bns_breakline_getblksize
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;handles prompting for extension distance
;and also places new default value in the registry.
;returns the entered value or the deafult if accepted
(defun bns_breakline_getblkexe ( / def a exe)
(setq exe (bns_breakline_blkexe)
def (rtos exe)
);setq
(initget 4);no negative numbers
(setq a (getdist (strcat "\n打断线扩展距离 <"
def
">: "
);strcat
);getdist
);setq
(if (not a)
(setq #bns_breakline_blkexe exe);setq
(setq #bns_breakline_blkexe a);setq
);if
(acet-setvar (list "ACET.BREAKLINE-BLKEXE" #bns_breakline_blkexe 3))
#bns_breakline_blkexe
);defun bns_breakline_getblkexe
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;takes a block name and returns a list containing a selection set and a list of
;two points.
(defun bns_breakline_get_blk_info ( bna / na na2 ss ss2 ss3 p1 p2 lst)
(setq p1 (acet-geom-view-points)
p2 (cadr p1)
p1 (car p1)
p1 (polar p2 (angle p1 p2) (distance p1 p2))
na (entlast)
);setq
(command "_.insert" bna p1 1 1 0)
(if (not (equal na (entlast)))
(progn
(command "_.explode" (entlast))
(while (wcmatch (getvar "cmdnames") "*EXPLODE*")
(command "")
);while
(setq ss (acet-ss-new na) ;(ssget "_p")
p1 nil
p2 nil
);setq
;explode the selection set again in case there are spline/fit polylines inside.
;(they don't join very well.)
);progn
);if
(if ss
(progn
(setq ss3 (ssget "_p" '((0 . "*POLYLINE"))));setq
(setq na (entlast))
(command "_.explode" ss3)
(while (wcmatch (getvar "cmdnames") "*EXPLODE*")
(command "")
);while
(if (and (setq ss3 (acet-ss-new na))
(> (sslength ss3) 0)
);and
(progn
(command "_.select" ss ss3 "")
(setq ss (ssget "_p"));setq
);progn then
(command "_.select" ss "");explode may have cleared the selset so select it again
);if ;for (ssget "p"..) call below
);progn then
);if
(if ss
(progn
(acet-ss-visible ss 1)
(setq ss2 (ssget "_p" '((0 . "POINT") (8 . "DEFPOINTS"))));setq
);progn
);if
(if (and ss2
(= (sslength ss2) 2)
);and
(progn
(setq na (ssname ss2 0)
ss (ssdel na ss)
p1 (cdr (assoc 10 (entget na)))
p1 (trans p1 0 1)
);setq
(entdel na)
(setq na (ssname ss2 1)
ss (ssdel na ss)
p2 (cdr (assoc 10 (entget na)))
p2 (trans p2 0 1)
);setq
(entdel na)
);progn then
(setq ss2 nil)
);if
(cond
((not ss)
(princ "\n不能插入块。")
(exit)
)
((not ss2)
(alert "无效的块。 \n块在DEFPOINTS图层上必须包含两个点对象。")
(setq lst (bns_breakline_get_blk_info (bns_breakline_getblkname nil)))
);cond #1
((equal p1 p2)
(alert "无效的块。 \n块的点对象必须不一致。")
(bns_breakline_getblkname nil)
(setq lst (bns_breakline_get_blk_info (bns_breakline_getblkname nil)))
);cond #2
(T
(setq lst (list ss p1 p2));setq
);cond #3
);cond close
lst
);defun bns_breakline_get_blk_info
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Takes three points and a flag and returns the perpindicular intersection
;from point p3 to the segement p1-p2.
;The flag argument is an "onsegment" argument.
;flag=true means return the intersection only if it is on segment p1-p2
;flag=nil means return the intersection as if segment p1-p2 was infinite in length.
;
(defun bns_perp_inters ( p1 p2 p3 flag / p4 a d)
(setq a (angle p1 p2)
d (* 2.0 (distance (getvar "extmax") (getvar "extmin")))
p4 (polar p3
(+ a (/ pi 2.0))
d
)
p3 (polar p3
(- a (/ pi 2.0))
d
);polar
a (inters p1 p2 p3 p4 flag)
);setq
a
);defun bns_perp_inters
(princ)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
;;;                ZD（折段线）CCLISP程序                             ;; 
;;;                By QQ：402326352   二００五年九月                  ;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
 
 
; 
(defun c:zd ( / p1 p2 p3 x1 x2 ss lk flag sca size ds os) 
 
(acet-error-init 
 (list 
  (list "HIGHLIGHT" 0 
          "CMDECHO" 0 
           "attreq" 0 
         "limcheck" 0 
           "osmode" (getvar "osmode") 
          "celtype" "continuous" 
  );list 
  T 
 );list 
);acet-error-init 
 
(sssetfirst nil nil) 
 
(setq lk (acet-layer-unlock-all)) 
 
(bns_breakline_blk) 
(setq size (bns_breakline_blksize)) 
(bns_breakline_blkexe) 
(bns_breakline_print_settings) 
 
 
(while (not flag) 
 (initget "Block Size Extension eXit" 128) 
 (setq p1 (getpoint "\n指定打断线的第一点或 [块(B)/大小(S)/扩展(E)]: "));setq 
 (cond 
  ((equal p1 "Block") 
   (bns_breakline_getblkname nil) 
  );cond #1 
  ((equal p1 "Size") 
   (bns_breakline_getblksize) 
  );cond #2 
  ((equal p1 "Extension") 
   (bns_breakline_getblkexe) 
  );cond #3 
  ((equal (type p1) 'LIST) 
   (setq flag T) 
  );cond #4 
  (T 
   (princ "\n无效。 就为点或是块、大小或扩展。") 
  );cond #5 
 );cond close 
);while 
 
(if (equal (setq ds (getvar "dimscale")) 0.0) 
    (setq ds 1.0) 
);if 
(setq  ss (bns_breakline_get_blk_info (bns_breakline_blk)) ;returns a list i.e.  (ss x1 x2) 
       x1 (cadr ss) 
       x2 (caddr ss) 
       ss (car ss) 
      sca (/ (* ds size) (distance x1 x2)) 
);setq 
 
 
(setq p2 p1) 
(while (< (distance p1 p2) 
           (* (distance x1 x2) (abs sca)) 
       ) 
 (initget 1) 
 (setq p2 (getpoint p1 "\n指定打断线的第二点: "));setq 
 (if (<= (distance p1 p2) 
         (* (distance x1 x2) (abs sca)) 
     ) 
     (princ "\n*Invalid* 要插入打断的点太靠近。") 
 );if 
);while 
 
(if ss 
    (progn 
     (setq flag nil 
             os (getvar "osmode") 
     ) 
     (if (not (equal 512 (logand 512 os))) 
         (setq os (+ os 512)) 
     );if 
     (if (equal 16384 (logand 16384 os)) ;;;osnaps are off 
         (setq os (- os 16384)) 
     );if 
     (if (/= os (getvar "osmode")) 
         (progn 
          (acet-sysvar-set (list "OSMODE" os)) 
          (setq flag T) 
         );progn then 
     );if 
     (command "_.line" p1 p2 "") 
 
     (while (not p3) 
      (setq p3 (getpoint "\n指定打断的位置 <中点(M)>: "));setq 
      (if (not p3) 
          (setq p3 (acet-geom-midpoint p1 p2)) 
          (progn 
           (setq p3 (bns_perp_inters p1 p2 p3 1)) 
           (if (not p3) 
               (princ "\n*Invalid* 点不在由点一和点二构成的线段上。") 
           );if 
          );progn then 
      );if 
     );while 
     (if flag 
         (acet-sysvar-restore) 
     );if 
     (entdel (entlast)) 
     (bns_breakline p1 p2 p3 ss x1 x2) 
 
    );progn then 
);if 
 
(if lk 
    (command "_.layer" "_lock" lk "") 
);if 
 
(acet-error-restore) 
);defun c:breakline 
 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
(defun bns_breakline ( p1 p2 p3 ss x1 x2 / d x3 size na na2 sca ds) 
 
(setvar "osmode" 0) 
(if (equal (setq ds (getvar "dimscale")) 0.0) 
    (setq ds 1.0) 
);if 
 
(setq size (bns_breakline_blksize)) 
(setq x3 (acet-geom-midpoint x1 x2));setq 
(command "_.move" ss "" x3 p3) 
(setq  d (acet-geom-delta-vector x3 p3) 
      x3 (acet-geom-vector-add d x3) 
      x1 (acet-geom-vector-add d x1) 
      x2 (acet-geom-vector-add d x2) 
);setq 
(command "_.rotate" ss "" p3 "_r" x1 x2 p2);command 
(setq   d (- (angle p1 p2) (angle x1 x2)) 
       x1 (acet-geom-point-rotate x1 x3 d) 
       x2 (acet-geom-point-rotate x2 x3 d) 
      sca (/ (* ds size) (distance x1 x2)) 
);setq 
(command "_.scale" ss "" p3 sca);command 
(setq x1 (polar x3 
                (angle x3 x1) 
                (* sca (distance x1 x3)) 
         );polar 
      x2 (polar x3 
                (angle x3 x2) 
                (* sca (distance x2 x3)) 
         );polar 
      p1 (polar p1 (angle p2 p1) (* ds #bns_breakline_blkexe)) 
      p2 (polar p2 (angle p1 p2) (* ds #bns_breakline_blkexe)) 
);setq 
(acet-ss-visible ss 0) 
 
(command "_.pline" p1 x1 "") 
(setq na (entlast)) 
(command "_.pline" x2 p2 "") 
(setq na2 (entlast)) 
(command "_.pedit" na "_join" na na2 ss "" "_x") 
(command "_.select" na na2 ss "") 
 
(if (and (setq ss (ssget "_p")) 
         (> (sslength ss) 1) 
    );and 
    (acet-group-make-anon (list ss) "BREAKLINE") 
);if 
);defun bns_breakline 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
;initialize the default block name to use. 
;performs some checking to ensure the block is valid. 
(defun bns_breakline_blk ( / bna dwgna flag ss) 
 
 (if (not #bns_breakline_blk) 
     (progn 
      (setq #bns_breakline_blk (acet-getvar (list "ACET.BREAKLINE-BLOCK"))) 
      (setq flag T) ;set a flag to show this is the first time this is used this session 
     );progn 
 );if 
 (if (or (not #bns_breakline_blk)      ;set the default is non exists. 
         (equal "" #bns_breakline_blk) 
     );or 
     (setq #bns_breakline_blk "BRKLINE.DWG");setq 
 );if 
 (acet-setvar (list "ACET.BREAKLINE-BLOCK" #bns_breakline_blk 2)) ;save in profile only 
 
 (setq dwgna (xstrcase #bns_breakline_blk) 
       dwgna (acet-str-space-trim dwgna)              ;the dwgname, possibly w/path 
       dwgna (acet-filename-ext-remove dwgna) 
 );setq 
 (if (acet-str-m-find "=" dwgna) 
     (setq dwgna (acet-str-to-list "=" dwgna) 
             bna (car dwgna) 
           dwgna (cadr dwgna) 
     );setq then 
     (setq bna (acet-filename-path-remove (acet-filename-ext-remove dwgna)));setq else the base blockname 
 );if 
 (if (not (snvalid bna)) 
     (progn 
      (princ "\n无效的块名。重新设置为默认。 ") 
      (setq #bns_breakline_blk "BRKLINE.DWG");setq 
 
      (bns_breakline_getblkname "BRKLINE.DWG") 
 
     );progn then 
 );if 
 (if (and (not (member bna (acet-table-name-list "block"))) 
          (not (findfile (strcat dwgna ".DWG"))) 
          (not (findfile (strcat dwgna ".DWT"))) 
     );and 
     (progn 
      (princ (strcat "\n不能找到 "" 
                     bna 
                     "" or "" 
                     dwgna ".DWG" "." 
             );strcat 
      ) 
      (setq #bns_breakline_blk "BRKLINE.DWG");setq 
 
      (bns_breakline_getblkname "BRKLINE.DWG") 
     );progn then 
 );if 
 
 (acet-setvar (list "ACET.BREAKLINE-BLOCK" #bns_breakline_blk 2)) 
 
 (if flag 
     (progn 
 
      (setq ss (bns_breakline_get_blk_info #bns_breakline_blk) 
            ss (car ss) 
      );setq 
      (if (and ss 
               (> (sslength ss) 0) 
          );and 
          (command "_.erase" ss "") 
      );if 
     );progn 
 );if 
 
 #bns_breakline_blk 
);defun bns_breakline_blk 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
;initialize the block size to use 
(defun bns_breakline_blksize () 
 (if (not #bns_breakline_blksize) 
     (setq #bns_breakline_blksize (acet-getvar (list "ACET.BREAKLINE-BLKSIZE"))) 
 );if 
 (if (not #bns_breakline_blksize) 
     (setq #bns_breakline_blksize 0.5);setq 
 );if 
 (acet-setvar (list "ACET.BREAKLINE-BLKSIZE" #bns_breakline_blksize 2)) 
 #bns_breakline_blksize 
);defun bns_breakline_blksize 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
;initialize the extension distance to use 
(defun bns_breakline_blkexe () 
 (if (not #bns_breakline_blkexe) 
     (setq #bns_breakline_blkexe (acet-getvar (list "ACET.BREAKLINE-BLKEXE"))) 
 );if 
 (if (not #bns_breakline_blkexe) 
     (setq #bns_breakline_blkexe (getvar "dimexe"));setq 
 );if 
 (acet-setvar (list "ACET.BREAKLINE-BLKEXE" #bns_breakline_blkexe 2)) 
 #bns_breakline_blkexe 
);defun bns_breakline_blkexe 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
(defun bns_breakline_print_settings ( / ) 
 
(princ (strcat "\n块= " #bns_breakline_blk 
               ", 大小= " (rtos #bns_breakline_blksize) 
               ", 扩展= " (rtos #bns_breakline_blkexe) 
       );strcat 
);princ 
 
);defun bns_breakline_print_settings 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
;Handles prompting for breakline block name. 
; 
(defun bns_breakline_getblkname ( def / lst lst2 a b flag na ) 
 
(if (not def) 
    (setq def (bns_breakline_blk)) 
);if 
 
(setq  lst (acet-table-name-list '("block" 4 16)) 
      lst2 (acet-table-name-list "block") 
);setq 
 
(while (not flag) 
 
(setq flag nil 
         a (strcat "\n输入打断线的块名 <" 
                    def 
                    ">: " 
           );strcat 
         a (getstring T a) 
         a (xstrcase (acet-str-space-trim a)) 
);setq 
(if (equal a "") 
    (setq a def);setq 
);if 
(cond 
 ((and (acet-str-m-find "=" a)             ;the "=" syntax for inserting long filenames 
       (setq b (acet-str-to-list "=" a)) 
       (setq a (cadr b)) 
       (setq b (car b)) 
       (setq a (acet-str-space-trim a) 
             b (acet-str-space-trim b) 
       );setq 
       (if (equal a "") 
           (setq a b) 
           a 
       );if 
       (setq a (strcat (acet-filename-ext-remove a) ".DWG")) 
       (snvalid b) 
       (acet-file-find a) 
  );and 
   (setq flag (strcat b "=" a)) 
 );cond #1 contains = 
 ((and (equal a "~") 
       (setq a (getfiled "打断线的块:" def "DWG" 0)) 
       (setq a (xstrcase a) 
             a (acet-filename-ext-remove a) 
             b (acet-filename-path-remove a) 
             a (strcat a ".DWG") 
       );setq 
       (snvalid b) 
       (acet-file-find a) 
  );and 
   (setq flag a) 
 );cond #2 enter a block name through filedia 
 ((and a 
       (not (acet-str-m-find "=" a)) 
       (not (equal a "~")) 
       (setq a (acet-filename-ext-remove a)) 
       (setq b (acet-filename-path-remove a)) 
       (setq a (strcat a ".DWG")) 
       (snvalid b) 
       (or (acet-file-find a) 
           (member b lst) 
       );or 
  );and 
   (setq flag a) 
 );cond #3 
 ((and b 
       (not (snvalid b)) 
       a 
       (acet-file-find a) 
  );and 
  (princ "\n无效的块名。") 
  (if (member b lst2) 
      (princ "\n不允许外部参照块。") 
      (princ (strcat "\n警告: 如果您正试图插入文件: " 
                     a 
                     "\n它必须用语法<块>=<文件名>才能插入。" 
             );strcat 
      );princ then 
  );if 
 );cond #4 
 ((and a 
       (not (acet-file-find a)) 
  );and 
  (princ (strcat "\n不能找到块 " a "。")) 
 );cond #5 
);cond close 
 
(if flag 
    (progn 
     (setq na (entlast)) 
     (command "_.insert" flag) 
     (acet-cmd-exit) 
     ;(while (wcmatch (getvar "cmdnames") "*INSERT*") (command nil)) 
     (if (acet-str-m-find "=" flag) 
         (setq flag (car (acet-str-to-list "=" flag))) 
     );if 
     (entmake (list '(0 . "INSERT") (cons 2 (vl-filename-base flag)) 
                    '(60 . 1) 
                    '(10 0.0 0.0 0.0) '(41 . 1.0) '(42 . 1.0) '(43 . 1.0) '(50 . 0.0) 
              ) 
     );entmake 
     (if (equal na (entlast)) 
         (setq flag nil) 
         (progn 
          (entdel (entlast)) 
          (setq #bns_breakline_blk flag) 
          (acet-setvar (list "ACET.BREAKLINE-BLOCK" flag 3)) 
         );progn then 
     );if 
    );progn then 
);if 
 
);while 
 
 
flag 
);defun bns_breakline_getblkname 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
;handles prompting for block insert size 
;and also places new default value in the registry. 
;returns the entered value or the deafult if accepted 
(defun bns_breakline_getblksize ( / def a size) 
 
(setq size (bns_breakline_blksize) 
       def (rtos size) 
);setq 
(initget 6);non zero and no negative numbers 
(setq a (getdist (strcat "\n打断线大小 <" 
                         def 
                         ">: " 
                 );strcat 
        );getdist 
);setq 
(if (not a) 
    (setq #bns_breakline_blksize size);setq 
    (setq #bns_breakline_blksize a);setq 
);if 
(acet-setvar (list "ACET.BREAKLINE-BLKSIZE" #bns_breakline_blksize 3)) 
#bns_breakline_blksize 
);defun bns_breakline_getblksize 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
;handles prompting for extension distance 
;and also places new default value in the registry. 
;returns the entered value or the deafult if accepted 
(defun bns_breakline_getblkexe ( / def a exe) 
 
(setq exe (bns_breakline_blkexe) 
      def (rtos exe) 
);setq 
(initget 4);no negative numbers 
(setq a (getdist (strcat "\n打断线扩展距离 <" 
                         def 
                         ">: " 
                 );strcat 
        );getdist 
);setq 
(if (not a) 
    (setq #bns_breakline_blkexe exe);setq 
    (setq #bns_breakline_blkexe a);setq 
);if 
(acet-setvar (list "ACET.BREAKLINE-BLKEXE" #bns_breakline_blkexe 3)) 
#bns_breakline_blkexe 
);defun bns_breakline_getblkexe 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
;takes a block name and returns a list containing a selection set and a list of 
;two points. 
(defun bns_breakline_get_blk_info ( bna / na na2 ss ss2 ss3 p1 p2 lst) 
 
(setq p1 (acet-geom-view-points) 
      p2 (cadr p1) 
      p1 (car p1) 
      p1 (polar p2 (angle p1 p2) (distance p1 p2)) 
      na (entlast) 
);setq 
(command "_.insert" bna p1 1 1 0) 
(if (not (equal na (entlast))) 
    (progn 
     (command "_.explode" (entlast)) 
     (while (wcmatch (getvar "cmdnames") "*EXPLODE*") 
      (command "") 
     );while 
     (setq ss (acet-ss-new na) ;(ssget "_p") 
           p1 nil 
           p2 nil 
     );setq 
     ;explode the selection set again in case there are spline/fit polylines inside. 
     ;(they don't join very well.) 
    );progn 
);if 
(if ss 
    (progn 
     (setq ss3 (ssget "_p" '((0 . "*POLYLINE"))));setq 
     (setq na (entlast)) 
     (command "_.explode" ss3) 
     (while (wcmatch (getvar "cmdnames") "*EXPLODE*") 
      (command "") 
     );while 
     (if (and (setq ss3 (acet-ss-new na)) 
              (> (sslength ss3) 0) 
         );and 
         (progn 
          (command "_.select" ss ss3 "") 
          (setq ss (ssget "_p"));setq 
         );progn then 
         (command "_.select" ss "");explode may have cleared the selset so select it again 
     );if                          ;for (ssget "p"..) call below 
    );progn then 
);if 
(if ss 
    (progn 
     (acet-ss-visible ss 1) 
     (setq ss2 (ssget "_p" '((0 . "POINT") (8 . "DEFPOINTS"))));setq 
    );progn 
);if 
(if (and ss2 
         (= (sslength ss2) 2) 
    );and 
    (progn 
     (setq  na (ssname ss2 0) 
            ss (ssdel na ss) 
            p1 (cdr (assoc 10 (entget na))) 
            p1 (trans p1 0 1) 
     );setq 
     (entdel na) 
     (setq  na (ssname ss2 1) 
            ss (ssdel na ss) 
            p2 (cdr (assoc 10 (entget na))) 
            p2 (trans p2 0 1) 
     );setq 
     (entdel na) 
    );progn then 
    (setq ss2 nil) 
);if 
(cond 
 ((not ss) 
  (princ "\n不能插入块。") 
  (exit) 
 ) 
 ((not ss2) 
  (alert "无效的块。 \n块在DEFPOINTS图层上必须包含两个点对象。") 
  (setq lst (bns_breakline_get_blk_info (bns_breakline_getblkname nil))) 
 );cond #1 
 ((equal p1 p2) 
  (alert "无效的块。 \n块的点对象必须不一致。") 
  (bns_breakline_getblkname nil) 
  (setq lst (bns_breakline_get_blk_info (bns_breakline_getblkname nil))) 
 );cond #2 
 (T 
  (setq lst (list ss p1 p2));setq 
 );cond #3 
);cond close 
 
lst 
);defun bns_breakline_get_blk_info 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
;Takes three points and a flag and returns the perpindicular intersection 
;from point p3 to the segement p1-p2. 
;The flag argument is an "onsegment" argument. 
;flag=true means return the intersection only if it is on segment p1-p2 
;flag=nil means return the intersection as if segment p1-p2 was infinite in length. 
; 
(defun bns_perp_inters ( p1 p2 p3 flag / p4 a d) 
 
(setq  a (angle p1 p2) 
       d (* 2.0 (distance (getvar "extmax") (getvar "extmin"))) 
      p4 (polar p3 
                (+ a (/ pi 2.0)) 
                d 
         ) 
      p3 (polar p3 
                (- a (/ pi 2.0)) 
                d 
         );polar 
       a (inters p1 p2 p3 p4 flag) 
);setq 
 
a 
);defun bns_perp_inters 
 
 
(princ)

liuyj · 发表于 2005-9-22 09:07:27

唉，这不就是Express里的东西嘛，把命令名一改就拿来了。

lyl6414300 · 发表于 2005-11-11 08:23:24

楼主我加载了是这样的。

shq197528 · 发表于 2006-4-13 07:01:51

是呀!不过好的就是方便有些人不知道在什么地方!

zh_6531394 · 发表于 2006-4-13 10:04:35

"no function definition: ACET-ERROR-INIT"
不能用

cracher · 发表于 2006-4-14 16:40:22

"no function definition: ACET-ERROR-INIT"

shaojingjing · 发表于 2010-1-13 22:25:36

不能用啊 .为什么?

JackTool · 发表于 2013-5-1 14:11:59

终于子这里找到了,谢谢LZ

wangdaobin · 发表于 2013-12-24 06:48:34

"no function definition: ACET-ERROR-INIT"

totorojdm · 发表于 2014-5-7 23:31:56

试了一下真的是Express的东西~

账号		自动登录	找回密码
密码			立即注册

[LISP程序]：折断线（物体断开线）程序

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子