[原创]：Eachy 工具集 Lisp源码详解

jx2008 · 发表于 2009-1-8 22:15:30

支持了，继续贴上来哦！

eachy · 发表于 2009-1-14 16:12:36

继续贴几个 Dim 处理程序，文件名 Obj_dim.lsp

(defun c:ea:DimMerge (/ uo ux uy dme1 dmel1 dme2 dmel2 keyr ucsza dm1p13
dm1p14 dm1p10 dm2p13 np13x np14x e1 e2
)
(command ".undo" "g")
(setq uo (getvar "ucsorg")
ux (getvar "ucsxdir")
uy (getvar "ucsydir")
)
(command "cmdecho" "0" "osnap" "nea" "ucs" "")
(defun *error* (msg)
(print "\n取消!")
(command ".ucs" "3" uo ux uy)
(command ".undo" "end")
(setq *error* nil)
)
(if (and (setq e1 (car (entsel "\n点选要合并的第一个尺寸标注<退出>:")))
(= (cdr (assoc 0 (setq dmel1 (entget e1)))) "DIMENSION")
)
(while (and
(setq e2 (car (entsel "\n点选要合并的第二个尺寸标注<退出>:")))
(= (cdr (assoc 0 (setq dmel2 (entget e2)))) "DIMENSION")
)
(if (member '(100 . "AcDbRotatedDimension") dmel1)
(setq keyr "T")
(setq keyr nil)
)
(if keyr
(setq ucsza (angtos (cdr (assoc 50 dmel1)) 0 3))
(setq ucsza (angtos (angle (cdr (assoc 14 dmel1)) (cdr
(assoc 13
dmel1
)
)
) 0 3
)
)
)
(command "ucs" "z" ucsza)
(setq dm1p13 (trans (cdr (assoc 13 dmel1)) 0 1)
dm1p14 (trans (cdr (assoc 14 dmel1)) 0 1)
dm1p10 (trans (cdr (assoc 10 dmel1)) 0 1)
dm2p13 (trans (cdr (assoc 13 dmel2)) 0 1)
dm2p14 (trans (cdr (assoc 14 dmel2)) 0 1)
np13x (min
(car dm1p13)
(car dm1p14)
(car dm2p13)
(car dm2p14)
)
np14x (max
(car dm1p13)
(car dm1p14)
(car dm2p13)
(car dm2p14)
)
)
(setq dmel1 (subst
(cons 13 (trans (cons np13x (cdr dm1p13)) 1 0))
(assoc 13 dmel1)
dmel1
)
dmel1 (subst
(cons 14 (trans (cons np14x (cdr dm1p14)) 1 0))
(assoc 14 dmel1)
dmel1
)
dmel1 (subst
(cons 10 (trans (cons np14x (cdr dm1p10)) 1 0))
(assoc 10 dmel1)
dmel1
)
)
(entdel e2)
(entmod dmel1)
(command "ucs" "")
)
) ; end while
(command ".ucs" "3" uo ux uy)
(setq *error* nil)
(command ".undo" "end")
(princ)
)
;|
标注分割, 断开工具适用线形标注、对齐标注、水平标注、垂直标注
|;
(defun c:ea:DimBrk (/ tf e p1 p2 pt pt1 pt0 pn ang oldlist newlist1
newlist2 key str nstr k
)
(command ".undo" "g")
(setq tf T)
(while tf
(if (and (setq e (car (entsel "\n请选取要断开的尺寸标注<退出>:")))
(= (cdr (assoc 0 (setq oldlist (entget e)))) "DIMENSION")
)
(progn
(setvar "osmode" 3063)
(setq oldlist (cdr (entget e)))
(setq p1 (cdr (assoc 13 oldlist))
p2 (cdr (assoc 14 oldlist))
ang (if (= (cdr (assoc 70 oldlist)) 33)
(angle p1 p2)
(cdr (assoc 50 oldlist))
)
str (cdr (assoc 1 oldlist))
)
(initget 128 "1 2 3 4 5 6 7")
(if (not (setq pt (getpoint "\n断开点/均分份数[1/2/3/4/5/6/7]<2>: ")))
(setq pt "2")
)
(cond
((= (type pt) 'LIST)
(progn
(setq pt1 (polar pt (- ang (/ pi 2)) 1))
(setq pt0 (inters
p1
p2
pt
pt1
nil
)
)
(if (not (equal (angle pt0 p1) (angle pt0 p2) 0.000001))
(progn
(setq newlist1 (subst
(cons 14 pt0)
(assoc 14 oldlist)
oldlist
)
newlist2 (subst
(cons 13 pt0)
(assoc 13 oldlist)
oldlist
)
)
(if (/= str "")
(progn
(setq nstr (atof str)
k (/ (distance pt0 p1) (distance p1 p2))
)
(setq newlist1 (subst (cons 1
(rtos (* k nstr)
(getvar "DIMLUNIT")
(getvar "dimdec")
)
)
(assoc 1 newlist1)
newlist1
)
newlist2 (subst
(cons 1
(rtos (* (- 1. k) nstr)
(getvar "DIMLUNIT")
(getvar "dimdec")
)
)
(assoc 1 newlist2)
newlist2
)
)
)
)
(entdel e)
(entmake newlist1)
(entmake newlist2)
)
(PROGN
(initget "Extend Add")
(if (not (setq key (getkword "\n[E -延伸/ A -加入]<A>: ")))
(setq key "Add")
)
(if (> (distance pt0 p1) ; 13
(distance pt0 p2) ; 14
)
(setq newlist1 (subst
(cons (if (= key "Add")
13
14
) pt0
)
(assoc (if (= key "Add")
13
14
) oldlist
)
oldlist
)
)
(setq newlist1 (subst
(cons (if (= key "Add")
14
13
) pt0
)
(assoc (if (= key "Add")
14
13
) oldlist
)
oldlist
)
)
)
(if (= key "Extend")
(entdel e)
)
(entmake newlist1)
)
)
)
)
((= (type pt) 'STR)
(setq d (/ (distance p1 p2) (atof pt)))
(if (/= str "")
(progn
(setq nstr (atof str)
k (/ 1. (atof pt))
)
(setq nstr
(rtos (* k nstr)
(getvar "DIMLUNIT")
(getvar "dimdec")
)
)
)
)
(entdel e)
(repeat (read pt)
(setq pn (polar p1 ang d)
newlist1 (subst
(cons 14 pn)
(assoc 14 oldlist)
oldlist
)
oldlist (subst
(cons 13 pn)
(assoc 13 newlist1)
newlist1
)
)
(if nstr
(setq newlist1 (subst (cons 1 nstr)
(assoc 1 newlist1)
newlist1
)
)
)
(entmake newlist1)
(setq p1 pn)
)
)
(T
)
)
) ; progn
(setq tf nil)
) ; if
) ; while
(command ".undo" "end")
(princ)
)
;|
将选择的标注，恢复标注值到原始状态下。
|;
(defun c:ea:DimResVal (/ ss e ssl lst)
(command ".undo" "g")
(while (progn
(prompt "\n请选取要恢复原值的尺寸标注<退出>:")
(setq ss (ssget '((0 . "dimension"))))
)
(setq ssl (sslength ss))
(while (> ssl 0)
(setq e (ssname ss (setq ssl (1- ssl)))
lst (entget e)
)
(entmod (subst '(1 . "")
(assoc 1 lst)
lst
)
)
(entupd e)
)
)
(command ".undo" "end")
(princ)
)
;|
功能：增减边线
|;
(defun c:ea:DimASBX (/ e p p1 p2 ent)
(ea:Clearcset)
(prompt "\n请选取要增减边线的尺寸实体<退出>:")
(if (ssget '((0 . "dimension")))
(progn
(while (and
(listp p)
(progn
(initget "A D R")
(setq p
(getpoint
"\r点取要增减边线的位置[A -全增加 /D -全去掉/R -恢复默认]<退出>: "
)
)
)
)
(vlax-map-collection
(vlax-get-property
(vlax-get-property
(vlax-get-acad-object)
'activedocument
)
'activeselectionset
)
'(lambda (e)
(if (member (vla-get-objectname e)
'("AcDbAlignedDimension"
"AcDbRotatedDimension"
"AcDb3PointAngularDimension"
)
)
(cond
((= p "A")
(vla-put-ExtLine1Suppress e :vlax-false)
(vla-put-extline2suppress e :vlax-false)
)
((= p "D")
(vla-put-ExtLine1Suppress e :vlax-true)
(vla-put-extline2suppress e :vlax-true)
)
((= p "R")
(setq
lst (entget (setq ent (vlax-vla-object->ename e)))
)
(entmake lst)
(entdel ent)
)
((= 'LIST (type p))
(setq p1 (cdr (assoc 13 (entget (vlax-vla-object->ename e))))
p2 (cdr (assoc 14 (entget (vlax-vla-object->ename e))))
)
(if (< (distance p p1) (distance p p2))
(vla-put-extline1suppress
e
(if (= (vla-get-extline1suppress e) :vlax-true)
:vlax-false
:vlax-true
)
)
(vla-put-extline2suppress
e
(if (= (vla-get-extline2suppress e) :vlax-true)
:vlax-false
:vlax-true
)
)
)
)
(t)
)
)
)
)
)
)
)
(princ)
)
;|
功能：尺寸标注文字翻转
|;
(defun c:ea:DIMTxtRev (/ ss ang ssl e lst)
(while (progn
(prompt "\n请选取要翻转文字方向的尺寸标注 <退出>: ")
(setq ss (ssget '((0 . "DIMENSION"))))
)
(setq ssl (sslength ss))
(command ".undo" "g")
(while (> ssl 0)
(setq e (ssname ss (setq ssl (1- ssl)))
lst (entget e)
ang (cdr (assoc 51 lst))
)
(entmod (subst (cons 51
(if (and
(>= pi ang)
(> ang 0)
)
0
pi
)
)
(assoc 51 lst)
lst
)
)
)
(command "undo" "end")
)
(princ)
)
;|
功能：标注删除
|;
(defun c:ea:DimErase (/ ss)
(prompt "\n请选取要删除的尺寸标注<退出>:")
(if (setq ss (ssget '((0 . "DIMENSION"))))
(command "._erase" ss "")
)
(princ)
)
; 尺寸界线修剪小宇 98.8.5 E-MAIL:CHXY@HOTMAIL.COM
; 修改于98.11.27
;
;
(defun dfrmvz (p /)
(if p (list (car p) (cadr p) 0.0))
)
(defun c:Ea:dimtrim (/ n ss sn en pt10 pt13 pt14 ptx
ptx1 ptx2 pt_1 pt_2 ang1 ang2 oexo ose1 ose2
)
(if (and (setq pt_1 (getpoint "\n切断线第一点(切线要穿过尺寸线)<退出>: "))
(setq pt_2
(getpoint pt_1 "\n切断线第二点(切线要穿过尺寸线)<退出>: ")
)
(setq n 0
ss (ssget "F" (list pt_1 pt_2))
)
)
(progn
(setq oexo (getvar "dimexo")
ose1 (getvar "dimse1")
ose2 (getvar "dimse2")
)
(setvar "dimexo" 0.0)
(setvar "dimse1" 0)
(setvar "dimse2" 0)
(setq ptx (mapcar '(lambda (x y) (* 0.5 (+ x y))) pt_1 pt_2))
(while (setq sn (ssname ss n))
(setq n (1+ n)
en (entget sn)
)
(if (= "DIMENSION" (cdr (assoc 0 en)))
(progn
(setq pt10 (cdr (assoc 10 en))
pt13 (cdr (assoc 13 en))
pt14 (cdr
(assoc 14 en)
)
ang1 (angle pt10 pt14)
ang2 (+ ang1 (* 0.5 pi))
pt10 (dfrmvz pt10)
pt13 (dfrmvz pt13)
pt14 (dfrmvz pt14)
pt_1 (inters pt13
(polar pt13 ang1 1000.)
pt10
(polar pt10 ang2 1000.)
nil
)
ptx (dfrmvz ptx)
pt_2 (polar ptx ang2 1000.)
)
(if (and (setq ptx1 (inters pt10 pt14 ptx pt_2 nil))
(setq ptx2 (inters pt_1 pt13 ptx pt_2 nil))
)
(progn
(setq en (subst (cons 14 ptx1) (assoc 14 en) en)
en (subst (cons 13 ptx2) (assoc 13 en) en)
)
(entmod en)
)
)
)
)
)
(setvar "dimexo" oexo)
(setvar "dimse1" ose1)
(setvar "dimse2" ose2)
)
)
(princ)
)

(defun c:ea:DimMerge (/ uo ux uy dme1 dmel1 dme2 dmel2 keyr ucsza dm1p13 
                          dm1p14 dm1p10 dm2p13 np13x np14x e1 e2 
                       ) 
  (command ".undo" "g") 
  (setq uo (getvar "ucsorg") 
        ux (getvar "ucsxdir") 
        uy (getvar "ucsydir") 
  ) 
  (command "cmdecho" "0" "osnap" "nea" "ucs" "") 
  (defun *error* (msg) 
    (print "\n取消!") 
    (command ".ucs" "3" uo ux uy) 
    (command ".undo" "end") 
    (setq *error* nil) 
  ) 
  (if (and (setq e1 (car (entsel "\n点选要合并的第一个尺寸标注<退出>:"))) 
           (= (cdr (assoc 0 (setq dmel1 (entget e1)))) "DIMENSION") 
      ) 
    (while (and 
             (setq e2 (car (entsel "\n点选要合并的第二个尺寸标注<退出>:"))) 
             (= (cdr (assoc 0 (setq dmel2 (entget e2)))) "DIMENSION") 
           )                                
      (if (member '(100 . "AcDbRotatedDimension") dmel1) 
        (setq keyr "T") 
        (setq keyr nil) 
      ) 
      (if keyr 
        (setq ucsza (angtos (cdr (assoc 50 dmel1)) 0 3)) 
        (setq ucsza (angtos (angle (cdr (assoc 14 dmel1)) (cdr 
                                                               (assoc 13 
                                                                      dmel1 
                                                               ) 
                                                          ) 
                            ) 0 3 
                    ) 
        ) 
      ) 
      (command "ucs" "z" ucsza) 
      (setq dm1p13 (trans (cdr (assoc 13 dmel1)) 0 1) 
            dm1p14 (trans (cdr (assoc 14 dmel1)) 0 1) 
            dm1p10 (trans (cdr (assoc 10 dmel1)) 0 1) 
            dm2p13 (trans (cdr (assoc 13 dmel2)) 0 1) 
            dm2p14 (trans (cdr (assoc 14 dmel2)) 0 1) 
            np13x (min 
                    (car dm1p13) 
                    (car dm1p14) 
                    (car dm2p13) 
                    (car dm2p14) 
                  ) 
            np14x (max 
                    (car dm1p13) 
                    (car dm1p14) 
                    (car dm2p13) 
                    (car dm2p14) 
                  ) 
      ) 
      (setq dmel1 (subst 
                    (cons 13 (trans (cons np13x (cdr dm1p13)) 1 0)) 
                    (assoc 13 dmel1) 
                    dmel1 
                  ) 
            dmel1 (subst 
                    (cons 14 (trans (cons np14x (cdr dm1p14)) 1 0)) 
                    (assoc 14 dmel1) 
                    dmel1 
                  ) 
            dmel1 (subst 
                    (cons 10 (trans (cons np14x (cdr dm1p10)) 1 0)) 
                    (assoc 10 dmel1) 
                    dmel1 
                  ) 
      ) 
      (entdel e2) 
      (entmod dmel1) 
      (command "ucs" "") 
    ) 
  )                                       ; end while 
  (command ".ucs" "3" uo ux uy) 
  (setq *error* nil) 
  (command ".undo" "end") 
  (princ) 
) 
;| 
标注分割, 断开工具适用线形标注、对齐标注、水平标注、垂直标注 
|; 
(defun c:ea:DimBrk (/ tf e p1 p2 pt pt1 pt0 pn ang oldlist newlist1 
                          newlist2 key str nstr k 
                       ) 
  (command ".undo" "g") 
  (setq tf T) 
  (while tf    
    (if (and (setq e (car (entsel "\n请选取要断开的尺寸标注<退出>:"))) 
             (= (cdr (assoc 0 (setq oldlist (entget e)))) "DIMENSION") 
        ) 
      (progn 
        (setvar "osmode" 3063) 
        (setq oldlist (cdr (entget e))) 
        (setq p1 (cdr (assoc 13 oldlist)) 
              p2 (cdr (assoc 14 oldlist)) 
              ang (if (= (cdr (assoc 70 oldlist)) 33) 
                    (angle p1 p2) 
                    (cdr (assoc 50 oldlist)) 
                  ) 
              str (cdr (assoc 1 oldlist)) 
        ) 
        (initget 128 "1 2 3 4 5 6 7") 
        (if (not (setq pt (getpoint "\n断开点/均分份数[1/2/3/4/5/6/7]<2>: "))) 
          (setq pt "2") 
        ) 
        (cond 
          ((= (type pt) 'LIST) 
            (progn 
              (setq pt1 (polar pt (- ang (/ pi 2)) 1)) 
              (setq pt0 (inters 
                          p1 
                          p2 
                          pt 
                          pt1 
                          nil 
                        ) 
              ) 
              (if (not (equal (angle pt0 p1) (angle pt0 p2) 0.000001)) 
                (progn 
                  (setq newlist1 (subst 
                                   (cons 14 pt0) 
                                   (assoc 14 oldlist) 
                                   oldlist 
                                 ) 
                        newlist2 (subst 
                                   (cons 13 pt0) 
                                   (assoc 13 oldlist) 
                                   oldlist 
                                 ) 
                  ) 
                  (if (/= str "") 
                    (progn 
                      (setq nstr (atof str) 
                            k         (/ (distance pt0 p1) (distance p1 p2)) 
                      ) 
                      (setq newlist1 (subst (cons 1 
                                                  (rtos        (* k nstr) 
                                                        (getvar "DIMLUNIT") 
                                                        (getvar "dimdec") 
                                                  ) 
                                            ) 
                                            (assoc 1 newlist1) 
                                            newlist1 
                                     ) 
                            newlist2 (subst 
                                       (cons 1 
                                             (rtos (* (- 1. k) nstr) 
                                                   (getvar "DIMLUNIT") 
                                                   (getvar "dimdec") 
                                             ) 
                                       ) 
                                       (assoc 1 newlist2) 
                                       newlist2 
                                     ) 
                      ) 
                    ) 
                  )                     
                  (entdel e) 
                  (entmake  newlist1) 
                  (entmake newlist2) 
                ) 
                (PROGN 
                  (initget "Extend Add") 
                  (if (not (setq key (getkword "\n[E -延伸/ A -加入]<A>: "))) 
                    (setq key "Add") 
                  ) 
                  (if (> (distance pt0 p1) ; 13 
                         (distance pt0 p2) ; 14 
                      ) 
                    (setq newlist1 (subst 
                                     (cons (if (= key "Add") 
                                             13 
                                             14 
                                           ) pt0 
                                     ) 
                                     (assoc (if (= key "Add") 
                                              13 
                                              14 
                                            ) oldlist 
                                     ) 
                                     oldlist 
                                   ) 
                    ) 
                    (setq newlist1 (subst 
                                     (cons (if (= key "Add") 
                                             14 
                                             13 
                                           ) pt0 
                                     ) 
                                     (assoc (if (= key "Add") 
                                              14 
                                              13 
                                            ) oldlist 
                                     ) 
                                     oldlist 
                                   ) 
                    ) 
                  ) 
                  (if (= key "Extend") 
                    (entdel e) 
                  ) 
                  (entmake newlist1) 
                ) 
              ) 
            ) 
          ) 
          ((= (type pt) 'STR) 
            (setq d (/ (distance p1 p2) (atof pt))) 
            (if        (/= str "") 
              (progn 
                (setq nstr (atof str) 
                      k           (/ 1. (atof pt)) 
                ) 
                (setq nstr 
                       (rtos (* k nstr) 
                             (getvar "DIMLUNIT") 
                             (getvar "dimdec") 
                       ) 
                ) 
              ) 
            ) 
            (entdel e) 
            (repeat (read pt) 
              (setq pn             (polar p1 ang d) 
                    newlist1 (subst 
                               (cons 14 pn) 
                               (assoc 14 oldlist) 
                               oldlist 
                             ) 
                    oldlist  (subst 
                               (cons 13 pn) 
                               (assoc 13 newlist1) 
                               newlist1 
                             ) 
              ) 
              (if nstr 
                (setq newlist1 (subst (cons 1 nstr) 
                                      (assoc 1 newlist1) 
                                      newlist1 
                               ) 
                ) 
              ) 
              (entmake newlist1) 
              (setq p1 pn) 
            ) 
          ) 
          (T 
          ) 
        ) 
      )                                       ; progn 
      (setq tf nil) 
    )                                       ; if 
  )                                       ; while 
  (command ".undo" "end") 
  (princ) 
) 
;| 
  将选择的标注，恢复标注值到原始状态下。 
|; 
 
(defun c:ea:DimResVal        (/ ss e ssl lst) 
  (command ".undo" "g") 
  (while (progn 
           (prompt "\n请选取要恢复原值的尺寸标注<退出>:") 
           (setq ss (ssget '((0 . "dimension")))) 
         ) 
    (setq ssl (sslength ss)) 
    (while (> ssl 0) 
      (setq e        (ssname ss (setq ssl (1- ssl))) 
            lst        (entget e) 
      ) 
      (entmod (subst '(1 . "") 
                     (assoc 1 lst) 
                     lst 
              ) 
      ) 
      (entupd e) 
    ) 
  ) 
  (command ".undo" "end") 
  (princ) 
) 
;| 
  功能：增减边线 
|; 
(defun c:ea:DimASBX (/ e p p1 p2 ent) 
  (ea:Clearcset) 
  (prompt "\n请选取要增减边线的尺寸实体<退出>:") 
  (if (ssget '((0 . "dimension"))) 
    (progn 
      (while (and 
               (listp p) 
               (progn 
                 (initget "A D R") 
                 (setq p 
                        (getpoint 
                          "\r点取要增减边线的位置[A -全增加 /D -全去掉/R -恢复默认]<退出>: " 
                        ) 
                 ) 
               ) 
             ) 
        (vlax-map-collection 
          (vlax-get-property 
            (vlax-get-property 
              (vlax-get-acad-object) 
              'activedocument 
            ) 
            'activeselectionset 
          ) 
          '(lambda (e) 
             (if (member (vla-get-objectname e) 
                         '("AcDbAlignedDimension" 
                           "AcDbRotatedDimension" 
                           "AcDb3PointAngularDimension" 
                          ) 
                 ) 
               (cond 
                 ((= p "A") 
                  (vla-put-ExtLine1Suppress e :vlax-false) 
                  (vla-put-extline2suppress e :vlax-false) 
                 ) 
                 ((= p "D") 
                  (vla-put-ExtLine1Suppress e :vlax-true) 
                  (vla-put-extline2suppress e :vlax-true) 
                 ) 
                 ((= p "R") 
                  (setq 
                    lst        (entget (setq ent (vlax-vla-object->ename e))) 
                  ) 
                  (entmake lst) 
                  (entdel ent) 
                 ) 
                 ((= 'LIST (type p)) 
                  (setq        p1 (cdr (assoc 13 (entget (vlax-vla-object->ename e)))) 
                        p2 (cdr (assoc 14 (entget (vlax-vla-object->ename e)))) 
                  ) 
                  (if (< (distance p p1) (distance p p2)) 
                    (vla-put-extline1suppress 
                      e 
                      (if (= (vla-get-extline1suppress e) :vlax-true) 
                        :vlax-false 
                        :vlax-true 
                      ) 
                    ) 
                    (vla-put-extline2suppress 
                      e 
                      (if (= (vla-get-extline2suppress e) :vlax-true) 
                        :vlax-false 
                        :vlax-true 
                      ) 
                    ) 
                  ) 
                 ) 
                 (t) 
               ) 
             ) 
         ) 
        ) 
      ) 
    ) 
  ) 
  (princ) 
) 
;| 
  功能：尺寸标注文字翻转 
|; 
(defun c:ea:DIMTxtRev (/ ss ang ssl e lst) 
  (while (progn 
           (prompt "\n请选取要翻转文字方向的尺寸标注 <退出>: ") 
           (setq ss (ssget '((0 . "DIMENSION")))) 
         ) 
    (setq ssl (sslength ss)) 
    (command ".undo" "g") 
    (while (> ssl 0) 
      (setq e        (ssname ss (setq ssl (1- ssl))) 
            lst        (entget e) 
            ang        (cdr (assoc 51 lst)) 
      ) 
      (entmod (subst (cons 51 
                           (if (and 
                                 (>= pi ang) 
                                 (> ang 0) 
                               ) 
                             0 
                             pi 
                           ) 
                     ) 
                     (assoc 51 lst) 
                     lst 
              ) 
      ) 
    ) 
    (command "undo" "end") 
  ) 
  (princ) 
) 
;| 
  功能：标注删除 
|; 
(defun c:ea:DimErase (/ ss) 
  (prompt "\n请选取要删除的尺寸标注<退出>:") 
  (if (setq ss (ssget '((0 . "DIMENSION")))) 
    (command "._erase" ss "") 
  ) 
  (princ) 
) 
;          尺寸界线修剪 小宇 98.8.5 E-MAIL:CHXY@HOTMAIL.COM 
;          修改于98.11.27 
; 
; 
(defun dfrmvz (p /) 
  (if p (list (car p) (cadr p) 0.0)) 
) 
(defun c:Ea:dimtrim (/        n     ss    sn          en        pt10  pt13  pt14  ptx 
                  ptx1        ptx2  pt_1  pt_2  ang1        ang2  oexo  ose1  ose2 
                 ) 
  (if (and (setq pt_1 (getpoint "\n切断线第一点(切线要穿过尺寸线)<退出>: ")) 
           (setq pt_2 
                  (getpoint pt_1 "\n切断线第二点(切线要穿过尺寸线)<退出>: ") 
           ) 
           (setq n  0 
                 ss (ssget "F" (list pt_1 pt_2)) 
           ) 
      ) 
    (progn 
      (setq oexo (getvar "dimexo") 
            ose1 (getvar "dimse1") 
            ose2 (getvar "dimse2") 
      ) 
      (setvar "dimexo" 0.0) 
      (setvar "dimse1" 0) 
      (setvar "dimse2" 0) 
      (setq ptx (mapcar '(lambda (x y) (* 0.5 (+ x y))) pt_1 pt_2)) 
      (while (setq sn (ssname ss n)) 
        (setq n         (1+ n) 
              en (entget sn) 
        ) 
        (if (= "DIMENSION" (cdr (assoc 0 en))) 
          (progn 
            (setq pt10 (cdr (assoc 10 en)) 
                  pt13 (cdr (assoc 13 en)) 
                  pt14 (cdr 
                         (assoc 14 en) 
                       ) 
                  ang1 (angle pt10 pt14) 
                  ang2 (+ ang1 (* 0.5 pi)) 
                  pt10 (dfrmvz pt10) 
                  pt13 (dfrmvz pt13) 
                  pt14 (dfrmvz pt14) 
                  pt_1 (inters pt13 
                               (polar pt13 ang1 1000.) 
                               pt10 
                               (polar pt10 ang2 1000.) 
                               nil 
                       ) 
                  ptx  (dfrmvz ptx) 
                  pt_2 (polar ptx ang2 1000.) 
            ) 
            (if        (and (setq ptx1 (inters pt10 pt14 ptx pt_2 nil)) 
                     (setq ptx2 (inters pt_1 pt13 ptx pt_2 nil)) 
                ) 
              (progn 
                (setq en (subst (cons 14 ptx1) (assoc 14 en) en) 
                      en (subst (cons 13 ptx2) (assoc 13 en) en) 
                ) 
                (entmod en) 
              ) 
            ) 
          ) 
        ) 
      ) 
      (setvar "dimexo" oexo) 
      (setvar "dimse1" ose1) 
      (setvar "dimse2" ose2) 
    ) 
  ) 
  (princ) 
)

158466939 · 发表于 2009-1-14 16:48:47

革命上未成功，同志仍须努力，继续、继续、继续、继续、继续

eachy · 发表于 2009-1-15 14:49:38

继续贴个计算程序
通用函数

(defun ybvl-addtxt (ms str hi / txt tf p typ)
(setq txt (vla-addtext ms str (vlax-3d-point (getvar "viewctr")) hi))
(setq tf t)
(while tf
(vl-catch-all-apply
'(lambda ()
(setq p (grread t 12))
)
)
(cond
((= (car p) 3)
(vla-put-insertionpoint txt (vlax-3d-point (cadr p)))
(setq tf nil)
)
((= (car p) 5)
(vla-put-insertionpoint txt (vlax-3d-point (cadr p)))
)
(t
(vla-delete txt)
(setq txt nil
tf nil
)
)
)
(setq p nil)
)
txt
)

主程序

;;Author: eachy 2009.1.15 修改版
(defun c:Ea:Addtxt (/ eEntsel eSsget obj key lst tf e e1 ss d tf1)
(defun eEntsel (str)
(car (entsel str))
)
(defun essget (str e / ss ss->num lst)
(defun ss->num (sset / ssl i l)
(setq ssl (sslength sset)
i -1
)
(repeat ssl
(setq l
(cons (distof
(cdr (assoc 1 (entget (ssname sset (setq i (1+ i))))))
)
l
)
)
)
l
)
(Princ str)
(if (setq ss (ssget '((0 . "text"))))
(if e
(progn
(ssdel e ss)
(setq lst (list
(cdr (assoc 40 (entget (ssname ss 0))))
(distof (cdr (assoc 1 (entget e))))
(ss->num ss)
)
)
)
(setq lst (list (cdr (assoc 40 (entget (ssname ss 0))))
(ss->num ss)
)
)
)
)
lst
)
(if (not $ea_addmode)
(setq $ea_addmode "0")
)
(setq tf t)
(setvar "dimzin" 0)
(if (zerop (getvar "tilemode"))
(setq obj (vla-get-ActivePViewport
(vla-get-activedocument (vlax-get-acad-object))
)
)
(setq obj (vla-get-Modelspace
(vla-get-activedocument (vlax-get-acad-object))
)
)
)
(while tf
(initget 128 "0 1 2 3 4 5 E")
(setq
key
(getkword
(strcat
"\n选择[0 -加/1 -减/2 -乘/3 -除/4 -百分比/5 -比例/ E - Exit]<"
$ea_addmode
">: "
)
)
)
(if (or (not key) (= key ""))
(setq key $ea_addmode)
(setq $ea_addmode key)
)
(cond
((or (setq tf1 (= key "0")) (= key "2"))
(if (setq lst (essget "\n选择统计数字...." nil))
(ybvl-addtxt
obj
(if tf1
(rtos (apply '+ (cadr lst)) 2 4)
(rtos (apply '* (cadr lst)) 2 4)
)
(car lst)
)
(setq tf nil)
)
)
((or (setq tf1 (= key "1")) (= key "3"))
(if (and (setq e (eEntsel "\n拾取总数: "))
(setq lst (essget "\n选择数字...." e))
)
(if tf1
(ybvl-addtxt
obj
(rtos (- (cadr lst) (apply '+ (caddr lst))) 2 4)
(car lst)
)
(if (vl-catch-all-error-p
(setq d (vl-catch-all-apply
'/
(list (cadr lst) (apply '* (caddr lst)))
)
)
)
(princ "\nDived by Zerop!")
(ybvl-addtxt obj (rtos d 2 4) (car lst))
)
)
(setq tf nil)
)
)
((= key "E")
(setq tf nil)
)
(t
(if (and (setq e (eEntsel "\n拾取总数: "))
(setq e1 (eEntsel "\n拾取数:"))
)
(if (vl-catch-all-error-p
(setq d (vl-catch-all-apply
'/
(list (distof (cdr (assoc 1 (entget e1))))
(distof (cdr (assoc 1 (entget e))))
)
)
)
)
(princ "\nDived by Zerop!")
(ybvl-addtxt
obj
(if (= key "4")
(strcat (rtos (* d 100.) 2 4) "%")
(rtos d 2 4)
)
(cdr (assoc 40 (entget e)))
)
)
(setq tf nil)
)
)
)
)
(princ)
)

;;Author: eachy 2009.1.15 修改版 
(defun c:Ea:Addtxt (/ eEntsel eSsget obj key lst tf e e1 ss d tf1) 
  (defun eEntsel (str) 
    (car (entsel str)) 
  ) 
  (defun essget        (str e / ss ss->num lst) 
    (defun ss->num (sset / ssl i l) 
      (setq ssl        (sslength sset) 
            i        -1 
      ) 
      (repeat ssl 
        (setq l 
               (cons (distof 
                       (cdr (assoc 1 (entget (ssname sset (setq i (1+ i)))))) 
                     ) 
                     l 
               ) 
        ) 
      ) 
      l 
    ) 
    (Princ str) 
    (if        (setq ss (ssget '((0 . "text")))) 
      (if e 
        (progn 
          (ssdel e ss) 
          (setq        lst (list 
                      (cdr (assoc 40 (entget (ssname ss 0)))) 
                      (distof (cdr (assoc 1 (entget e)))) 
                      (ss->num ss) 
                    ) 
          ) 
        ) 
        (setq lst (list        (cdr (assoc 40 (entget (ssname ss 0)))) 
                        (ss->num ss) 
                  ) 
        ) 
      ) 
    ) 
    lst 
  ) 
  (if (not $ea_addmode) 
    (setq $ea_addmode "0") 
  ) 
  (setq tf t) 
  (setvar "dimzin" 0) 
  (if (zerop (getvar "tilemode")) 
    (setq obj (vla-get-ActivePViewport 
                (vla-get-activedocument (vlax-get-acad-object)) 
              ) 
    ) 
    (setq obj (vla-get-Modelspace 
                (vla-get-activedocument (vlax-get-acad-object)) 
              ) 
    ) 
  ) 
  (while tf 
    (initget 128 "0 1 2 3 4 5 E") 
    (setq 
      key 
       (getkword 
         (strcat 
           "\n选择[0 -加/1 -减/2 -乘/3 -除/4 -百分比/5 -比例/ E - Exit]<" 
           $ea_addmode 
           ">: " 
         ) 
       ) 
    ) 
    (if        (or (not key) (= key "")) 
      (setq key $ea_addmode) 
      (setq $ea_addmode key) 
    ) 
    (cond 
      ((or (setq tf1 (= key "0")) (= key "2")) 
       (if (setq lst (essget "\n选择统计数字...." nil)) 
         (ybvl-addtxt 
           obj 
           (if tf1 
             (rtos (apply '+ (cadr lst)) 2 4) 
             (rtos (apply '* (cadr lst)) 2 4) 
           ) 
           (car lst) 
         ) 
         (setq tf nil) 
       ) 
      ) 
      ((or (setq tf1 (= key "1")) (= key "3")) 
       (if (and        (setq e (eEntsel "\n拾取总数: ")) 
                (setq lst (essget "\n选择数字...." e)) 
           ) 
         (if tf1 
           (ybvl-addtxt 
             obj 
             (rtos (- (cadr lst) (apply '+ (caddr lst))) 2 4) 
             (car lst) 
           ) 
           (if (vl-catch-all-error-p 
                 (setq d (vl-catch-all-apply 
                           '/ 
                           (list (cadr lst) (apply '* (caddr lst))) 
                         ) 
                 ) 
               ) 
             (princ "\nDived by Zerop!") 
             (ybvl-addtxt obj (rtos d 2 4) (car lst)) 
           ) 
         ) 
         (setq tf nil) 
       ) 
      ) 
      ((= key "E") 
       (setq tf nil) 
      ) 
      (t 
       (if (and        (setq e (eEntsel "\n拾取总数: ")) 
                (setq e1 (eEntsel "\n拾 取 数:")) 
           ) 
         (if (vl-catch-all-error-p 
               (setq d (vl-catch-all-apply 
                         '/ 
                         (list (distof (cdr (assoc 1 (entget e1)))) 
                               (distof (cdr (assoc 1 (entget e)))) 
                         ) 
                       ) 
               ) 
             ) 
           (princ "\nDived by Zerop!") 
           (ybvl-addtxt 
             obj 
             (if (= key "4") 
               (strcat (rtos (* d 100.) 2 4) "%") 
               (rtos d 2 4) 
             ) 
             (cdr (assoc 40 (entget e))) 
           ) 
         ) 
         (setq tf nil) 
       ) 
      ) 
    ) 
  ) 
  (princ) 
)

158466939 · 发表于 2009-1-15 15:06:51

脱掉、脱掉、把底裤脱掉……

dabingrain · 发表于 2009-1-20 15:32:43

纯粹支持，慢慢看慢慢学习

oujun1971 · 发表于 2009-1-26 14:17:38

继续革命!来个"填充提取"的lsp吧!!!!

雄啸 · 发表于 2009-1-29 19:15:53

怎么叫"填充提取"？

oujun1971 · 发表于 2009-1-31 12:33:53

"填充提取"见晓东工具!

bububa918 · 发表于 2009-2-6 09:18:24

;21楼的Obj_lyr.lsp 无法运行？？
;错误: 参数类型错误: VLA-OBJECT nil

wudongfeng001 · 发表于 2009-2-6 18:59:43

看不懂，有时间学学！！

5341652 · 发表于 2009-2-12 10:43:02

很好的丢东西

five321 · 发表于 2009-2-12 19:28:21

支持开源，支持晓东

happyboy75 · 发表于 2009-2-16 09:58:08

谢谢好东西参考一下

夜精灵 · 发表于 2009-2-18 21:29:12

感谢楼主的无私

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

[原创]：Eachy 工具集 Lisp源码 详解

[原创]：Eachy 工具集 Lisp源码详解