马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。
您需要 登录 才可以下载或查看，没有账号？立即注册
×
老早在晓东工具箱中的程序，用DCL写的，可能有个别通用函数，请自行搜索论坛
Lisp 部分[pcode=lisp,true]
;;; 本代码仅提供作为应用上的参考, 而未声明或隐含任何保证; 对于任何特殊
;; 用途之适应性, 以及商业销售所隐含作出的保证, 在此一概予以否认.
;; ==================================================================
; 作者：Eachy，
;;
;; 命令：Ea_LhBZ 标注命令
;;
;; 命令：Ea_EdLH 标注编辑
;;
;; 命令：Ea_SetScale 比例设置
;;
;; 命令：Ea_MKTitle 统计表表头及表格生成
;;
;; 命令: TXT_TJ 统计图中相同字串的个数
;
;; 命令: Ea_EraLh 删除本程序生成的图元
;;
;;
;;
;;======================================================================
;|;比例控制
(if (not (vlax-ldata-list "ea_sys_scale"))
(vlax-ldata-put "ea_sys_scale" "scale" 1.)
)
|; ;(setvar "cmdecho" 0)
;;设定字体
(defun $ea_setfont (/ oldsty)
(if (null (tblsearch "style" "yb_lhbz"))
(progn
(setq oldsty (getvar "textstyle"))
(command "style" "yb_lhbz" "gbenor,gbcbig" "" "1" "" "" "")
(setvar "textstyle" oldsty)
)
)
(princ)
)
($ea_setfont)
;;检查当前字体，setvar 设置当前字体时出错
(defun $chk_curfont ()
(= (strcase (getvar "textstyle")) "YB_LHBZ")
)
;|;设置比例
(defun c:Ea_setScale (/ scl)
(setq scl
(getreal
(strcat
"\n出图比例<"
(vl-prin1-to-string (vlax-ldata-get "ea_sys_scale" "scale"))
">: "
)
)
)
(if (and (/= scl "") scl)
(vlax-ldata-put "ea_sys_scale" "scale" scl)
)
)|;
;;空字串（nil 或 "" " "）检查
(defun $ea:string_check (str)
(cond
((or (= str "") (= str nil)) nil)
(t
(not (equal '((0. 0. 0.) (0. 0. 0.))
(textbox (list (cons 1 str)))
)
)
)
)
)
;;去除名称中的数字
(defun $ea:chk_name (str / num)
(setq num (rtos (atof (ea:string_reverse str)) 2 0))
(vl-string-right-trim num str)
)
;;测量两字串的最大长度
(defun $ea_textlength (str)
(caadr
(textbox
(list (cons 40 (* 3.5 (vlax-ldata-get "ea_sys_scale" "scale")))
(cons 1
(if str
str
""
)
)
'(7 . "YB_LHBZ")
)
)
)
)
;;bz 名称|数量|说明|高度|冠幅|胸径;
;;control 名称|数量|说明|高度|冠幅|胸径|文件标志|绘线标志
(if (not (vlax-ldata-list "ea_lhbz"))
(mapcar '(lambda (x y) (vlax-ldata-put "ea_lhbz" x y))
'("bz" "control")
'("0|0|0|0|0|0" "1|1|1|1|1|1|0|1")
)
)
;;; 读取植物名称文件放入txt_tb中 frutex 灌木 arbor 乔木
(defun ea:do_init (tf / fname fp txt1 txt_tb)
(setq fname (findfile (if (= tf "0")
"frutex.txt"
"arbor.txt"
)
)
)
(setq fp (open fname "r"))
(setq txt_tb '())
(while (setq txt1 (read-line fp))
(setq txt_tb (cons txt1 txt_tb))
)
(close fp)
(reverse txt_tb)
)
;|
建立文件或对文件追加字串;
参数说明 tf T 追加 ;
nil 新建
str "0" 灌木词典;
"1" 乔木词典;
str1 字串或字串表，往文件追加的字串
|;
(defun ea:write_file (tf str str1 / f fp)
(setq f (if (= str "0")
"frutex.txt"
"arbor.txt"
)
)
(if tf
(setq f (findfile f))
)
(setq fp (open f "a"))
(if (= (type str1) 'STR)
(write-line str1 fp)
(mapcar '(lambda (x) (write-line x fp)) str1)
)
(close fp)
)
;;检查词典文件，没有－》自动生成
(if (not (findfile "frutex.txt"))
(ea:write_file
nil
"0"
'("杜鹃" "连翘" "洒金珊瑚" "金叶女贞"
"红花继木" "茶梅" "月季" "云南黄馨"
"栀子" "龟背冬青" "金丝桃" "贴梗海棠"
"六月雪" "小叶黄杨" "八角金盘" "小腊"
"龙柏" "金边绣线菊" "南天竹"
)
)
)
(if (not (findfile "arbor.txt"))
(ea:write_file
nil
"1"
'("无患子" "雪松" "日本柳杉" "香樟" "日本早樱" "广玉兰"
"桂花" "杜英" "银杏" "合欢" "马褂木" "水杉"
"垂柳" "白玉兰" "深山含笑" "乐昌含笑" "榉树" "七叶树"
"油松" "黑松" "白皮松" "湿地松" "南洋杉" "侧柏"
"圆柏" "金钱松" "赤松" "池杉" "白兰花" "青冈轹"
"榕树" "女贞" "棕榈" "鹅掌秋" "国槐" "枫香"
"悬铃木" "青杨" "朴树" "旱柳" "乌桕" "白桦"
"枫杨" "楝树" "元宝枫" "三角枫" "樱花" "栾树"
"臭椿" "白蜡"
)
)
)
;;对实体增加字串类扩展数据
(defun ea:addxdata (obj str / TypeArray xType TypeValue Value)
(setq TypeArray (vlax-make-safearray vlax-vbInteger '(0 . 1)))
(setq
xType (vlax-safearray-fill TypeArray (list 1001 1000))
)
(setq TypeValue (vlax-make-safearray vlax-vbVariant '(0 . 1)))
(setq Value (vlax-safearray-fill
TypeValue
(list str str)
)
)
(vla-setXdata obj xType Value)
)
;;对话框设定
(defun ea:setlhbz (/ $do_default do_setvarriant
do_help9 _ealh_id do_seltype
do_what txt_tb $chk_display
)
(defun $chk_display ()
(mode_tile "nn" 1)
(if (not ($ea:string_check (get_tile "sm")))
(mode_tile "ss" 1)
(mode_tile "ss" 1)
)
(if (not ($ea:string_check (get_tile "num")))
(mode_tile "aa" 1)
(mode_tile "aa" 1)
)
(if (not ($ea:string_check (get_tile "hig")))
(mode_tile "hh" 1)
(mode_tile "hh" 1)
)
(if (not ($ea:string_check (get_tile "wih")))
(mode_tile "ww" 1)
(mode_tile "ww" 1)
)
(if (not ($ea:string_check (get_tile "ro")))
(mode_tile "rr" 1)
(mode_tile "rr" 1)
)
)
;;对话框默认值
(defun $do_default (/ _$tr _$ctr name num sm hig wih ro tf nn aa ss hh
ww rr fl plctr)
(setq _$tr (ea:string_parse (vlax-ldata-get "ea_lhbz" "bz") "|")
_$ctr (ea:string_parse (vlax-ldata-get "ea_lhbz" "control") "|")
)
(setq name ($ea:chk_name (car _$tr))
num (cadr _$tr)
sm (nth 2 _$tr)
hig (nth 3 _$tr)
wih (nth 4 _$tr)
ro (last _$tr)
nn (car _$ctr)
aa (cadr _$ctr)
ss (nth 2 _$ctr)
hh (nth 3 _$ctr)
ww (nth 4 _$ctr)
rr (nth 5 _$ctr)
fl (nth 6 _$ctr) ;乔灌木记录 "0" 灌木 "1" 乔木
plctr (last _$ctr) ;"0" 绘引线 "1" 不绘
)
(start_list "what") ;将词组显示到列表框内
(mapcar 'add_list (ea:do_init fl))
(end_list)
(set_tile (if (= fl "0")
"fs"
"as"
)
"1"
)
;;可变标签
(if (= fl "1")
(progn
(set_tile "num_label" "")
(set_tile "num_label" "株数")
(set_tile "wih_label" "")
(set_tile "wih_label" "地径")
)
(progn
(set_tile "num_label" "")
(set_tile "num_label" "面积")
(set_tile "wih_label" "")
(set_tile "wih_label" "胸径")
)
)
(mapcar '(lambda (x y)
(if (/= y "0")
(set_tile x y)
)
)
'("name" "num" "sm" "hig" "wih" "ro")
_$tr
)
(mapcar '(lambda (x y) (set_tile x y))
'("nn" "aa" "ss" "hh" "ww" "rr" "pl")
(list nn aa ss hh ww rr plctr)
)
;(mode_tile "nn" 0)
;($chk_display)
(setq txt_tb (ea:do_init fl))
)
;;设定
(defun do_setvarriant (str / va tile _$tr _$ctr string mark)
(cond ((= str 0) (setq tile "name"))
((= str 1) (setq tile "num") (setq mark "aa"))
((= str 2) (setq tile "sm") (setq mark "ss"))
((= str 3) (setq tile "hig") (setq mark "hh"))
((= str 4) (setq tile "wih") (setq mark "ww"))
((= str 5) (setq tile "ro") (setq mark "rr"))
((= str 6) (setq tile "nn"))
((= str 7) (setq tile "aa"))
((= str 8) (setq tile "ss"))
((= str 9) (setq tile "hh"))
((= str 10) (setq tile "ww"))
((= str 11) (setq tile "rr"))
((= str 13) (setq tile "pl"))
;;((= str 13) (setq tile "pl"))
)
(setq va (get_tile tile))
;(if (< str 6) (set_tile mark "1"))
;($chk_display)
(setq _$tr (ea:string_parse (vlax-ldata-get "ea_lhbz" "bz") "|"))
(if (> str 5)
(setq
_$tr (ea:string_parse
(vlax-ldata-get "ea_lhbz" "control")
"|"
)
)
)
(setq string (ea:string_unparse
(ea:subst-n
(if (<= str 5)
str
(- str 6)
)
(if ($ea:string_check $value)
$value
"0"
)
_$tr
)
"|"
)
)
(vlax-ldata-put
"ea_lhbz"
(if (< str 6)
"bz"
"control"
)
string
)
)
(defun do_seltype (tf / _$ctr fl)
(setq
_$ctr (ea:string_parse (vlax-ldata-get "ea_lhbz" "control") "|")
)
(setq fl (nth 6 _$ctr)) ;乔灌木记录 "0" 灌木 "1" 乔木
(setq txt_tb (ea:do_init tf))
(start_list "what") ;将词组显示到列表框内
(mapcar 'add_list txt_tb)
(end_list)
;;改变标签
(if (= tf "0")
(progn
(set_tile "num_label" "")
(set_tile "num_label" "面积")
(set_tile "wih_label" "")
(set_tile "wih_label" "胸径")
)
(progn
(set_tile "num_label" "")
(set_tile "num_label" "株数")
(set_tile "wih_label" "")
(set_tile "wih_label" "地径")
)
)
(set_tile "name" "")
;($chk_display)
(vlax-ldata-put
"ea_lhbz"
"control"
(ea:string_unparse
(ea:subst-n 6 tf _$ctr)
"|"
)
)
)
(defun do_what (/ txt _$tr i)
(setq _$tr (ea:string_parse (vlax-ldata-get "ea_lhbz" "bz") "|"))
(setq i (atoi $value)) ;选中词组
(setq txt (nth i txt_tb))
(set_tile "name" txt)
;($chk_display)
(vlax-ldata-put
"ea_lhbz"
"bz"
(ea:string_unparse
(ea:subst-n 0 txt _$tr)
"|"
)
)
)
(defun do_help9 ()
(alert
"\n绿化标注 作者：Eachy
\n=======================================
\n 1 名 称 植物名称
\n 2 数 量 植物的株数或面积，数字或数字加 m
\n 3 说 明 植物造型说明
\n 4 高 度 植物高度，文字、数字或连字符数字"
)
)
;; 主程序开始
(if (not _ealh_id)
(setq _ealh_id (load_dialog "ea_lhbz.dcl"))
)
(if (not (new_dialog "ea_lhbz" _ealh_id))
(exit)
)
($do_default)
(action_tile "accept" "(done_dialog 1)")
(action_tile "what" "(do_what)")
(action_tile "name" "(do_setvarriant 0)")
(action_tile "num" "(do_setvarriant 1)")
(action_tile "sm" "(do_setvarriant 2)")
(action_tile "hig" "(do_setvarriant 3)")
(action_tile "wih" "(do_setvarriant 4)")
(action_tile "ro" "(do_setvarriant 5)")
(action_tile "nn" "(do_setvarriant 6)")
(action_tile "aa" "(do_setvarriant 7)")
(action_tile "ss" "(do_setvarriant 8)")
(action_tile "hh" "(do_setvarriant 9)")
(action_tile "ww" "(do_setvarriant 10)")
(action_tile "rr" "(do_setvarriant 11)")
(action_tile "pl" "(do_setvarriant 13)")
(action_tile "fs" "(do_seltype \"0\")") ;灌木
(action_tile "as" "(do_seltype \"1\")") ;乔木
(action_tile "help" "(do_help9)")
(start_dialog)
(unload_dialog _ealh_id)
(princ)
)
;;创建标注块
(defun ea:lhblk_make (p2 ang / blkang por _$tr _$ctr
name sm wih hig num ro nn aa
ss hh rr ww pn ps ph pw
len p3 blkdef blkref str1 str2
len c plctr pr
)
(if (or (<= ang (/ pi 2))
(> ang (* 1.5 pi))
)
(setq blkang 0.)
(setq blkang pi)
)
(setq $yb_global_scale (* (car (ea:init)) (cadr (ea:init))));vlax-ldata-get "ea_sys_scale" "scale"))
(setq por '(0. 0. 0.))
(setq _$tr (ea:string_parse (vlax-ldata-get "ea_lhbz" "bz") "|")
_$ctr (ea:string_parse (vlax-ldata-get "ea_lhbz" "control") "|")
)
(setq name (car _$tr)
num (cadr _$tr)
sm (nth 2 _$tr)
hig (nth 3 _$tr)
ro (nth 4 _$tr)
wih (last _$tr)
nn (car _$ctr)
aa (cadr _$ctr)
ss (nth 2 _$ctr)
hh (nth 3 _$ctr)
rr (nth 4 _$ctr)
ww (nth 5 _$ctr)
plctr (last _$ctr) ;"0" 绘引线 "1" 不绘
)
(if (/= name "0")
(progn
(if (/= num "0")
(if (vl-string-search "M" (strcase num))
(setq num (strcat num "%%178"))
)
(setq num nil)
)
(if (/= hig "0")
(if (numberp (read hig))
(setq hig (strcat "H" hig))
)
(setq hig nil)
)
(if (/= wih "0")
(setq wih (strcat "W" wih))
(setq wih nil)
)
(if (/= ro "0")
(setq ro (strcat "%%C" ro))
(setq ro nil)
)
(if (= sm "0")
(setq sm nil)
)
(setq str1 (ea:string_unparse
(vl-remove nil
(list name
(if (= aa "0")
nil
num
)
(if (= ss "0")
nil
sm
)
)
)
","
)
str2 (vl-remove nil
(list (if (= hh "0")
nil
hig
)
(if (= ww "0")
nil
wih
)
(if (= rr "0")
nil
ro
)
)
)
)
(if str2
(setq str2 (ea:string_unparse str2 ","))
(setq str2 " ")
)
;;决定画线的长度
(setq len
(+
(apply
'max
(mapcar
'$ea_textlength
(list str1
str2
)
)
)
(* 1.5 $yb_global_scale)
)
)
(setq p3 (polar por blkang len))
(setq p3 (mapcar '(lambda (x) (EA:ZEROSMALLNUM x)) p3))
(setq pn (if (= blkang 0.0)
(list $yb_global_scale $yb_global_scale 0.)
(mapcar '+ p3 (list $yb_global_scale $yb_global_scale 0.))
)
ph (mapcar '+ pn (list 0. (- (* 4.5 $yb_global_scale)) 0.))
)
;;建立匿名块
(setq BLKDEF
(vla-add (vla-get-blocks
(vla-get-activedocument (vlax-get-acad-object))
)
(vlax-3d-point por)
;;要 '(0. 0. 0.)为原点
"*U"
)
)
;;是否画线
(if (= plctr "1")
(vla-addline
blkdef
(vlax-3d-point por)
(vlax-3d-point p3)
)
)
;;tag prompt cont 值为空时分解块文字消失
(mapcar '(lambda (x)
(vla-addattribute
blkdef
(* 3.5 $yb_global_scale)
acAttributeModePreset
x
(vlax-3d-point pn)
x
x
)
)
'("" "" "" "" "" "")
) ;植物属性
(setq blkref (vla-insertblock
(vla-get-modelspace
(vla-get-activedocument (vlax-get-acad-object))
)
(vlax-3d-point p2)
(vla-get-name BLKDEF)
(vlax-make-variant 1 vlax-vbdouble)
(vlax-make-variant 1 vlax-vbdouble)
(vlax-make-variant 1 vlax-vbdouble)
(vlax-make-variant
(ea:angle_format blkang)
vlax-vbdouble
)
)
) ;将块插入到模型空间
(setq c 1)
(setq pn (mapcar '+ pn p2) ;属性在图纸空间的插入点
pa (polar pn 0. ($ea_textlength name))
ps (if (and num (= aa "1"))
(polar
pa
0.
($ea_textlength
(strcat "," num)
)
)
pa
)
ph (mapcar '+ ph p2)
pw (if (and hig (= hh "1"))
(polar ph
0.
($ea_textlength hig)
)
ph
)
pr (polar
pw
0.
(if (= ww "1")
($ea_textlength
(strcat ","
(if wih
wih
""
)
)
)
0.
)
)
)
;;对插入的块赋予 tag 值，getattributes 得到的属性顺序与加入时的一致
(mapcar
'(lambda (x)
(cond
((= c 1)
(vla-put-tagstring x "名称")
(vla-put-textstring x name)
)
((= c 2)
(vla-put-tagstring x "数量")
(if num
(progn
(vla-put-textstring
x
(if (numberp num)
(strcat "," (rtos num 2 0))
(strcat "," num)
)
)
(vla-put-insertionpoint
x
(vlax-3d-point pa)
)
(if (= aa "0")
(vla-put-visible x :vlax-false) ;属性是否显示,下同
)
)
)
)
((= c 3)
(vla-put-tagstring x "说明")
(if sm
(progn
(vla-put-textstring x (strcat "," sm))
(vla-put-insertionpoint
x
(vlax-3d-point ps)
)
(if (= ss "0")
(vla-put-visible x :vlax-false)
)
)
)
)
((= c 4)
(vla-put-tagstring x "高度")
(if hig
(progn
(vla-put-textstring
x
hig
)
(vla-put-insertionpoint x (vlax-3d-point ph))
)
)
(if (= hh "0")
(vla-put-visible x :vlax-false)
)
)
((= c 5)
(vla-put-tagstring x "冠幅")
(if (and wih (= ww "1"))
(progn
(vla-put-textstring
x
(if (and hig (= hh "1"))
(strcat "," wih)
wih
)
)
(vla-put-insertionpoint
x
(vlax-3d-point pw)
)
(if (= ww "0")
(vla-put-visible x :vlax-false)
)
)
(setq pw ph)
)
)
((= c 6)
(vla-put-tagstring x "地径")
(if ro
(progn
(vla-put-textstring
x
(if (and (or hig wih) (or (= hh "1") (= ww "1")))
(strcat "," ro)
ro
)
)
(vla-put-insertionpoint
x
(vlax-3d-point pr)
)
(if (= rr "0")
(vla-put-visible x :vlax-false)
)
)
)
)
(t)
)
(setq c (1+ c))
)
(vlax-safearray->list
(vlax-variant-value (vla-getattributes blkref))
)
)
;;对块增加Xdata，方便选择处理
(ea:addxdata blkref "YB_LHBZ")
)
)
)
(defun c:Ea_lhbz (/ tf p0 p00 ang $fl_mark
$txt_tb _name _conlst $plctr HostAcad oldos
oldor oldsty xln
)
;;主程序
(ea:begin '("osmode" "orthomode"))
(setq oldsty ($chk_curfont))
(setvar "osmode" 0)
(setvar "orthomode" 1)
(if (not ($chk_curfont))
(progn
(setq oldsty (getvar "textstyle"))
(setvar "textstyle" "yb_lhbz")
)
)
(setq tf t)
(if (= (car (ea:string_parse (vlax-ldata-get "ea_lhbz" "bz") "|"))
"0"
)
(ea:setlhbz)
)
(while tf
(initget "S")
(if (setq p0 (getpoint "\n第一点[S - 设置]<退出>: "))
(cond
((= p0 "S")
(ea:setlhbz)
)
((= (type p0) 'LIST)
(progn
(setq _conlst (ea:string_parse
(vlax-ldata-get "ea_lhbz" "control")
"|"
)
)
(setq $fl_mark (nth 6 _conlst)
$plctr (last _conlst)
$txt_tb (ea:do_init $fl_mark)
)
(setq _name
($ea:chk_name
(car (ea:string_parse (vlax-ldata-get "ea_lhbz" "bz") "|")
)
)
)
(if (and (/= _name "0") (not (member _name $txt_tb)))
;;检查ldata中的名称是否在 $txt_tb ，没有->写入
(ea:write_file t $fl_mark _name)
)
(if (= $plctr "1")
(progn
(setq p00 (getpoint p0 "\n第二点: "))
(setvar "orthomode" 1)
(if (and (/= (angle p0 p00) 0.0)
(/= (angle p0 p00) pi)
)
(setq ang (getangle p00 "\n角 度: "))
(setq ang (angle p0 p00))
)
)
(setq p00 p0
ang 0.
)
)
(if (and p0 p00 ang)
(progn
(setq xln (vla-addline
(model-space)
(vlax-3d-point p0)
(vlax-3d-point p00)
)
)
(ea:addxdata xln "YB_LHBZ1")
;;引线加xdata
(ea:lhblk_make p00 ang)
)
)
)
)
(t (setq tf nil))
)
(setq tf nil)
)
)
(if (= (type oldsty) 'STR)
(setvar "textstyle" oldsty)
)
(ea:end)
(princ)
)
(defun c:Ea_Edlh (/ HostAcad tf e obj
pl name lst plctr txt_tb txtlst
elst conlst fl oldos oldor oldsty
ang
)
;;主程序
(ea:begin '("osmode" "orthomode"))
(setvar "orthomode" 0)
(if (not ($chk_curfont))
(progn
(setvar "textstyle" "yb_lhbz")
(setvar oldsty (getvar "textstyle"))
)
)
(setq tf t)
(while tf
(setq e (ea:entself "\n选择绿化标注: " '((-3 ("yb_lhbz")))))
(if e
(progn
(setq obj (vlax-ename->vla-object (car e))
pl (vla-item
(vla-item
(vla-get-blocks
(vla-get-activedocument (vlax-get-acad-object))
)
(vla-get-name obj)
)
0
)
)
(if (= (vla-get-objectname pl) "AcDbLine")
(progn
(setq plctr "1")
(setq ang (vla-get-angle pl))
)
(progn (setq plctr "0") (setq ang 0.0))
)
(setq lst (ea:getattributes obj)
name (caar lst)
txt_tb (ea:do_init "0")
fl (if (member name txt_tb)
"0"
"1"
)
elst (mapcar '(lambda (x) (last x)) lst)
txtlst (mapcar '(lambda (x / y)
(setq y (if (= (cadr x) "")
"0"
(cadr x)
)
)
(setq y (vl-string-left-trim "," y))
(setq y (vl-string-right-trim "%%178" y))
(setq y (vl-string-left-trim "H" y))
(setq y (vl-string-left-trim "W" y))
(setq y (vl-string-left-trim "%%C" y))
)
lst
)
conlst (mapcar '(lambda (x)
(cond
((= (vla-get-textstring
(vlax-ename->vla-object x)
)
""
)
"0"
)
((= (vla-get-visible
(vlax-ename->vla-object x)
)
:vlax-false
)
"0"
)
(t "1")
)
)
elst
)
)
(vlax-ldata-put
"ea_lhbz"
"control"
(strcat (ea:string_unparse conlst "|") "|" fl "|" plctr)
)
(vlax-ldata-put
"ea_lhbz"
"bz"
(ea:string_unparse txtlst "|")
)
(ea:setlhbz)
(ea:lhblk_make
(ea:lisp-value (vla-get-insertionpoint obj))
ang
)
(vla-delete obj)
)
(setq tf nil)
)
)
(if (= (type oldsty) 'STR)
(setvar "textstyle" oldsty)
)
(ea:end)
(princ)
)
(defun c:TXT_TJ (/ ss e string txtlst)
(setq e (ea:entself "\n点选统计文字:" '((0 . "text"))))
(if e
(progn
(princ "\n拾取选择范围[ALL - 全选]...")
(setq ss (ssget (list '(0 . "text") (assoc 8 (entget (car e))))))
(foreach e (ea:ssgettoentitylist ss)
(setq string (ea:dxf e 1))
(if txtlst
(progn
(if (assoc string txtlst)
(setq
txtlst (subst
(append (list string) (assoc string txtlst))
(assoc string txtlst)
txtlst
)
)
(setq txtlst (append (list (list string)) txtlst))
)
)
(setq txtlst (list (list string)))
)
)
(mapcar '(lambda (x)
(princ (strcat (car x) " " (itoa (length x)) " | "))
)
txtlst
)
)
)
(princ)
)
;;定义苗木表表头及表格, 块定义以 '(0 0 0) 为基点定义
(defun ea:mk_title (/ BLKDEF_title pl BLKDEF_Cel c )
(if (not (tblsearch "block" "Yb_LH_Title"))
(progn
(setq BLKDEF_title
(vla-add (vla-get-blocks
(vla-get-activedocument (vlax-get-acad-object))
)
(vlax-3d-point '(0. 0. 0.))
"Yb_LH_Title"
)
)
(setq pl (vla-AddLightweightPolyline
BLKDEF_title
(list->VariantArray
'(0. 0. 14.2 0. 14.2 1.2 0. 1.2)
vlax-vbDouble
)
)
)
(vla-put-closed pl :vlax-true)
(mapcar '(lambda (x y / txt)
(setq txt (vla-AddText
BLKDEF_title
x
(vlax-3d-point y)
0.4
)
)
(vla-put-alignment txt acAlignmentMiddleCenter)
(vla-put-TextAlignmentPoint txt (vlax-3d-point y))
)
'("序号" "名 称" "备 注")
'((0.5 0.6 0.) (2.2 0.6 0.) (12.6 0.6 0.))
)
(mapcar '(lambda (x y / txt)
(setq txt (vla-AddText
BLKDEF_title
x
(vlax-3d-point y)
0.36
)
)
(vla-put-alignment txt acAlignmentMiddleCenter)
(vla-put-TextAlignmentPoint txt (vlax-3d-point y))
)
'("规 格" "高度(M)" "冠幅(M)")
'((6.1 0.9 0.) (4.3 0.3 0.) (7.9 0.3 0.))
)
(mapcar '(lambda (pt / txt)
(setq txt (vla-addattribute
BLKDEF_title
0.38
acAttributeModePreset
""
(vlax-3d-point pt)
""
""
)
)
(vla-put-alignment txt acAlignmentMiddleCenter)
(vla-put-TextAlignmentPoint txt (vlax-3d-point pt))
;|(if tf
(progn
(vla-put-tagstring txt "数量")
(vla-put-textstring txt "数量(株)")
)
(progn
(vla-put-tagstring txt "面积")
(vla-put-textstring txt "面积(m%%178)")
)
)|;
)
'((9.9 0.6 0.)
(6.1 0.3 0.)
)
)
(mapcar '(lambda (x)
(vla-addline
BLKDEF_title
(vlax-3d-point (car x))
(vlax-3d-point (cadr x))
)
)
'(((1. 0. 0.) (1. 1.2 0.))
((3.4 0. 0.) (3.4 1.2 0.))
((8.8 0. 0.) (8.8 1.2 0.))
((11. 0. 0.) (11. 1.2 0.))
((5.2 0. 0.) (5.2 0.6 0.))
((7. 0. 0.) (7. 0.6 0.))
((3.4 0.6 0.) (8.8 0.6 0.))
)
)
)
)
(if (not (tblsearch "block" "Yb_LH_Cel"))
(progn
(setq BLKDEF_Cel
(vla-add (vla-get-blocks
(vla-get-activedocument (vlax-get-acad-object))
)
(vlax-3d-point '(0. 0. 0.))
"Yb_LH_Cel"
)
)
(mapcar '(lambda (x)
(vla-addline
BLKDEF_Cel
(vlax-3d-point (car x))
(vlax-3d-point (cadr x))
)
)
'(((1. 0. 0.) (1. -0.8 0.))
((3.4 0. 0.) (3.4 -0.8 0.))
((5.2 0. 0.) (5.2 -0.8 0.))
((7. 0. 0.) (7. -0.8 0.))
((8.8 0. 0.) (8.8 -0.8 0.))
((11. 0. 0.) (11. -0.8 0.))
((14.2 0. 0.) (14.2 -0.8 0.))
((1. -0.8 0.) (14.2 -0.8 0.))
)
)
(setq c 1)
(mapcar '(lambda (x pt / txt)
(setq txt (vla-addattribute
BLKDEF_Cel
0.38
acAttributeModePreset
""
(vlax-3d-point pt)
x
""
)
)
(vla-put-alignment
txt
(if (= c 1)
acAlignmentMiddleLeft
acAlignmentMiddleCenter
)
)
(vla-put-TextAlignmentPoint txt (vlax-3d-point pt))
(setq c (1+ c))
)
'("名称" "高度" "胸径" "冠幅" "数量")
'((1.25 -0.4 0.)
(4.3 -0.4 0.)
(6.1 -0.4 0.)
(7.9 -0.4 0.)
(9.9 -0.4 0.)
)
)
)
)
(princ)
)
(defun c:Ea_MKTitle (/ txt pt pcen ptxt)
(ea:begin '("osmode" "textstyle"))
(setvar "osmode" 0)
(setq pt (getpoint "\n输出点: "))
(if pt
(progn
(setvar "textstyle" "yb_lhbz")
(setq pcen (getvar "viewctr")
$yb_global_scale (vlax-ldata-get
"ea_sys_scale"
"scale"
)
)
(ea:mk_title)
(mapcar
'(lambda (x)
(vla-insertblock
(vla-get-modelspace
(vla-get-activedocument (vlax-get-acad-object))
)
(vlax-3d-point pt) ;insertpoint
x ;block name
(vlax-make-variant (* 10 $yb_global_scale) vlax-vbdouble)
;x 比例
(vlax-make-variant (* 10 $yb_global_scale) vlax-vbdouble)
;Y
(vlax-make-variant (* 10 $yb_global_scale) vlax-vbdouble)
;Z
(vlax-make-variant 0 vlax-vbdouble) ; rotation
)
)
'("Yb_LH_Title" "Yb_LH_Cel")
)
(setq ptxt (mapcar '+
(list (* 71 $yb_global_scale)
(* 16 $yb_global_scale)
0.
)
pt
)
)
(setq txt (vla-AddText
(model-space)
"苗木统计一览表"
(vlax-3d-point ptxt)
(* 7 (vlax-ldata-get "ea_sys_scale" "scale"))
)
)
(vla-put-alignment txt acAlignmentCenter)
(vla-put-TextAlignmentPoint txt (vlax-3d-point ptxt))
(vla-addline
(model-space)
(vlax-3d-point pt)
(vlax-3d-point
(polar pt (- (/ pi 2)) (* 8 $yb_global_scale))
)
)
;|(vla-zoomcenter
(vla-get-Application
(vla-get-activedocument (vlax-get-acad-object))
)
(vlax-3d-point (getvar "viewctr"))
(vlax-make-variant (* 300 $yb_global_scale) vlax-vbdouble)
)|;
)
)
(ea:end)
(princ)
)
(defun c:ea_EraLh (/ ss)
(princ "\n选择范围[All - 全选].....")
(setq ss (ssget '((-3 ("YB_LHBZ*")))))
(if ss
(vl-cmdf ".erase" ss "")
)
(princ)
)
(defun c:ea_lhtj (/ ss ssobj lst l1 l2 ll1 ln $yb_global_scale)
(ea:begin '("osmode" "celayer"))
(setvar "osmode" 0)
(setq ss (ssget '((-3 ("yb_lhbz")))))
(setq $yb_global_scale (vlax-ldata-get "ea_sys_scale" "scale"))
(if ss
(progn
(setq pt (getpoint "\n表格输出点: "))
(setq ssobj (ea:selectionsetToArray ss))
(setq lst (mapcar
'(lambda (x)
(mapcar '(lambda (a) (vl-string-trim "," a))
(reverse (cdr (reverse (ea:GetAttributes x))))
)
)
(vlax-safearray->list ssobj)
)
l1 nil
)
;;按名称分类
(foreach ll lst
(setq ln (cadar ll)
l2 l1
)
(while (and (setq ll1 (car l2))
(not (equal ln (cadar ll1)))
)
(setq l2 (cdr l2))
)
(setq l1 (if ll1
(subst (append ll1 (list ll)) ll1 l1)
(cons (list ln ll) l1)
)
)
)
)
)
(ea:end)
(princ)
)[/pcode]
配套DCL文件 | 
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
|申请友链|Archiver|手机版|小黑屋|辽公网安备|晓东CAD家园
( 辽ICP备15016793号 )
窥视卡
雷达卡
已领礼包: 
财富等级: 
发表于 2013-5-27 11:31:52
提升卡
置顶卡
沉默卡
变色卡
千斤顶
发表于 2013-5-27 12:11:21
