大神帮我看下这个代码时好时坏

小男人漏水

2. (defun c:fff (/ ss i e cpt pts pt1)
   
3. (while (and (setq s1 (entsel "\n选择3/4螺纹线孔 :"))
   
4.              (setq ent (entget (car s1)))
   
5.    (wcmatch (setq tn (cdr(assoc 0 ent))) "ARC,"))
   
6.   (setq pt1 (cadr s1))
   
7.   (setq r (cdr(assoc 40 ent)))
   
8. ;判断是否有2细线层。没有新建细线层
   
9. (if (=(tblobjname "LAYER" "2细线层") nil)
   
10. (progn
    
11. (entmake (list
    
12. '(0 . "LAYER")
    
13. '(100 . "AcDbSymbolTableRecord")
    
14. '(100 . "AcDbLayerTableRecord")
    
15. '(6 . "bylayer") ;线型
    
16. '(62 . 4) ;颜色
    
17. '(70 . 0) ;图层状态
    
18. (cons 2 "2细线层") ;图层名
    
19. )
    
20. )
    
21. )
    
22. )
    
23. ;所选线改变为2细线层
    
24.   (setq *laysel* (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))))
    
25.   ;(if (and (setq en (car (entsel "\n选择目标对象:")))
    
26.    (if (and (setq en (car s1))
    
27.    (setq obj (vlax-ename->vla-object en))
    
28.    (setq cor (vla-get-color obj))
    
29.   ;(setq pt (getpoint "\n基点:"))
    
30.     )
    
31.    (progn
    
32.      ;; 分辨颜色
    
33.    (cond ((= cor 256) ;_ 随层
    
34.   (setq cor (vla-get-color (vla-item *laysel* (vla-get-layer obj))))
    
35.    )
    
36.    ((= cor 0) ;_ 随块
    
37.     (setq cor 7)
    
38.    )  )
    
39.      ;; 筛选图层
    
40.   (vlax-for lay *laysel*
    
41. (if (= (vla-get-color lay) cor)
    
42.   (setq lay-lst (cons (vla-get-name lay) lay-lst))
    
43. ) )
    
44. (if lay-lst
    
45. (foreach lay lay-lst
    
46. (if lay-str
    
47.     (setq lay-str (strcat lay-str "," lay))
    
48.    (setq lay-str lay)
    
49. )
    
50. )
    
51.      )
    
52.     ;; 形成选择集
    
53.    (if lay-str
    
54. 
    
55. (setq ss (ssget "x" (list '(-4 . "<OR") (cons 0 lay-str) (cons 62 cor) '(-4 . "OR>"))))
    
56. (setq ss (ssget "x" (list (cons 62 cor))))
    
57.    )
    
58.    (vl-cmdf "change" ss "" "p" "la" "2细线层"  "lt" "bylayer" "c" "bylayer" "")
    
59.     ;(vl-cmdf "move" ss "" pt)
    
60.      ;(vl-cmdf pause)
    
61.   )
    
62. )  
    
63. ;;判断筛选直径等于所选圆弧直径并且线处于2细线层
    
64.   (setq ss (ssget (list '(0 . "arc")'(-4 . "=")(cons 40 r)'(8 . "2细线层"))) i -1)
    
65.   (while (setq e (ssname ss (setq i (1+ i))))
    
66.     (setq cpt(cdr(assoc 10 (entget e))))
    
67.     (if(not(member cpt pts))
    
68.       (setq pts(cons cpt pts))     )   )
    
69.       (length pts)
    
70. ;;判断筛选     
    
71.   (setq qztxt (if (setq qz (length pts)) (strcat (itoa qz) "-") ""))
    
72. (if (= 1 (length pts))
    
73.      (setq qztxt ""))
    
74. ;判断孔数量是否为1  
    
75.   (if (= tn "ARC") (progn
    
76.    (setq r (cdr(assoc 40 ent)))
    
77.    (command ".LENGTHEN" (car s1) "")
    
78.    (if (>= (getvar "PERIMETER") (* 1.5 pi)) (progn
    
79.     (setq qztxt (strcat qztxt "M" (rtos (+ r r) 2) "压铆螺母" ))
    
80.     (command "DIMDIAMETER" pt1 "T" qztxt PAUSE)   
    
81.    )
    
82.     ;(command "DIMRADIUS" pt1 "T" (strcat qztxt "<>") PAUSE)
    
83.    )
    
84.   )
    
85.    ;(command "DIMDIAMETER" pt1 "T" (strcat qztxt "<>") PAUSE)
    
86.   )
    
87. )
    
88. (princ)
    
89. )

(defun c:fff (/ ss i e cpt pts pt1)<br /> (while (and (setq s1 (entsel "\n选择3/4螺纹线孔 :"))<br />              (setq ent (entget (car s1)))<br />    (wcmatch (setq tn (cdr(assoc 0 ent))) "ARC,"))<br />   (setq pt1 (cadr s1))<br />   (setq r (cdr(assoc 40 ent)))<br /> ;判断是否有2细线层。没有新建细线层<br /> (if (=(tblobjname "LAYER" "2细线层") nil)<br /> (progn<br /> (entmake (list<br /> '(0 . "LAYER")<br /> '(100 . "AcDbSymbolTableRecord")<br /> '(100 . "AcDbLayerTableRecord")<br /> '(6 . "bylayer") ;线型<br /> '(62 . 4) ;颜色<br /> '(70 . 0) ;图层状态<br /> (cons 2 "2细线层") ;图层名<br /> )<br /> )<br /> )<br /> )<br /> ;所选线改变为2细线层<br />   (setq *laysel* (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))))<br />   ;(if (and (setq en (car (entsel "\n选择目标对象:")))<br />    (if (and (setq en (car s1))<br />    (setq obj (vlax-ename->vla-object en))<br />    (setq cor (vla-get-color obj))<br />   ;(setq pt (getpoint "\n基点:"))<br />     )<br />    (progn<br />      ;; 分辨颜色<br />    (cond ((= cor 256) ;_ 随层<br />   (setq cor (vla-get-color (vla-item *laysel* (vla-get-layer obj))))<br />    )<br />    ((= cor 0) ;_ 随块<br />     (setq cor 7)<br />    )  )<br />      ;; 筛选图层<br />   (vlax-for lay *laysel*<br /> (if (= (vla-get-color lay) cor)<br />   (setq lay-lst (cons (vla-get-name lay) lay-lst))<br /> ) )<br /> (if lay-lst<br /> (foreach lay lay-lst<br /> (if lay-str<br />     (setq lay-str (strcat lay-str "," lay))<br />    (setq lay-str lay)<br /> )<br /> )<br />      )<br />     ;; 形成选择集<br />    (if lay-str<br /> <br /> (setq ss (ssget "x" (list '(-4 . "<OR") (cons 0 lay-str) (cons 62 cor) '(-4 . "OR>"))))<br /> (setq ss (ssget "x" (list (cons 62 cor))))<br />    )<br />    (vl-cmdf "change" ss "" "p" "la" "2细线层"  "lt" "bylayer" "c" "bylayer" "")<br />     ;(vl-cmdf "move" ss "" pt)<br />      ;(vl-cmdf pause)<br />   )<br /> )  <br /> ;;判断筛选直径等于所选圆弧直径并且线处于2细线层<br />   (setq ss (ssget (list '(0 . "arc")'(-4 . "=")(cons 40 r)'(8 . "2细线层"))) i -1)<br />   (while (setq e (ssname ss (setq i (1+ i))))<br />     (setq cpt(cdr(assoc 10 (entget e))))<br />     (if(not(member cpt pts))<br />       (setq pts(cons cpt pts))     )   )<br />       (length pts)<br /> ;;判断筛选     <br />   (setq qztxt (if (setq qz (length pts)) (strcat (itoa qz) "-") ""))<br /> (if (= 1 (length pts))<br />      (setq qztxt ""))<br /> ;判断孔数量是否为1  <br />   (if (= tn "ARC") (progn<br />    (setq r (cdr(assoc 40 ent)))<br />    (command ".LENGTHEN" (car s1) "")<br />    (if (>= (getvar "PERIMETER") (* 1.5 pi)) (progn<br />     (setq qztxt (strcat qztxt "M" (rtos (+ r r) 2) "压铆螺母" ))<br />     (command "DIMDIAMETER" pt1 "T" qztxt PAUSE)   <br />    )<br />     ;(command "DIMRADIUS" pt1 "T" (strcat qztxt "<>") PAUSE)<br />    )<br />   )<br />    ;(command "DIMDIAMETER" pt1 "T" (strcat qztxt "<>") PAUSE)<br />   )<br /> )<br /> (princ)<br /> )

这个代码步骤是：1.选择4/3圆弧后，并加入2号层
2.筛选出重复圆弧后，统计不重复数量N
3.然后标注出N-M*压铆螺母
现在出现2个问题，
1.第一个是输入命令: fff
选择3/4螺纹线孔 :应用程序错误: 命令输入时发送的类型无效
但是不影响结果。
2.选择弧线以后框选范围出现无法标注：这个问题是间断性出现的。
《
选择3/4螺纹线孔 :应用程序错误: 命令输入时发送的类型无效

选择对象: 找到 1 个

选择对象: 指定对角点: 找到 0 个
选择对象: 指定对角点: 找到 3 个 (1 个重复)，总计 3 个

选择对象:  .LENGTHEN
选择对象或 [增量(DE)/百分数(P)/全部(T)/动态(DY)]:

当前长度: 10.4720，包含角: 300
选择对象或 [增量(DE)/百分数(P)/全部(T)/动态(DY)]:
命令: DIMDIAMETER
选择圆弧或圆:
选择圆弧或圆: T

*无效选择*
需要单个对象。
; 错误: 函数被取消

》》》

劳烦各位大神给看看，上面的代码都是在咋们群里兄弟提供后我自己拼接了一下。

xyp1964

1. (defun c:tt ()
   
2.   (while (and (setq s1 (entsel "\n选择3/4螺纹线孔: "))
   
3.               (setq s2 (car s1))
   
4.               (setq ent (entget s2))
   
5.               (wcmatch (setq tn (cdr (assoc 0 ent))) "ARC")
   
6.          )
   
7.     (setq pt1 (cadr s1)
   
8.           r   (cdr (assoc 40 ent))
   
9.     )                                                  ;判断是否有2细线层。没有新建细线层
   
10.     (if        (= (tblobjname "LAYER" "2细线层") nil)
    
11.       (entmake (list
    
12.                  '(0 . "LAYER")
    
13.                  '(100 . "AcDbSymbolTableRecord")
    
14.                  '(100 . "AcDbLayerTableRecord")
    
15.                  '(6 . "bylayer")                  ;线型
    
16.                  '(62 . 4)                          ;颜色
    
17.                  '(70 . 0)                          ;图层状态
    
18.                  (cons 2 "2细线层")                  ;图层名
    
19.                )
    
20.       )
    
21.     )
    
22.     (setq *laysel* (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))))
    
23.     (if        (and (setq en (car s1))
    
24.              (setq obj (vlax-ename->vla-object en))
    
25.              (setq cor (vla-get-color obj))
    
26.         )
    
27.       (progn
    
28.         (cond ((= cor 256)
    
29.                (setq cor (vla-get-color (vla-item *laysel* (vla-get-layer obj))))
    
30.               )
    
31.               ((= cor 0) (setq cor 7))
    
32.         )
    
33.         (vlax-for lay *laysel*
    
34.           (if (= (vla-get-color lay) cor)
    
35.             (setq lay-lst (cons (vla-get-name lay) lay-lst))
    
36.           )
    
37.         )
    
38.         (if lay-lst
    
39.           (foreach lay lay-lst
    
40.             (if        lay-str
    
41.               (setq lay-str (strcat lay-str "," lay))
    
42.               (setq lay-str lay)
    
43.             )
    
44.           )
    
45.         )
    
46.         (if lay-str
    
47.           (setq        qf (list '(-4 . "<OR") (cons 8 lay-str) (cons 62 cor) '(-4 . "OR>"))
    
48.                 ss (ssget "x" qf)
    
49.           )
    
50.           (setq ss (ssget "x" (list (cons 62 cor))))
    
51.         )
    
52.         (vl-cmdf "change" ss ""        "p" "la" "2细线层" "lt"        "bylayer" "c" "bylayer"        "")
    
53.       )
    
54.     )
    
55.     (setq ss (ssget (list '(0 . "arc") '(-4 . "=") (cons 40 r) '(8 . "2细线层")))
    
56.           i  -1
    
57.     )
    
58.     (if        ss
    
59.       (progn
    
60.         (while (setq e (ssname ss (setq i (1+ i))))
    
61.           (setq cpt (cdr (assoc 10 (entget e))))
    
62.           (if (not (member cpt pts))
    
63.             (setq pts (cons cpt pts))
    
64.           )
    
65.         )
    
66.         (setq qztxt (if        (setq qz (length pts))
    
67.                       (strcat (itoa qz) "-")
    
68.                       ""
    
69.                     )
    
70.         )
    
71.         (if (= 1 (length pts))
    
72.           (setq qztxt "")
    
73.         )
    
74.         (if (= tn "ARC")
    
75.           (progn
    
76.             (setq r (cdr (assoc 40 ent)))
    
77.             (command ".LENGTHEN" (car s1) "")
    
78.             (if        (>= (getvar "PERIMETER") (* 1.5 pi))
    
79.               (progn
    
80.                 (setq qztxt (strcat qztxt "M" (rtos (+ r r) 2) "压铆螺母"))
    
81.                 (command "DIMDIAMETER" pt1 "T" qztxt PAUSE)
    
82.               )
    
83.             )
    
84.           )
    
85.         )
    
86.       )
    
87.     )
    
88.   )
    
89.   (princ)
    
90. )

(defun c:tt ()<br />   (while (and (setq s1 (entsel "\n选择3/4螺纹线孔: "))<br />               (setq s2 (car s1))<br />               (setq ent (entget s2))<br />               (wcmatch (setq tn (cdr (assoc 0 ent))) "ARC")<br />          )<br />     (setq pt1 (cadr s1)<br />           r   (cdr (assoc 40 ent))<br />     )                                                  ;判断是否有2细线层。没有新建细线层<br />     (if        (= (tblobjname "LAYER" "2细线层") nil)<br />       (entmake (list<br />                  '(0 . "LAYER")<br />                  '(100 . "AcDbSymbolTableRecord")<br />                  '(100 . "AcDbLayerTableRecord")<br />                  '(6 . "bylayer")                  ;线型<br />                  '(62 . 4)                          ;颜色<br />                  '(70 . 0)                          ;图层状态<br />                  (cons 2 "2细线层")                  ;图层名<br />                )<br />       )<br />     )<br />     (setq *laysel* (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))))<br />     (if        (and (setq en (car s1))<br />              (setq obj (vlax-ename->vla-object en))<br />              (setq cor (vla-get-color obj))<br />         )<br />       (progn<br />         (cond ((= cor 256)<br />                (setq cor (vla-get-color (vla-item *laysel* (vla-get-layer obj))))<br />               )<br />               ((= cor 0) (setq cor 7))<br />         )<br />         (vlax-for lay *laysel*<br />           (if (= (vla-get-color lay) cor)<br />             (setq lay-lst (cons (vla-get-name lay) lay-lst))<br />           )<br />         )<br />         (if lay-lst<br />           (foreach lay lay-lst<br />             (if        lay-str<br />               (setq lay-str (strcat lay-str "," lay))<br />               (setq lay-str lay)<br />             )<br />           )<br />         )<br />         (if lay-str<br />           (setq        qf (list '(-4 . "<OR") (cons 8 lay-str) (cons 62 cor) '(-4 . "OR>"))<br />                 ss (ssget "x" qf)<br />           )<br />           (setq ss (ssget "x" (list (cons 62 cor))))<br />         )<br />         (vl-cmdf "change" ss ""        "p" "la" "2细线层" "lt"        "bylayer" "c" "bylayer"        "")<br />       )<br />     )<br />     (setq ss (ssget (list '(0 . "arc") '(-4 . "=") (cons 40 r) '(8 . "2细线层")))<br />           i  -1<br />     )<br />     (if        ss<br />       (progn<br />         (while (setq e (ssname ss (setq i (1+ i))))<br />           (setq cpt (cdr (assoc 10 (entget e))))<br />           (if (not (member cpt pts))<br />             (setq pts (cons cpt pts))<br />           )<br />         )<br />         (setq qztxt (if        (setq qz (length pts))<br />                       (strcat (itoa qz) "-")<br />                       ""<br />                     )<br />         )<br />         (if (= 1 (length pts))<br />           (setq qztxt "")<br />         )<br />         (if (= tn "ARC")<br />           (progn<br />             (setq r (cdr (assoc 40 ent)))<br />             (command ".LENGTHEN" (car s1) "")<br />             (if        (>= (getvar "PERIMETER") (* 1.5 pi))<br />               (progn<br />                 (setq qztxt (strcat qztxt "M" (rtos (+ r r) 2) "压铆螺母"))<br />                 (command "DIMDIAMETER" pt1 "T" qztxt PAUSE)<br />               )<br />             )<br />           )<br />         )<br />       )<br />     )<br />   )<br />   (princ)<br /> )

小男人漏水

xyp1964 发表于 2017-12-21 14:54

谢谢版主支持。虽然有点点小小瑕疵。谢谢版主