求教：程序合并
本帖最后由 香田里浪人 于 2015-6-9 08:45 编辑今有2个程序，分别是面积计算统计到Excel及图层改名颜色，我想实现一次选择既可计算面积并统计也可图层改名（不用二次选择），不知如何修改合并，请高手抽空帮忙，谢谢！
;;;面积计算统计到Excel。根据lisheng的程序，略作修改。
(defun c:mjztj(/ OBJLLPOINT OBJRUPOINT TEXTHEIGHT TEXTINDEX f ss e i obj l tarea)
(vl-load-com)
(command "layer" "M" "面积" "C" "6" "" "LT" "CONTINUOUS" "" "");设置一个面积标注图层
(command "layer" "M" "面积统计" "C" "4" "" "LT" "CONTINUOUS" "" "");设置一个面积统计图层
(setvar"dimzin"0);;保留小数位数时如果位数不足可以补零
(setq TextHeight (getdist "\n输入标注文字高度:(默认1)")
Textbh(getstring "\n输入编号前缀:")
f(getfiled "指定输出文件路径" "" "xls" 1));;;指定输出文件路径，
(if (= TextHeight nil) (setq TextHeight 1))
(if f(progn
(setq f(open f "a")i 0 TextIndex 1 tarea 0
ss (ssget '((0 . "CIRCLE,LWPOLYLINE,ELLIPSE"))))
(write-line "编号\t面积(㎡)" f)
(repeat(SSlength ss)
(setq e(ssname ss i)i(1+ i)
Obj(vlax-ename->vla-object e))
(vla-GetBoundingBox Obj 'ObjLlPoint 'ObjRuPoint)
(setq l(cons(list(mapcar'(lambda(x y)(/ (+ x y)2))(vlax-safearray->list ObjLlPoint)(vlax-safearray->list ObjRuPoint))
(vla-get-Area(vlax-ename->vla-object e)))l)))
(foreach x(vl-sort l'(lambda(x y)(<(last x)(last y))))
(write-line(setq txt(strcat Textbh(itoa TextIndex)"\t"(setq area(rtos(last x)2 2))))f)
(entmake(list'(0 . "TEXT")'(8 . "面积")'(62 . 6)'(41 . 0.7)(cons 10 (car x))(cons 1 (STRCAT(vl-string-subst"=""\t"txt)"㎡"))
(CONS 40 TextHeight)'(7 . "tukou")(cons 11 (car x))'(72 . 1)));设置一个面积标注文字颜色品红，宽高比0.7，可根据需要自行修改
(setq tarea(+(atof area)tarea)
TextIndex(1+ TextIndex)))
(close f)
(entmake(list'(0 . "TEXT")'(8 . "面积统计")'(62 . 4)'(41 . 0.7)(cons 10 (setq e(getpoint"\n请输入文字插入点: ")));设置一个面积统计文字颜色青色，宽高比0.7，可根据需要自行修改
(cons 1(strcat Textbh"="Textbh"1+"Textbh"2+...+"Textbh (itoa i)"="(rtos tarea 2 2)"㎡"))
(CONS 40 TextHeight)'(7 . "tukou")(cons 11 e)'(72 . 1)))
)
(alert"没有选择文件"))
(princ)
)
;;将图中实体图层改名变色
(defun #chg_color (e cnum0 cnum / tf e blkna)
(xdrx_setenttodb e)
(setq tf (xdrx_getentdxf 0))
(cond
((or
(= tf "INSERT")
(= tf "DIMENSION")
)
(setq blkna (xdrx_getentdxf 2))
(setq blkna (tblsearch "block" blkna))
(setq e (cdr (assoc -2 blkna)))
(while e
(xdrx_setenttodb e)
(setq tf (xdrx_getentdxf 0))
(if (or
(= tf "INSERT")
(= tf "DIMENSION")
)
(progn
(#chg_color e cnum0 cnum)
)
(progn
(xdrx_setenttodb e)
(xdrx_modent cnum0 cnum)
)
)
(setq e (entnext e))
)
)
(t
(xdrx_modent cnum0 cnum)
)
)
)
(defun c:tcgm (/ ss key num num0 n e)
(xdrx_begin)
(prompt "\n请选取要变色的实体<全选>:")
(if (not (setq ss (ssget)))
(setq ss (ssget "x"))
)
(initget "1 2")
(setq key (getstring "\n<1>: "))
(if (or (= key "1")
(= key "")
)
(progn
(setq num (acad_colordlg 7))
(setq num0 62)
)
(progn
(setq num (getstring "\n图层名称: "))
(setq num0 8)
)
)
(setq n 0)
(xdrx_setsstodb ss 0)
(xdrx_pbarbegin "已经完成:" (sslength ss))
(while (setq e (xdrx_getentdata 0))
(xdrx_pbarsetpos n)
(setq n (1+ n))
(#chg_color e num0 num)
(entupd e)
)
(xdrx_pbarend)
(setvar "osmode" 4261)
(xdrx_end)
(princ)
) LISP好难读，如果是VBA或者C#还能帮帮你，不过论坛里LISP高手济济，马上有人会帮到你的 未验证。。
;;;面积计算统计到Excel。根据lisheng的程序，略作修改。
(defun c:mjztj(/ OBJLLPOINT OBJRUPOINT TEXTHEIGHT TEXTINDEX f ss e i obj l tarea)
(vl-load-com)
(command "layer" "M" "面积" "C" "6" "" "LT" "CONTINUOUS" "" "");设置一个面积标注图层
(command "layer" "M" "面积统计" "C" "4" "" "LT" "CONTINUOUS" "" "");设置一个面积统计图层
(setvar"dimzin"0);;保留小数位数时如果位数不足可以补零
(setq TextHeight (getdist "\n输入标注文字高度:(默认1)")
Textbh(getstring "\n输入编号前缀:")
f(getfiled "指定输出文件路径" "" "xls" 1));;;指定输出文件路径，
(if (= TextHeight nil) (setq TextHeight 1))
(if f(progn
(setq f(open f "a")i 0 TextIndex 1 tarea 0
ss (ssget '((0 . "CIRCLE,LWPOLYLINE,ELLIPSE"))))
(write-line "编号\t面积(㎡)" f)
(repeat(SSlength ss)
(setq e(ssname ss i)i(1+ i)
Obj(vlax-ename->vla-object e))
(vla-GetBoundingBox Obj 'ObjLlPoint 'ObjRuPoint)
(setq l(cons(list(mapcar'(lambda(x y)(/ (+ x y)2))(vlax-safearray->list ObjLlPoint)(vlax-safearray->list ObjRuPoint))
(vla-get-Area(vlax-ename->vla-object e)))l)))
(foreach x(vl-sort l'(lambda(x y)(<(last x)(last y))))
(write-line(setq txt(strcat Textbh(itoa TextIndex)"\t"(setq area(rtos(last x)2 2))))f)
(entmake(list'(0 . "TEXT")'(8 . "面积")'(62 . 6)'(41 . 0.7)(cons 10 (car x))(cons 1 (STRCAT(vl-string-subst"=""\t"txt)"㎡"))
(CONS 40 TextHeight)'(7 . "tukou")(cons 11 (car x))'(72 . 1)));设置一个面积标注文字颜色品红，宽高比0.7，可根据需要自行修改
(setq tarea(+(atof area)tarea)
TextIndex(1+ TextIndex)))
(close f)
(entmake(list'(0 . "TEXT")'(8 . "面积统计")'(62 . 4)'(41 . 0.7)(cons 10 (setq e(getpoint"\n请输入文字插入点: ")));设置一个面积统计文字颜色青色，宽高比0.7，可根据需要自行修改
(cons 1(strcat Textbh"="Textbh"1+"Textbh"2+...+"Textbh (itoa i)"="(rtos tarea 2 2)"㎡"))
(CONS 40 TextHeight)'(7 . "tukou")(cons 11 e)'(72 . 1)))
(initget 1 "Yes No")
(setq keyword (getkword "是否确定[是(Y)/否(N)]： "))
(if (and keyword (= keyword "Yes"))
(if (and ss (> (sslength ss) 0))(xdrx_tcgm ss))
)
)
(alert"没有选择文件"))
(princ)
)
;;将图中实体图层改名变色
(defun #chg_color (e cnum0 cnum / tf e blkna)
(xdrx_setenttodb e)
(setq tf (xdrx_getentdxf 0))
(cond
((or
(= tf "INSERT")
(= tf "DIMENSION")
)
(setq blkna (xdrx_getentdxf 2))
(setq blkna (tblsearch "block" blkna))
(setq e (cdr (assoc -2 blkna)))
(while e
(xdrx_setenttodb e)
(setq tf (xdrx_getentdxf 0))
(if (or
(= tf "INSERT")
(= tf "DIMENSION")
)
(progn
(#chg_color e cnum0 cnum)
)
(progn
(xdrx_setenttodb e)
(xdrx_modent cnum0 cnum)
)
)
(setq e (entnext e))
)
)
(t
(xdrx_modent cnum0 cnum)
)
)
)
(defun xdrx_tcgm (ss /key num num0 n e)
(xdrx_begin)
;(prompt "\n请选取要变色的实体<全选>:")
(if (not ss)
(setq ss (ssget "x"))
)
(initget "1 2")
(setq key (getstring "\n<1>: "))
(if (or (= key "1")
(= key "")
)
(progn
(setq num (acad_colordlg 7))
(setq num0 62)
)
(progn
(setq num (getstring "\n图层名称: "))
(setq num0 8)
)
)
(setq n 0)
(xdrx_setsstodb ss 0)
(xdrx_pbarbegin "已经完成:" (sslength ss))
(while (setq e (xdrx_getentdata 0))
(xdrx_pbarsetpos n)
(setq n (1+ n))
(#chg_color e num0 num)
(entupd e)
)
(xdrx_pbarend)
(setvar "osmode" 4261)
(xdrx_end)
(princ)
) edata 发表于 2015-6-9 12:04 static/image/common/back.gif
未验证。。
谢谢！好像不行，面积及其统计无法在图中显示 你原来能用这个程序，你就能用，你原来不能用这两个程序，就不能用。因为合并并没有改变这两个程序。
检查你的字体有没有，另外测试了下，这面积单位貌似不正确。
图层改名你能不能用，不能用，合并也不能用，因为这需要另外的函数支持，貌似是晓东的API。 edata 发表于 2015-6-9 16:11 static/image/common/back.gif
你原来能用这个程序，你就能用，你原来不能用这两个程序，就不能用。因为合并并没有改变这两个程序。
检查 ...
再次感谢，问题找出来了，原来是字体问题，修改字体就可以用
页:
[1]