悬赏缩放LISP源码

c735023723

xyp1964

此功能基本木有用
柱子缩小－尺寸不变

x_s_s_1

（仅针对楼主测试图）修改了一下，标注的位置有思路，但是实现起来比较麻烦（对我来讲），有空了再搞吧。

2. 
   
3. (vl-load-com)
   
4. ;;;lst_ssn函数(lst_ssn ss)
   
5. ;;;ss参数：选折集
   
6. ;;;返回图元名表
   
7. (defun lst_ssn (ss / n lst)
   
8.   (repeat (setq N (sslength ss))
   
9.     (setq LST (cons (ssname SS (setq N (1- N))) LST))
   
10.   ) ;_ 结束repeat
    
11. ) ;_ 结束defun
    
12. ;;;计算曲线交点
    
13. (defun Curveinters (en1 en2 / pl pts)
    
14.   (setq pl (vlax-invoke
    
15.       (vlax-ename->vla-object en2)
    
16.       'IntersectWith
    
17.       (vlax-ename->vla-object en1)
    
18.       acExtendNone
    
19.     )
    
20.   )
    
21.   (while pl
    
22.     (setq pts (append pts (list (list (car pl) (cadr pl) (caddr pl))))
    
23.    pl  (cdr (cdr (cdr pl)))
    
24.     )
    
25.   )
    
26.   pts
    
27. )
    
28. ;;;更改标注比例因子
    
29. (defun ch_dim_bl (en sc)
    
30.   (entmod (reverse (cons (list -3
    
31.           (list "acad"
    
32.          '(1000 . "DSTYLE")
    
33.          '(1002 . "{")
    
34.          '(1070 . 144)
    
35.      ;DIMLFAC变量'设置线性标注测量值的比例因子
    
36.          (cons 1040 sc)
    
37.          '(1002 . "}")
    
38.           ) ;_ 结束list
    
39.     ) ;_ 结束list
    
40.     (reverse (entget en))
    
41.      )
    
42.    )
    
43.   )
    
44. )
    
45. (defun zsf (/ old_ly ss_all ss_dot ss_sc ss_pts pt ssets scal n)
    
46.   (setvar "cmdecho" 0)
    
47.   (setq old_ly (getvar "CLAYER"))
    
48.   (setvar "CLAYER" "柱涂实")
    
49.   (prompt "\n请选择需要进行缩放的物体:")
    
50.   (setq ss_all (ssget))   ;此处可根据个人习惯增加图层(ssget  '((8 . "colu,dim,sbar,dote,axis")))
    
51.   (setq ss_dot (ssget "p" (list '(0 . "*line") '(8 . "轴线__点划线"))))
    
52.      ;此处图层根据个人习惯改
    
53.   (command "._Select" ss_all "remove" ss_dot "")
    
54.   (setq ss_sc (ssget "p"))
    
55.   (setq ss_pts (lst_ssn ss_dot))
    
56.   (setq pt (car (Curveinters (car ss_pts) (cadr ss_pts))))
    
57.   (setq ssets (lst_ssn ss_sc))
    
58.   (if (setq scal (getreal "\n比例因子<0.25>:"))
    
59.     t
    
60.     (setq scal 0.25)
    
61.   )
    
62.   (foreach n (lst_ssn ss_sc)
    
63.     (if (or (= (cdr (assoc 8 (entget n))) "柱平法箍筋")
    
64.      (= (cdr (assoc 8 (entget n))) "柱平法纵筋")
    
65.      (= (cdr (assoc 8 (entget n))) "柱__钢筋标注")
    
66. )
    
67.       (progn (ssdel n ss_sc) (entdel n))
    
68.     )
    
69.     (if (= (cdr (assoc 8 (entget n))) "柱截面标注")
    
70.       (progn (vla-scaleentity
    
71.         (vlax-ename->vla-object n)
    
72.         (vlax-3D-point pt)
    
73.         scal
    
74.       )
    
75.       (ch_dim_bl n 1)
    
76.       )
    
77.       (if (= (cdr (assoc 8 (entget n))) "柱平法截面")
    
78. (progn (vla-scaleentity
    
79.    (vlax-ename->vla-object n)
    
80.    (vlax-3D-point pt)
    
81.    scal
    
82.         )
    
83.         (command "_hatch" "solid" n "")
    
84. )
    
85.       )
    
86.     )
    
87.   )
    
88.   (setvar "CLAYER" old_ly)
    
89. )
    
90. (defun c:scc ()
    
91.   (zsf)
    
92.   (princ)
    
93. )
    
94. 
    

<br /> (vl-load-com)<br /> ;;;lst_ssn函数(lst_ssn ss)<br /> ;;;ss参数：选折集<br /> ;;;返回图元名表<br /> (defun lst_ssn (ss / n lst)<br />   (repeat (setq N (sslength ss))<br />     (setq LST (cons (ssname SS (setq N (1- N))) LST))<br />   ) ;_ 结束repeat<br /> ) ;_ 结束defun<br /> ;;;计算曲线交点<br /> (defun Curveinters (en1 en2 / pl pts)<br />   (setq pl (vlax-invoke<br />       (vlax-ename->vla-object en2)<br />       'IntersectWith<br />       (vlax-ename->vla-object en1)<br />       acExtendNone<br />     )<br />   )<br />   (while pl<br />     (setq pts (append pts (list (list (car pl) (cadr pl) (caddr pl))))<br />    pl  (cdr (cdr (cdr pl)))<br />     )<br />   )<br />   pts<br /> )<br /> ;;;更改标注比例因子<br /> (defun ch_dim_bl (en sc)<br />   (entmod (reverse (cons (list -3<br />           (list "acad"<br />          '(1000 . "DSTYLE")<br />          '(1002 . "{")<br />          '(1070 . 144)<br />      ;DIMLFAC变量'设置线性标注测量值的比例因子<br />          (cons 1040 sc)<br />          '(1002 . "}")<br />           ) ;_ 结束list<br />     ) ;_ 结束list<br />     (reverse (entget en))<br />      )<br />    )<br />   )<br /> )<br /> (defun zsf (/ old_ly ss_all ss_dot ss_sc ss_pts pt ssets scal n)<br />   (setvar "cmdecho" 0)<br />   (setq old_ly (getvar "CLAYER"))<br />   (setvar "CLAYER" "柱涂实")<br />   (prompt "\n请选择需要进行缩放的物体:")<br />   (setq ss_all (ssget))   ;此处可根据个人习惯增加图层(ssget  '((8 . "colu,dim,sbar,dote,axis")))<br />   (setq ss_dot (ssget "p" (list '(0 . "*line") '(8 . "轴线__点划线"))))<br />      ;此处图层根据个人习惯改<br />   (command "._Select" ss_all "remove" ss_dot "")<br />   (setq ss_sc (ssget "p"))<br />   (setq ss_pts (lst_ssn ss_dot))<br />   (setq pt (car (Curveinters (car ss_pts) (cadr ss_pts))))<br />   (setq ssets (lst_ssn ss_sc))<br />   (if (setq scal (getreal "\n比例因子<0.25>:"))<br />     t<br />     (setq scal 0.25)<br />   )<br />   (foreach n (lst_ssn ss_sc)<br />     (if (or (= (cdr (assoc 8 (entget n))) "柱平法箍筋")<br />      (= (cdr (assoc 8 (entget n))) "柱平法纵筋")<br />      (= (cdr (assoc 8 (entget n))) "柱__钢筋标注")<br /> )<br />       (progn (ssdel n ss_sc) (entdel n))<br />     )<br />     (if (= (cdr (assoc 8 (entget n))) "柱截面标注")<br />       (progn (vla-scaleentity<br />         (vlax-ename->vla-object n)<br />         (vlax-3D-point pt)<br />         scal<br />       )<br />       (ch_dim_bl n 1)<br />       )<br />       (if (= (cdr (assoc 8 (entget n))) "柱平法截面")<br /> (progn (vla-scaleentity<br />    (vlax-ename->vla-object n)<br />    (vlax-3D-point pt)<br />    scal<br />         )<br />         (command "_hatch" "solid" n "")<br /> )<br />       )<br />     )<br />   )<br />   (setvar "CLAYER" old_ly)<br /> )<br /> (defun c:scc ()<br />   (zsf)<br />   (princ)<br /> )<br /> <br />

随梦而飞

顶上去待高手再完善一下，注高手完善后设50明经币，让我下载

水沙漠

TO: 19楼

  (prompt "\n请选择需要进行缩放的物体:")
  (setq ss_all (ssget))   ;此处可根据个人习惯增加图层(ssget  '((8 . "colu,dim,sbar,dote,axis")))
  (setq ss_dot (ssget "p" (list '(0 . "*line") '(8 . "轴线__点划线"))));此处图层根据个人习惯改

    将上述代码做类似如下修改，可增加图层的通用性

  (setq ent_axis (entget (car (entsel " \n 请选择轴线图层："))))
  (setq layername_axis (cdr (assoc 8 ent_axis)))
  ......
  (setq ent_colu (entget (car (entsel " \n 请选择柱标注图层："))))
  (setq layername_colu (cdr (assoc 8 ent_colu)))

  (prompt "\n请选择需要进行缩放的物体:")  

  (setq ss_all (ssget  (list  '(-4 . "<or")
                                     '(-4 . "<and") '(0 . "line,text") (cons 8 layername_axis) '(-4 . "and>")
                                     ......
                                     '(-4 . "<and") '(0 . "line,text") (cons 8 layername_colu) '(-4 . "and>")
                                     '(-4 . "or>")
                              )
                   )
  )
  (setq ss_dot (ssget "p" (list '(0 . "*line") (cons 8 layername_axis))))
  ......
  (setq ss_colu (ssget "p" (list '(0 . "*text") (cons 8 layername_colu))))

jxjaxa

x_s_s_1 发表于 2012-8-3 18:41
严正声明！！子函数均来自明经，非本人原创，尺寸的比例由于不知道个人习惯没有处理

好用好用，谢谢

springwillow

新版探索者带这个功能，命令bbl

无惢

x_s_s_1 发表于 2012-8-3 18:41
严正声明！！子函数均来自明经，非本人原创，尺寸的比例由于不知道个人习惯没有处理

好像没法用

664571221

x_s_s_1 发表于 2012-8-3 18:41
严正声明！！子函数均来自明经，非本人原创，尺寸的比例由于不知道个人习惯没有处理

你好在吗能否 吧比例因子记住 ，输入一次就可以