“提取属性文字，生成标注”程序申请

theisland · 发表于 2015-8-18 16:32:22

给排水专业，画图之繁琐说出来都是泪~~，最近有个想法，如截图和附件所示，币币不多，希望有大神帮忙，翘首以盼！

edata · 发表于 2015-8-18 16:32:23

(defun c:tt(/ ang c1 cen en lay obj p1 p3 pl pl1 pl2 pl3 rad ss str txt1 txtpt1 txtpt2 x y)
(if(setq ss (ssget '((0 . "insert"))))
(while(setq en(ssname ss 0))
(setq obj(vlax-ename->vla-object en))
(vla-GetBoundingBox obj 'p1 'p3)
(setq p1 (vlax-safearray->list p1)
p3 (vlax-safearray->list p3))
(setq rad(* 0.5 (abs(- (car p1)(car p3))))
cen(mapcar '(lambda(x y)(* 0.5 (+ x y))) p1 p3)
ang (* pi 0.5)
lay(vla-get-layer obj)
str (MJ:GetTagTextStringByRef OBJ "XL-1")
)
(setq pl1(polar cen ang rad)
pl2(polar pl1 ang 600.0)
pl3(polar pl2 pi 830.0)
txtpt1(polar pl2 ang 50)
txtpt1(polar txtpt1 pi 70)
txtpt2(polar txtpt1 pi 680)
)
(setq c1 (entmakex (list '(0 . "CIRCLE") (cons 8 lay)(cons 10 cen) (cons 40 rad))))
(setq pl(entmakex (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 8 lay)(cons 90 3) (cons 10 pl1) (cons 10 pl2)(cons 10 pl3))))
(setq txt1 (entmakex (list '(0 . "TEXT")
(cons 8 lay)
(cons 1 str)
(cons 10 txtpt2)
(cons 11 txtpt1)
(cons 40 250)
'(7 . "DIM")
'(71 . 0)
'(72 . 5)
'(73 . 0)
(cons 50 pi)
)
)
)
(bns_makgrp (list c1 pl txt1) str)
(setq ss(ssdel en ss))
)
)
)
;;29.1 [功能] 取得选定块的指定属性
;; (MJ:GetTagTextStringByRef (*En2Obj* (car (entsel))) "设计")
(defun MJ:GetTagTextStringByRef (br tagname / atts tag str)
(if (and
(= (vla-get-hasattributes br) :vlax-true)
(safearray-value
(setq atts
(vlax-variant-value
(vla-getattributes br)
)
)
)
)
(foreach tag (vlax-safearray->list atts)
(if (= (strcase tagname) (strcase (vla-get-tagstring tag)))
(setq str (vla-get-TextString tag))
)
)
)
str
)
;;150 [功能] 生成无名组
;;示例(bns_makgrp (MJ:SS->LIST (ssget)) "描述")
(defun bns_makgrp (LST DESC / EN)
(command "_.-group" "_create" "*" DESC)
(foreach EN LST (command EN))
(command "")
)

(defun c:tt(/ ang c1 cen en lay obj p1 p3 pl pl1 pl2 pl3 rad ss str txt1 txtpt1 txtpt2 x y) 
  (if(setq ss (ssget '((0 . "insert")))) 
    (while(setq en(ssname ss 0)) 
      (setq obj(vlax-ename->vla-object en)) 
      (vla-GetBoundingBox obj 'p1 'p3) 
      (setq p1 (vlax-safearray->list p1) 
            p3 (vlax-safearray->list p3)) 
      (setq rad(* 0.5 (abs(- (car p1)(car p3)))) 
            cen(mapcar '(lambda(x y)(* 0.5 (+ x y))) p1 p3) 
            ang (* pi 0.5) 
            lay(vla-get-layer obj) 
            str (MJ:GetTagTextStringByRef OBJ "XL-1") 
            ) 
      (setq pl1(polar cen ang rad) 
            pl2(polar pl1 ang 600.0) 
            pl3(polar pl2 pi 830.0) 
            txtpt1(polar pl2 ang 50) 
            txtpt1(polar txtpt1 pi 70) 
            txtpt2(polar txtpt1 pi 680) 
            ) 
      (setq c1 (entmakex (list '(0 . "CIRCLE") (cons 8 lay)(cons 10 cen) (cons 40 rad)))) 
      (setq pl(entmakex (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 8 lay)(cons 90 3) (cons 10 pl1) (cons 10 pl2)(cons 10 pl3)))) 
      (setq txt1 (entmakex (list        '(0 . "TEXT") 
                                (cons 8 lay) 
                                (cons 1 str) 
                                (cons 10 txtpt2) 
                                (cons 11 txtpt1) 
                                (cons 40 250) 
                                '(7 . "DIM") 
                                '(71 . 0) 
                                '(72 . 5) 
                                '(73 . 0) 
                                (cons 50 pi) 
                          ) 
                 ) 
      ) 
      (bns_makgrp (list c1 pl txt1) str) 
      (setq ss(ssdel en ss)) 
      ) 
    ) 
  ) 
;;29.1 [功能] 取得选定块的指定属性 
;; (MJ:GetTagTextStringByRef (*En2Obj* (car (entsel))) "设计") 
(defun MJ:GetTagTextStringByRef        (br tagname / atts tag str) 
  (if (and 
        (= (vla-get-hasattributes br) :vlax-true) 
        (safearray-value 
          (setq        atts 
                 (vlax-variant-value 
                   (vla-getattributes br) 
                 ) 
          ) 
        ) 
      ) 
    (foreach tag (vlax-safearray->list atts) 
      (if (= (strcase tagname) (strcase (vla-get-tagstring tag))) 
        (setq str (vla-get-TextString tag)) 
      ) 
    ) 
  ) 
  str 
) 
 
;;150 [功能] 生成无名组 
;;示例(bns_makgrp (MJ:SS->LIST (ssget)) "描述") 
(defun bns_makgrp (LST DESC / EN) 
  (command "_.-group" "_create" "*" DESC) 
  (foreach EN LST (command EN)) 
  (command "") 
)

GamIng · 发表于 2015-8-18 17:07:41

“给排水专业，画图之繁琐说出来都是泪~~”？！

还让不让结构活了？！

theisland · 发表于 2015-8-19 07:22:49

edata 发表于 2015-8-18 23:07

一觉起来美梦成真！叩谢EDATA大大，程序实在是美得不像话！！完美实现全部要求，感动

theisland · 发表于 2015-8-19 10:19:05

edata 发表于 2015-8-18 16:32

我在琢磨怎么追加明经币给老大，如获至宝的我还在兴奋中

edata · 发表于 2015-8-19 12:29:26

局部调整了下

(defun c:tt(/ ang c1 cen en lay obj p1 p3 pl pl1 pl2 pl3 rad ss str txt1 txtpt1 txtpt2 x y)
(setq *error*_Old *error*)
(setq *error* *error*_att_dim)
(princ "\n需要标注选择属性图块:")
(if(setq ss (ssget '((0 . "insert"))))
(progn
(sk_load_style)
(vla-Startundomark(vla-get-activedocument(vlax-get-acad-object)))
(while(setq en(ssname ss 0))
(setq obj(vlax-ename->vla-object en))
(vla-GetBoundingBox obj 'p1 'p3)
(setq p1 (vlax-safearray->list p1)
p3 (vlax-safearray->list p3))
(setq rad(* 0.5 (abs(- (car p1)(car p3))))
cen(mapcar '(lambda(x y)(* 0.5 (+ x y))) p1 p3)
ang (* pi 0.5)
lay(vla-get-layer obj)
str (MJ:GetTagTextStringByRef OBJ "XL-1")
)
(if str
(progn
(setq pl1(polar cen ang rad)
pl2(polar pl1 ang 600.0)
pl3(polar pl2 pi 830.0)
txtpt1(polar pl2 ang 50)
txtpt1(polar txtpt1 pi 70)
txtpt2(polar txtpt1 pi 680)
)
(setq txt1 (entmakex (list '(0 . "TEXT")
(cons 8 lay)
(cons 1 str)
(cons 10 txtpt2)
(cons 11 txtpt1)
(cons 40 250)
'(7 . "DIM")
'(71 . 0)
'(72 . 5)
'(73 . 0)
(cons 50 pi)
)
)
)
(setq c1 (entmakex (list '(0 . "CIRCLE") (cons 8 lay)(cons 10 cen) (cons 40 rad))))
(setq pl(entmakex (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 8 lay)(cons 90 3) (cons 10 pl1) (cons 10 pl2)(cons 10 pl3))))
(create_group (list c1 pl txt1) str)
)
)
(setq ss(ssdel en ss))
)
(vla-Endundomark(vla-get-activedocument(vlax-get-acad-object)))
)
)
(and *error*_Old (setq *error* *error*_Old))
(princ)
)
(defun *error*_att_dim (msg)
(and *error*_Old (setq *error* *error*_Old))
(if (wcmatch (strcase msg t) "*break,*cancel*,*exit*,*取消*")
(if (= (getvar "LOCALE") "CHS")
(princ "\n用户按了<Esc>强制退出")
(princ "\nYou cancelled The operation!")
)
(princ (strcat "\n" msg))
)
(vla-Endundomark(vla-get-activedocument(vlax-get-acad-object)))
(princ)
)
;;29.1 [功能] 取得选定块的指定属性
;; (MJ:GetTagTextStringByRef (*En2Obj* (car (entsel))) "设计")
(defun MJ:GetTagTextStringByRef (br tagname / atts tag str)
(if (and
(= (vla-get-hasattributes br) :vlax-true)
(safearray-value
(setq atts
(vlax-variant-value
(vla-getattributes br)
)
)
)
)
(foreach tag (vlax-safearray->list atts)
(if (= (strcase tagname) (strcase (vla-get-tagstring tag)))
(setq str (vla-get-TextString tag))
)
)
)
str
)
;;无名组2
;;; ------------ CREATES UNAMED GROUP
(defun create_group (sslist desc / groupdictename entlist)
(setq groupdictename (cdar (dictsearch (namedobjdict) "ACAD_GROUP")))
(setq entlist
(append
(list
'(0 . "GROUP")
'(102 . "{ACAD_REACTORS")
(cons 330 groupdictename)
'(102 . "}")
'(100 . "AcDbGroup")
(cons 300 desc) ; Description
'(70 . 1) ; Named Group
'(71 . 1) ; Selectable Group
)
(mapcar '(lambda (ent) (cons 340 ent)) sslist)
;; Add all ent from SSList to the group
)
)
(entmake entlist)
)
;;加载文字样式
(defun sk_load_style ()
(if (not (tblobjname "style" "dim"))
(entmake '((0 . "STYLE")
(100 . "AcDbSymbolTableRecord")
(100 . "AcDbTextStyleTableRecord")
(2 . "DIM")
(70 . 0)
(40 . 0.0)
(41 . 0.75)
(50 . 0.0)
(71 . 0)
(42 . 250.0)
(3 . "txt.shx")
(4 . "")
)
)
)
)
(vl-load-com)
(princ)

(defun c:tt(/ ang c1 cen en lay obj p1 p3 pl pl1 pl2 pl3 rad ss str txt1 txtpt1 txtpt2 x y) 
  (setq *error*_Old *error*) 
  (setq *error* *error*_att_dim)   
  (princ "\n需要标注选择属性图块:") 
  (if(setq ss (ssget '((0 . "insert")))) 
    (progn 
      (sk_load_style) 
      (vla-Startundomark(vla-get-activedocument(vlax-get-acad-object))) 
      (while(setq en(ssname ss 0)) 
        (setq obj(vlax-ename->vla-object en)) 
        (vla-GetBoundingBox obj 'p1 'p3) 
        (setq p1 (vlax-safearray->list p1) 
              p3 (vlax-safearray->list p3)) 
        (setq rad(* 0.5 (abs(- (car p1)(car p3)))) 
              cen(mapcar '(lambda(x y)(* 0.5 (+ x y))) p1 p3) 
              ang (* pi 0.5) 
              lay(vla-get-layer obj) 
              str (MJ:GetTagTextStringByRef OBJ "XL-1") 
              )                
        (if str 
          (progn 
            (setq pl1(polar cen ang rad) 
              pl2(polar pl1 ang 600.0) 
              pl3(polar pl2 pi 830.0) 
              txtpt1(polar pl2 ang 50) 
              txtpt1(polar txtpt1 pi 70) 
              txtpt2(polar txtpt1 pi 680) 
              ) 
            (setq txt1 (entmakex (list '(0 . "TEXT") 
                                   (cons 8 lay) 
                                   (cons 1 str) 
                                   (cons 10 txtpt2) 
                                   (cons 11 txtpt1) 
                                   (cons 40 250) 
                                   '(7 . "DIM") 
                                   '(71 . 0) 
                                   '(72 . 5) 
                                   '(73 . 0) 
                                   (cons 50 pi) 
                                   ) 
                             ) 
              ) 
            (setq c1 (entmakex (list '(0 . "CIRCLE") (cons 8 lay)(cons 10 cen) (cons 40 rad)))) 
            (setq pl(entmakex (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 8 lay)(cons 90 3) (cons 10 pl1) (cons 10 pl2)(cons 10 pl3)))) 
            (create_group (list c1 pl txt1) str) 
            ) 
          )        
        (setq ss(ssdel en ss)) 
        ) 
      (vla-Endundomark(vla-get-activedocument(vlax-get-acad-object))) 
      ) 
    ) 
  (and *error*_Old (setq *error* *error*_Old)) 
  (princ) 
  ) 
(defun *error*_att_dim (msg) 
  (and *error*_Old (setq *error* *error*_Old)) 
  (if (wcmatch (strcase msg t) "*break,*cancel*,*exit*,*取消*") 
    (if        (= (getvar "LOCALE") "CHS") 
      (princ "\n用户按了<Esc>强制退出") 
      (princ "\nYou cancelled The operation!") 
    ) 
    (princ (strcat "\n" msg)) 
  ) 
  (vla-Endundomark(vla-get-activedocument(vlax-get-acad-object)))   
  (princ) 
) 
 
;;29.1 [功能] 取得选定块的指定属性 
;; (MJ:GetTagTextStringByRef (*En2Obj* (car (entsel))) "设计") 
(defun MJ:GetTagTextStringByRef        (br tagname / atts tag str) 
  (if (and 
        (= (vla-get-hasattributes br) :vlax-true) 
        (safearray-value 
          (setq        atts 
                 (vlax-variant-value 
                   (vla-getattributes br) 
                 ) 
          ) 
        ) 
      ) 
    (foreach tag (vlax-safearray->list atts) 
      (if (= (strcase tagname) (strcase (vla-get-tagstring tag))) 
        (setq str (vla-get-TextString tag)) 
      ) 
    ) 
  ) 
  str 
) 
;;无名组2 
;;; ------------ CREATES UNAMED GROUP 
(defun create_group (sslist desc / groupdictename entlist) 
  (setq groupdictename (cdar (dictsearch (namedobjdict) "ACAD_GROUP"))) 
  (setq entlist 
         (append 
           (list 
             '(0 . "GROUP") 
             '(102 . "{ACAD_REACTORS") 
             (cons 330 groupdictename) 
             '(102 . "}") 
             '(100 . "AcDbGroup") 
             (cons 300 desc)             ; Description 
             '(70 . 1)                        ; Named Group 
             '(71 . 1)                        ; Selectable Group 
           ) 
           (mapcar '(lambda (ent) (cons 340 ent)) sslist) 
           ;; Add all ent from SSList to the group 
         ) 
  ) 
  (entmake entlist) 
) 
;;加载文字样式 
(defun sk_load_style () 
  (if (not (tblobjname "style" "dim")) 
    (entmake '((0 . "STYLE") 
               (100 . "AcDbSymbolTableRecord") 
               (100 . "AcDbTextStyleTableRecord") 
               (2 . "DIM") 
               (70 . 0) 
               (40 . 0.0) 
               (41 . 0.75) 
               (50 . 0.0) 
               (71 . 0) 
               (42 . 250.0) 
               (3 . "txt.shx") 
               (4 . "") 
              ) 
    ) 
  ) 
) 
(vl-load-com) 
(princ)

theisland · 发表于 2015-8-22 21:23:39

edata 发表于 2015-8-19 12:29
局部调整了下

Edata好酷！

freehand8008 · 发表于 2015-8-24 15:55:57

帮顶！！！！！
干啥用的啊

jkop · 发表于 2023-7-21 15:05:38

帮顶！！！！！收藏学习～

菜鸟初来乍到 · 发表于 2024-1-18 07:55:00

顶起来顶起来

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

[已解答] “提取属性文字，生成标注”程序申请

最佳答案

相关帖子

评分

点评