在GC200块参照上写文字画圆

清风明月10

在GC200块参照上写文字画圆
在这个DWG文件中有测绘用的GC200块参照，它的属性“HEIGHT”,如何能读出它的“HEIGHT”。读出后，写文字表达它，再在块的插件点上画一个半径为1的圆就容易了。

请点击此处下载

查看状态：需购买或无权限

您的用户组是：游客

文件名称:试验代码用.rar 
下载次数:6  文件大小:6.05 KB 
下载权限: 不限 以上  [免费赚D豆]

st788796

清风明月10 发表于 2014-5-18 09:42
总算写出来了，大家共享。
(defun C:TTT()
(setq infolst (getgcinfo (CAR(ENTSEL))))

可以这样写

1. (defun Getatts (obj /)
   
2.   (mapcar '(lambda (att)
   
3.              (list att ;_属性Object
   
4.                    (vla-get-tagstring att) ;_属性标签
   
5.                    (vla-get-textstring att) ;_属性值
   
6.              )
   
7.            )
   
8.           (vlax-invoke obj 'GetAttributes) ;_全部属性Object
   
9.   );_((属性1 Tag1 textstring1) ....)
   
10. )
    
11. (defun c:tt (/ ss sl ms e el)
    
12.   (if (setq ss (ssget '((2 . "GC200") (66 . 1)))) ;_过滤属性酷爱
    
13.     (progn
    
14.       (setq sl (sslength ss)
    
15.             ms (vla-get-modelspace
    
16.                  (vla-get-activedocument (vlax-get-acad-object))
    
17.                )
    
18.       )
    
19.       (while (setq e (ssname ss (setq sl (1- sl)))) ;_取出实体
    
20.         (setq el (cons e el));_构造实体列表
    
21.       )
    
22.       (mapcar '(lambda (x / inspt atts height txt cir)
    
23.                  (setq inspt  (vla-get-InsertionPoint x) ;_
    
24.                        atts   (getatts x) ;_属性列表
    
25.                        height (cadr (assoc "height" (mapcar 'cdr atts))) ;_找出height属性，注意大小写
    
26.                  )
    
27.                  (setq cir (vla-AddCircle ms inspt 0.5));_绘制圆
    
28.                  (vla-put-layer cir "0");_修改圆图层
    
29.                  (setq txt (vla-AddText ms height inspt 2.5));_写高程字
    
30.                  (vla-put-layer txt "0");_修改字图层
    
31.                )
    
32.               (mapcar 'vlax-ename->vla-object el);_转换为Object列表
    
33.       )
    
34.     )
    
35.   )
    
36.   (princ)
    
37. )
    

(defun Getatts (obj /)<br />   (mapcar '(lambda (att)<br />              (list att ;_属性Object<br />                    (vla-get-tagstring att) ;_属性标签<br />                    (vla-get-textstring att) ;_属性值<br />              )<br />            )<br />           (vlax-invoke obj 'GetAttributes) ;_全部属性Object <br />   );_((属性1 Tag1 textstring1) ....)<br /> )<br /> (defun c:tt (/ ss sl ms e el)<br />   (if (setq ss (ssget '((2 . "GC200") (66 . 1)))) ;_过滤属性酷爱<br />     (progn<br />       (setq sl (sslength ss)<br />             ms (vla-get-modelspace<br />                  (vla-get-activedocument (vlax-get-acad-object))<br />                )<br />       )<br />       (while (setq e (ssname ss (setq sl (1- sl)))) ;_取出实体<br />         (setq el (cons e el));_构造实体列表<br />       )<br />       (mapcar '(lambda (x / inspt atts height txt cir)<br />                  (setq inspt  (vla-get-InsertionPoint x) ;_<br />                        atts   (getatts x) ;_属性列表<br />                        height (cadr (assoc "height" (mapcar 'cdr atts))) ;_找出height属性，注意大小写<br />                  )<br />                  (setq cir (vla-AddCircle ms inspt 0.5));_绘制圆<br />                  (vla-put-layer cir "0");_修改圆图层<br />                  (setq txt (vla-AddText ms height inspt 2.5));_写高程字<br />                  (vla-put-layer txt "0");_修改字图层<br />                )<br />               (mapcar 'vlax-ename->vla-object el);_转换为Object列表<br />       )<br />     )<br />   )<br />   (princ)<br /> )<br />

清风明月10

总算写出来了，大家共享。
(defun C:TTT()
(setq infolst (getgcinfo (CAR(ENTSEL))))
            (setq Scale  (car infolst)
                  inserD (cadr infolst)
                  Tag    (caddr infolst)
                  txt    (cadddr infolst)
                  ist1   (cadddr (reverse infolst))
                  txth   (caddr (reverse infolst))
                  ist2   (cadr (reverse infolst))
                  xsws   (car (reverse infolst))
            )
  (PRINC (STRCAT "\nScale" (VL-PRINC-TO-STRING Scale) "\ninserD" (VL-PRINC-TO-STRING inserD) "\nTag" (VL-PRINC-TO-STRING Tag) "\ntxt" (VL-PRINC-TO-STRING txt) "\nist1" (VL-PRINC-TO-STRING ist1) "\ntxth" (VL-PRINC-TO-STRING txth) "\nist2" (VL-PRINC-TO-STRING ist2) "\nxsws" (VL-PRINC-TO-STRING xsws)))               
                (entmake (list (cons 0  "TEXT") (cons 1 (vl-princ-to-string (CAR txt))) (cons 10 inserD)
               (cons 40 2.5)
               (cons 8 "0000用于图元属性快速输出利用（简称“属性”图层）")
               ))
                   ; 在下面画圆，这样就可以直接用“”读出里程及偏移，而孔号就是该点高程
                   (entmake (list '(0 . "CIRCLE") (cons 10 inserD) (cons 40 1.25)(cons 8 "0000用于图元属性快速输出利用（简称“属性”图层）")))
;;;                    (command "break" 单个图元 "f" (list  XZB YZB 高程) (list  XZB YZB 高程))
               
               
               
                )        
                        
(defun getgcinfo (obj / attlist attobj idx inserd ist1 ist2 scale tag txt txth xsws)
  (if (and (= (addgcDXF 0 (entget obj)) "INSERT") (setq obj (MakeObject obj)))
    (if (= (vla-get-HasAttributes obj) :vlax-true)
      (progn
        (setq attlist (varArray->List (vla-GetAttributes obj))
              Scale   (vla-get-XScaleFactor obj)
              inserD  (vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint obj))) ;点(块)的坐标值
              idx     0
        )
        (repeat (length attlist)
          (setq attobj (nth idx attlist)
                Tag   (append Tag   (list (vla-get-TagString attobj)))
                txt   (append txt   (list (vla-get-TextString attobj))) ;(高程值字符)
                ist1  (append ist1 (list (vlax-safearray->list (vlax-variant-value (vla-get-TextAlignmentPoint attobj)))))
                txth  (append txth  (list (vla-get-Height attobj))) ;高程值字符高度
                ist2  (append ist2 (list (vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint attobj)))))
                idx   (1+ idx)
          )
        )
        (cond
          ((= (car Tag) "height")
            (setq xsws (strlen (substr (car txt) (+ 2 (vl-string-search "." (car txt))))))
          )
          ((= (car Tag) "integer")
            (setq xsws (strlen (cadr txt)))
          )
        )
        (list Scale inserD Tag txt ist1 txth ist2 xsws)
      )
    )
  )
)