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

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 "")
)

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

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

还让不让结构活了？！

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

edata 发表于 2015-8-18 23:07 static/image/common/back.gif

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

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

edata 发表于 2015-8-18 16:32 static/image/common/back.gif

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

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)

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

edata 发表于 2015-8-19 12:29 static/image/common/back.gif
局部调整了下

Edata好酷！

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

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

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

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

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

顶起来顶起来

页: [1]

明经CAD社区's Archiver

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