求教：程序合并

香田里浪人 · 发表于 2015-6-9 08:31

本帖最后由香田里浪人于 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 改顏色/2 改层名]<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)
)

Real_King · 发表于 2015-6-9 08:50

LISP好难读，如果是VBA或者C#还能帮帮你，不过论坛里LISP高手济济，马上有人会帮到你的

edata · 发表于 2015-6-9 12:04

未验证。。

;;;面积计算统计到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 改顏色/2 改层名]<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)
)

;;;面积计算统计到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 改顏色/2 改层名]<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) 
)

香田里浪人 · 发表于 2015-6-9 15:40

edata 发表于 2015-6-9 12:04
未验证。。

谢谢！好像不行，面积及其统计无法在图中显示

edata · 发表于 2015-6-9 16:11

你原来能用这个程序，你就能用，你原来不能用这两个程序，就不能用。因为合并并没有改变这两个程序。
检查你的字体有没有，另外测试了下，这面积单位貌似不正确。
图层改名你能不能用，不能用，合并也不能用，因为这需要另外的函数支持，貌似是晓东的API。

香田里浪人 · 发表于 2015-6-10 08:31

edata 发表于 2015-6-9 16:11
你原来能用这个程序，你就能用，你原来不能用这两个程序，就不能用。因为合并并没有改变这两个程序。
检查 ...

再次感谢，问题找出来了，原来是字体问题，修改字体就可以用

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

[已解答] 求教：程序合并

评分