[LISP程序]：直击－弧长标注

梦断江南 · 发表于 2002-2-28 15:43:33

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

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

×

beta0.1测试版本
简介：
本程序不是标角度，而是用于标弧长的。
1.dmarc,单段圆弧标注
2.dimarc,圆弧连续标注;对圆分段标注也有效果

[font=courier new]
(princ "\ndmarc=====dim arc 单段圆弧标注--------lxx.2001.5")
(princ "\ndimarc=====dim arc 圆弧连续标注--------lxx.2001.5")
;;=============================================================
(defun c:dmarc (/ n ent entl rad ans ane ptcen pts pte ang arcl)
(princ "\ndim arc 单段圆弧标注--------lxx.2001.5")
(setq n (getint "\n标注文字小数点后位数<2>:"))
(if (not n) (setq n 2))
(setq ent (car(entsel "\n选择圆弧:"))
entl (entget ent)
rad (cdr (assoc 40 entl))
ans (cdr (assoc 50 entl))
ane (cdr (assoc 51 entl))
ptcen (cdr (assoc 10 entl))
pts (polar ptcen ans rad)
pte (polar ptcen ane rad)
)
(if (> ane ans)
(setq ang (- ane ans))
(setq ang (+ ane (- (* 2 PI) ans)))
)
(setq arcl (rtos (* rad ang) 2 n))
(command "dim" "an" "" ptcen pts pte pause arcl "" "e")
(princ)
)
;;=============================================================
(defun c:dimarc (/ n ent entl rad ptcen roop ptoff pts pte ans ane roff ang arcl)
(princ "\ndim arc 圆弧连续标注--------lxx.2001.5")
(setq n (getint "\n标注文字小数点后位数<2>:"))
(if (not n) (setq n 2))
(setq ent (car(entsel "\n选择圆弧:"))
entl (entget ent)
rad (cdr (assoc 40 entl))
ptcen (cdr (assoc 10 entl))
roop "true"
ptoff (getpoint "\n标注延伸线偏移点:")
)
(getarcl)
(command "dim" "an" "" ptcen pts pte pause arcl "")
(while roop
(getarcl)
(if (not pte)
(setq roop nil)
(progn
(command "co" pte)
(setq entl (entget(entlast))
entl (subst (cons 1 arcl) (assoc 1 entl) entl)
)
(entmod entl)
);end progn
)
);;end while
(command)
(princ)
)
;;getarcl
(defun getarcl ()
(if (not pts) (setq pts (getpoint "\n标注起点:")) )
(if pte (setq pts pte))
(setq pte (getpoint "\n标注终点:")
ans (angle ptcen pts)
ane (angle ptcen pte)
)
(if ptoff (setq roff (distance ptcen ptoff);;;;;;;标注美化
pts (polar ptcen ans roff)
pte (polar ptcen ane roff)
)
)
(if (> ane ans)
(setq ang (- ane ans))
(setq ang (+ ane (- (* 2 PI) ans)))
)
(setq arcl (rtos (* rad ang) 2 n))
)
[/font]

[font=courier new] 
(princ "\ndmarc=====dim arc 单段圆弧标注--------lxx.2001.5") 
(princ "\ndimarc=====dim arc 圆弧连续标注--------lxx.2001.5") 
;;============================================================= 
(defun c:dmarc (/ n ent entl rad ans ane ptcen pts pte ang arcl) 
(princ "\ndim arc 单段圆弧标注--------lxx.2001.5") 
(setq n (getint "\n标注文字小数点后位数<2>:")) 
(if (not n) (setq n 2)) 
(setq ent (car(entsel "\n选择圆弧:")) 
      entl (entget ent) 
      rad (cdr (assoc 40 entl)) 
      ans (cdr (assoc 50 entl)) 
      ane (cdr (assoc 51 entl)) 
      ptcen (cdr (assoc 10 entl)) 
      pts (polar ptcen ans rad) 
      pte (polar ptcen ane rad) 
) 
(if (> ane ans) 
    (setq ang (- ane ans)) 
    (setq ang (+ ane (- (* 2 PI) ans))) 
) 
(setq arcl (rtos (* rad ang) 2 n)) 
(command "dim" "an" "" ptcen pts pte pause arcl "" "e") 
(princ) 
) 
;;============================================================= 
(defun c:dimarc (/ n ent entl rad ptcen roop ptoff pts pte ans ane roff ang arcl) 
(princ "\ndim arc 圆弧连续标注--------lxx.2001.5") 
(setq n (getint "\n标注文字小数点后位数<2>:")) 
(if (not n) (setq n 2)) 
(setq ent (car(entsel "\n选择圆弧:")) 
      entl (entget ent) 
      rad (cdr (assoc 40 entl)) 
      ptcen (cdr (assoc 10 entl)) 
      roop "true" 
      ptoff (getpoint "\n标注延伸线偏移点:") 
) 
(getarcl) 
(command "dim" "an" "" ptcen pts pte pause arcl "") 
(while roop 
 (getarcl) 
 (if (not pte) 
     (setq roop nil) 
     (progn 
      (command "co" pte) 
      (setq entl (entget(entlast)) 
            entl (subst (cons 1 arcl) (assoc 1 entl) entl) 
      ) 
      (entmod entl) 
     );end progn 
 ) 
);;end while 
(command) 
(princ) 
) 
;;getarcl 
(defun getarcl () 
(if (not pts) (setq pts (getpoint "\n标注起点:")) ) 
(if pte (setq pts pte)) 
(setq pte (getpoint "\n标注终点:") 
      ans (angle ptcen pts) 
      ane (angle ptcen pte) 
) 
(if ptoff (setq roff (distance ptcen ptoff);;;;;;;标注美化 
                pts (polar ptcen ans roff) 
                pte (polar ptcen ane roff) 
          ) 
) 
(if (> ane ans) 
    (setq ang (- ane ans)) 
    (setq ang (+ ane (- (* 2 PI) ans))) 
) 
(setq arcl (rtos (* rad ang) 2 n)) 
) 
[/font]

goodsheep · 发表于 2002-3-1 07:56:36

请问代码是如何贴上去的，有一条灰色的分隔线。
而且格式保持很好。
程序没有细看，能作个针对弧线的break吗？

XDSoft · 发表于 2002-3-1 11:26:56

最初由 goodsheep 发布
[B]请问代码是如何贴上去的，有一条灰色的分隔线。
而且格式保持很好。
程序没有细看，能作个针对弧线的break吗？ [/B]

返回论坛，看置顶的帖子“论坛上贴代码保持格式缩进的方法”

说说你说的针对ARC的BREAK是什么要求吧？

nihaogemen · 发表于 2003-5-8 23:35:29

此程序不能判断是优弧还是劣弧，是严重的缺陷，请各位引用者注意。

lsjjm · 发表于 2003-5-30 06:44:09

有一个更简捷的小程序, 见AutoLisp/Vlisp技术开发专栏.

穹心 · 发表于 2004-8-7 22:30:04

厉害！！！！！！！

chm · 发表于 2004-8-8 23:35:56

我还没用呢
不知道哪里有更有好的程序

david96007 · 发表于 2004-8-21 22:38:48

试着判断了优弧劣弧问题，可以在14下运行！

(defun set_ini ()
(setq cmdsave (getvar "cmdecho"))
(setq os (getvar "OSMODE"))
(setvar "cmdecho" 0)
(setvar "OSMODE" 0)
) ;_ end of defun
(defun err_new (msg) (princ msg) (set_close)) ;_ end of defun
(defun set_close ()
(setvar "OSMODE" os)
(setvar "cmdecho" cmdsave)
(setq *error* err_old)
) ;_ end of defun
(defun c:dimarc (/ n key os cmdsave err_old)
(setq err_old *error*
*error* err_new
) ;_ end of setq
(set_ini)
(initget 128 "S C")
(setq key (getkword "\n[单段圆弧标注(S)/圆弧连续标注(C)]< S >: ")) (if (/= key nil)
(setq key (strcase key))
) ;_ end of if
(if (or (= key "S") (= key nil))
(dimarc_s)
(if (= key "C")
(dimarc_C)
)
)
(set_close)
(gc)
(princ)
)
(defun dimarc_s (/ ent entl rad ans ane ptcen pts pte)
(setq n (getint "\n标注文字小数点后位数<2>:"))
(if (not n)
(setq n 2)
)
(setq ent (car (entsel "\n选择圆弧:"))
entl (entget ent)
rad (cdr (assoc 40 entl))
ans (cdr (assoc 50 entl))
ane (cdr (assoc 51 entl))
ptcen (cdr (assoc 10 entl))
pts (polar ptcen ans rad)
pte (polar ptcen ane rad)
)
(command "dim" "an" "" ptcen pts pte pause "" "" "e")
(ang2len)
(princ)
)
;;=============================================================
(defun dimarc_c (/ ent entL rad ptcen roop pts pte)
(setq n (getint "\n标注文字小数点后位数<2>:"))
(if (not n)
(setq n 2)
)
(setq ent (car (entsel "\n选择圆弧:"))
entL (entget ent)
rad (cdr (assoc 40 entL))
ptcen (cdr (assoc 10 entL))
roop "true"
)
(getarcL)
(command "dim" "an" "" ptcen pts pte pause "" "")
(ang2len)
(while roop
(getarcL)
(if (not pte)
(setq roop nil)
(progn (command "co" pte) (ang2len)) ;end progn
)
)
;;end while
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun getarcL ()
(setvar "OSMODE" 33)
(if (not pts)
(setq pts (getpoint "\n标注起点:"))
)
(if pte
(setq pts pte)
)
(setq pte (getpoint "\n标注终点: <右键结束圆弧标注>"))
(if (= pte nil)
(command "dim" "e")
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun ang2len (/ entL ang arcL ptcen pts pte ptp ang01 ang02 ang03
ang21 ang31)
(setq entL (entget (entLast))
ptcen (cdr (assoc 15 entL))
pts (cdr (assoc 13 entL))
pte (cdr (assoc 14 entL))
ptp (cdr (assoc 10 entL))
ang01 (angle ptcen pts)
ang02 (angle ptcen pte)
ang03 (angle ptcen ptp)
ang21 (- ang02 ang01)
ang31 (- ang03 ang01)
)
(if (<= ang21 0)
(if (< ang31 ang21)
(setq ang (+ (* pi 2) ang21))
(if (> ang31 0)
(setq ang (+ (* pi 2) ang21))
(setq ang (- ang21))
)
)
(if (< ang31 ang21)
(if (< ang31 0)
(setq ang (- (* pi 2) ang21))
(setq ang ang21)
)
(setq ang (- (* pi 2) ang21))
)
)
(setq arcL (rtos (* rad ang) 2 n)
arcL (strcat "%%o" arcL)
entL (subst (cons 1 arcL) (assoc 1 entL) entL)
)
(entmod entL)
)

(defun set_ini () 
  (setq cmdsave (getvar "cmdecho")) 
  (setq os (getvar "OSMODE")) 
  (setvar "cmdecho" 0) 
  (setvar "OSMODE" 0) 
) ;_ end of defun 
 
(defun err_new (msg) (princ msg) (set_close)) ;_ end of defun 
 
(defun set_close () 
  (setvar "OSMODE" os) 
  (setvar "cmdecho" cmdsave) 
  (setq *error* err_old) 
) ;_ end of defun 
 
 
(defun c:dimarc        (/ n key os cmdsave err_old) 
  (setq        err_old        *error* 
        *error*        err_new 
  ) ;_ end of setq 
 
  (set_ini) 
  (initget 128 "S C") 
  (setq key (getkword "\n[单段圆弧标注(S)/圆弧连续标注(C)]< S >: "))   (if (/= key nil) 
    (setq key (strcase key)) 
  ) ;_ end of if 
  (if (or (= key "S") (= key nil)) 
    (dimarc_s) 
    (if        (= key "C") 
      (dimarc_C) 
    ) 
  ) 
  (set_close) 
  (gc) 
  (princ) 
) 
 
(defun dimarc_s        (/ ent entl rad ans ane ptcen pts pte) 
  (setq n (getint "\n标注文字小数点后位数<2>:")) 
  (if (not n) 
    (setq n 2) 
  ) 
  (setq        ent   (car (entsel "\n选择圆弧:")) 
        entl  (entget ent) 
        rad   (cdr (assoc 40 entl)) 
        ans   (cdr (assoc 50 entl)) 
        ane   (cdr (assoc 51 entl)) 
        ptcen (cdr (assoc 10 entl)) 
        pts   (polar ptcen ans rad) 
        pte   (polar ptcen ane rad) 
  ) 
  (command "dim" "an" "" ptcen pts pte pause "" "" "e") 
  (ang2len) 
  (princ) 
) 
;;============================================================= 
 
(defun dimarc_c        (/ ent entL rad ptcen roop pts pte) 
  (setq n (getint "\n标注文字小数点后位数<2>:")) 
  (if (not n) 
    (setq n 2) 
  ) 
  (setq        ent   (car (entsel "\n选择圆弧:")) 
        entL  (entget ent) 
        rad   (cdr (assoc 40 entL)) 
        ptcen (cdr (assoc 10 entL)) 
        roop  "true" 
  ) 
  (getarcL) 
  (command "dim" "an" "" ptcen pts pte pause "" "") 
  (ang2len) 
  (while roop 
    (getarcL) 
    (if        (not pte) 
      (setq roop nil) 
      (progn (command "co" pte) (ang2len)) ;end progn 
    ) 
  ) 
  ;;end while 
  (princ) 
) 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
(defun getarcL () 
  (setvar "OSMODE" 33) 
  (if (not pts) 
    (setq pts (getpoint "\n标注起点:")) 
  ) 
  (if pte 
    (setq pts pte) 
  ) 
  (setq pte (getpoint "\n标注终点: <右键结束圆弧标注>")) 
  (if (= pte nil) 
    (command "dim" "e") 
  ) 
) 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
(defun ang2len (/ entL ang arcL        ptcen pts pte ptp ang01        ang02 ang03 
                ang21 ang31) 
  (setq        entL  (entget (entLast)) 
        ptcen (cdr (assoc 15 entL)) 
        pts   (cdr (assoc 13 entL)) 
        pte   (cdr (assoc 14 entL)) 
        ptp   (cdr (assoc 10 entL)) 
        ang01 (angle ptcen pts) 
        ang02 (angle ptcen pte) 
        ang03 (angle ptcen ptp) 
        ang21 (- ang02 ang01) 
        ang31 (- ang03 ang01) 
  ) 
  (if (<= ang21 0) 
    (if        (< ang31 ang21) 
      (setq ang (+ (* pi 2) ang21)) 
      (if (> ang31 0) 
        (setq ang (+ (* pi 2) ang21)) 
        (setq ang (- ang21)) 
      ) 
    ) 
    (if        (< ang31 ang21) 
      (if (< ang31 0) 
        (setq ang (- (* pi 2) ang21)) 
        (setq ang ang21) 
      ) 
      (setq ang (- (* pi 2) ang21)) 
    ) 
  ) 
  (setq        arcL (rtos (* rad ang) 2 n) 
        arcL (strcat "%%o" arcL) 
        entL (subst (cons 1 arcL) (assoc 1 entL) entL) 
  ) 
  (entmod entL) 
)

shisj · 发表于 2004-8-23 13:51:26

还是用标注角度的方法，没有加上弧长的标志，不符合国标啊？

xqs001 · 发表于 2005-1-23 17:46:33

没有LISP的么

li809 · 发表于 2005-2-15 23:31:37

还有很好的吗

PFD8667 · 发表于 2005-3-21 19:01:21

梦断江南:
谢谢您的好程序,解决了分段标注的问题,但如果能随层标注就更好了.但分段标注标注的尺寸好象不对,也许就是优弧与劣弧的问题吧?

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

[LISP程序]：直击－弧长标注

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

相关帖子