统计线长之前,须先乱弹琴
本帖最后由 自贡黄明儒 于 2013-8-27 10:13 编辑http://bbs.mjtd.com/thread-107329-1-1.html
1 “统计线长”的改良版
2 问：这是“统计线长”工具吗？是的，同时是一把小钢琴
3 创意来自：不死猫nonsmall的咔嚓声
4 提示：开音响哟
1 加载后输入命令：Lens
2 击0 1 2 3 4 5 6 7，乱弹琴(本人不懂音乐，弹不出<命令交响曲>,请谅解)
3 击"确定"后，开始工作
(defun C:Lens (/ COLOR EN FIL LAYLIS LEN LINETYPE NAME OSM1 RA0 RA1 RA2 RA3 RA4 RA5 RA6 RA7 RETURN# SS0 wmp)
;;0 错误处理
(defun *error* (S)
(vl-bt)
;;结束编组;(if (= 8 (logand (getvar "undoctl") 8)) (command "_.undo" "_e"))
(endundo)
;;结束命令
(while (not (equal (getvar "cmdnames") "")) (command nil))
(if osm1 (setvar "osmode" osm1))
(if wmp (vlax-release-object wmp))
(princ "\n 出错啦!")
)
;;1.1 获取颜色
(defun getcolor (/ COLOR EN ENTLIST LAYER)
(while (not en) (setq en (car (entsel "\n 拾取颜色"))))
(setq entlist (entget en))
(if (setq color (cdr (assoc 62 entlist)))
nil
(progn
(setq layer (cdr (assoc 8 entlist)))
(setq color (cdr (assoc 62 (tblsearch "layer" layer))))
)
)
(list en color)
)
;;1.2 指定颜色的随层随块层名
(defun ColorLayers (color / D LAYER LAYLIS)
(while (setq d (tblnext "LAYER" (null d)))
(setq layer (cdr (assoc 2 d)))
(if (equal (cdr (assoc 62 d)) color)
(setq layLis (if layLis
(strcat layLis "," layer)
layer
)
)
)
)
LAYLIS
)
;;2 取得层名
(defun getLayer ()
(list (assoc 8 (entget (car (entsel "\n 拾取层名")))))
)
;;3.1 获取线型
;;EN LINETYPE
(defun getLineType (/ ENTLIST LAYER)
(while (not en) (setq en (car (entsel "\n 拾取线型"))))
(setq entlist (entget en))
(if (setq LineType (cdr (assoc 6 entlist)))
nil
(progn
(setq layer (cdr (assoc 8 entlist)))
(setq LineType (cdr (assoc 6 (tblsearch "layer" layer))))
)
)
)
;;3.2 指定线型的随层随块层名
;; LAYLIS
(defun TypeLayers (LineType / D LAYER)
(while (setq d (tblnext "LAYER" (null d)))
(setq layer (cdr (assoc 2 d)))
(if (equal (cdr (assoc 6 d)) LineType)
(setq layLis (if layLis
(strcat layLis "," layer)
layer
)
)
)
)
)
;;4 一统+ strcat
;;在处理输入时，可能有些用处 自贡黄明儒 2013年8月20日
;;(++ '("a" 5));"a5"
(defun ++ (lis / SYMBOL X)
(if (vl-every 'numberp lis)
(apply '+ lis)
(apply 'strcat (mapcar 'vl-princ-to-string lis))
)
)
;;5.1 圆整线宽
(defun Iwidth (len0)
(cond ((< len0 5) (setq len 5))
((< len0 9) (setq len 9))
((< len0 13) (setq len 13))
((< len0 15) (setq len 15))
((< len0 18) (setq len 18))
((< len0 20) (setq len 20))
((< len0 25) (setq len 25))
((< len0 30) (setq len 30))
((< len0 35) (setq len 35))
((< len0 40) (setq len 40))
((< len0 50) (setq len 50))
((< len0 53) (setq len 53))
((< len0 60) (setq len 60))
((< len0 70) (setq len 70))
((< len0 80) (setq len 80))
((< len0 90) (setq len 90))
((< len0 100) (setq len 100))
((< len0 106) (setq len 106))
((< len0 120) (setq len 120))
((< len0 140) (setq len 140))
((< len0 158) (setq len 158))
((< len0 200) (setq len 200))
(t (setq len 211))
)
)
;;5.2 预设线宽
;; len
(defun PreWidth (en / ENTLIST LEN1 OBJ)
;;(setq en (car (entsel)))
(setq entlist (entget en))
(setq len (vlax-curve-getDistAtParam en (vlax-curve-getEndParam en)))
(setq len (/ len 20))
(Iwidth len) ;圆整后len
(setq obj (vlax-ename->vla-object en))
(vla-put-Lineweight obj len)
(princ (++ (list "\n 当前线宽是 " len)))
(initget (++ (list 2 4))) ;没必要也用一下
(if (setq len1 (getreal (++ (list "\n 输入线宽<" len ">"))))
(progn (Iwidth len1)
(vla-put-Lineweight obj len)
)
)
(princ (++ (list "\n 当前线宽圆整后是 " len)))
)
;;5.3 处理选择集内对象
(defun HHproSS (ss len / EN N)
(repeat (setq n (sslength ss))
(setq en (ssname ss (setq n (1- n))))
(setq en (vlax-ename->vla-object en))
(vlax-put en 'lineweight len)
)
)
;;6.1 对话框
(defun MyPlanDCL (/ DCLID FN FNAME LIN return#)
(setq fname (vl-filename-mktemp nil nil ".dcl"))
(setq fn (open fname "w"))
(write-line "MyPlanDialog : dialog{" fn)
(write-line "label=\"自贡运机集团黄明儒 命令:Lens\";" fn)
(write-line " :row{" fn)
(write-line ":column{" fn)
(write-line ":boxed_radio_column{label=\"选择\";" fn)
(write-line " initial_focus=\"ra1\";" fn)
(write-line
" :radio_button{label=\"按图层(&0)\";key=\"ra0\";mnemonic=\"0\";}"
fn
)
(write-line
" :radio_button{label=\"按颜色(&1)\";key=\"ra1\";mnemonic=\"1\";value=\"1\";}"
fn
)
(write-line
" :radio_button{label=\"按线型(&2)\";key=\"ra2\";mnemonic=\"2\";} "
fn
)
(write-line " }" fn)
(write-line " :boxed_radio_column{label=\"范围\";" fn)
(write-line " initial_focus=\"ra3\";" fn)
(write-line
" :radio_button{label=\"手选(&3)\";key=\"ra3\";mnemonic=\"3\";value=\"1\";}"
fn
)
(write-line
" :radio_button{label=\"全选(&4)\";key=\"ra4\";mnemonic=\"4\";} "
fn
)
(write-line " }" fn)
(write-line " }//column" fn)
(write-line ":column{" fn)
(write-line ":boxed_radio_column{label=\"功能\";" fn)
(write-line " initial_focus=\"ra5\";" fn)
(write-line
" :radio_button{label=\"统计线长(&5)\";key=\"ra5\";mnemonic=\"5\";value=\"1\";}"
fn
)
(write-line
" :radio_button{label=\"线宽显示(&6)\";key=\"ra6\";mnemonic=\"6\";}"
fn
)
(write-line
" :radio_button{label=\"保存文件(&7)\";key=\"ra7\";mnemonic=\"7\";} "
fn
)
(write-line " }" fn)
(write-line " :boxed_column{label=\"操作\";" fn)
(write-line
" : button {label = \"取消(&E)\";key = \"but_Cancel\";is_cancel=true;}"
fn
)
(write-line
" : button {label = \"确定(&O)\";key = \"but_OK\";is_default=true;}"
fn
)
(write-line " } " fn)
(write-line "}//column" fn)
(write-line " }" fn)
(write-line "}" fn)
(close fn)
(setq fn (open fname "r"))
(setq dclid (load_dialog fname))
(while
(or (eq (substr (setq lin (vl-string-right-trim
"\" fn)"
(vl-string-left-trim "(write-line \"" (read-line fn))
)
)
1
2
)
"//"
)
(eq (substr lin 1 (vl-string-search " " lin)) "")
(not (eq (substr lin (+ (vl-string-search " " lin) 1) 9)
" : dialog"
)
)
)
)
(new_dialog (substr lin 1 (vl-string-search " " lin)) dclid)
(MyPlanSet)
(if wmp (actionDo wmp))
(action_tile "but_OK" "(MyPlanGet)(done_dialog 1)")
(action_tile "but_Cancel" "(kacha wmp)")
(setq return# (start_dialog))
(unload_dialog dclid)
(close fn)
(vl-file-delete fname)
return#
)
;;6.2 对话框上用户选择
(defun MyPlanGet (/ ARA0 ARA1 ARA2 ENVLENS)
(setq ra0 (get_tile "ra0"))
(setq ra1 (get_tile "ra1"))
(setq ra2 (get_tile "ra2"))
(setq ra3 (get_tile "ra3"))
(setq ra4 (get_tile "ra4"))
(setq ra5 (get_tile "ra5"))
(setq ra6 (get_tile "ra6"))
(setq ra7 (get_tile "ra7"))
(cond ((= ra0 "1") (setq Ara0 2))
((= ra1 "1") (setq Ara0 4))
((= ra2 "1") (setq Ara0 8))
)
(cond ((= ra3 "1") (setq Ara1 16))
((= ra4 "1") (setq Ara1 32))
)
(cond ((= ra5 "1") (setq Ara2 64))
((= ra6 "1") (setq Ara2 128))
((= ra7 "1") (setq Ara2 256))
)
(setq envLens (++ (list Ara0 Ara1 Ara2)))
(setenv "HuangMR\\Lens" (vl-princ-to-string envLens))
)
;;6.3设置对话框
(defun MyPlanSet (/ ENVLENS)
(setq envLens (read (getenv "HuangMR\\Lens")))
(cond ((= 2 (boole 1 envLens 2)) (set_tile "ra0" "1"))
((= 4 (logand envLens 4)) (set_tile "ra1" "1"))
((= 8 (logand envLens 8)) (set_tile "ra2" "1"))
)
(cond ((= 16 (logand envLens 16)) (set_tile "ra3" "1"))
((= 32 (logand envLens 32)) (set_tile "ra4" "1"))
)
(cond ((= 64 (logand envLens 64)) (set_tile "ra5" "1"))
((= 128 (logand envLens 128)) (set_tile "ra6" "1"))
((= 256 (logand envLens 256)) (set_tile "ra7" "1"))
)
)
;;6.4 切换
(defun actionDo (wmp / A N)
(repeat (setq n 8)
(action_tile (++ (list "ra" (setq n (1- n)))) "(kacha wmp)")
)
)
;;6.5 发声
(defun kacha (wmp / voice)
(setq voice (nth (ZL-RAND) (list "notify" "chimes" "chord" "ding")))
(setq voice (strcat "C:\\WINDOWS\\Media\\" voice ".wav"))
(Vlax-Put-Property wmp 'URL voice)
)
;;6.6 随机数0-3
(defun ZL-RAND ()
(fix (* 4 (/ (rem (getvar "CPUTICKS") 1984) 1983)))
)
;;7 线长统计
(defun HH:lens (ss / LENS SSV n)
(command "_.Select" ss "")
(setq ssv (vla-get-activeselectionset
(vla-get-activedocument (vlax-get-acad-object))
)
)
(setq n 0)
(setq lens 0)
(vlax-for x ssv
(setq
lens (++
(list lens
(vlax-curve-getdistatparam x (vlax-curve-getendparam x))
)
)
)
(setq n (1+ n))
)
(if ssv
(vlax-release-object ssv)
)
(princ (++ (list "\n 线数量(" n ") 总长为: " lens)))
(princ)
)
;;8.1
;;137.2 [功能] 图中最后图元Find True last entity
(Defun MJ:LASTENT (/ E0 EN)
(Setq E0 (EntLast))
(While (Setq EN (EntNext E0)) (Setq E0 EN))
E0
)
;;8.2
;;125.2 [功能] 获取在图元 en 之后产生的图元的选择集
(defun MJ:ss-entnext (en / ss)
(if en
(progn
(setq ss (ssadd))
(while (setq en (entnext en))
(if (not (member (cdr (assoc 0 (entget en)))
'("ATTRIB"
"VERTEX"
"SEQEND"
)
)
)
(ssadd en ss)
)
)
(if (zerop (sslength ss))
(setq ss nil)
)
ss
)
(ssget "_x")
)
)
;;8.3 另存
(defun HH:save (ss name / DNAME LASTENT NEWDNAME SS0)
(setq lastent (MJ:LASTENT))
(command "_.copy" ss "" "0,0" "@")
(setq ss0 (MJ:ss-entnext lastent))
(setq DName (getvar "dwgname"))
(setq NewDName (++ (list (vl-filename-base DName) "-" name)))
;;保证文件名不重复
(while (findfile (++ (list NewDName ".dwg")))
(setq NewDName (++ (list NewDName "-" name)))
)
(command "_.WBLOCK" NewDName "" "0,0" ss0 "")
(princ (++ (list "\n 已经保存,文件名为:" NewDName)))
)
;;9.1 编组开始;(command "_.undo" "be")
(defun startundo (*DOC*)
(vla-startundomark *DOC*)
)
;;9.2 编组结束(command "_.undo" "e")
(defun endundo (*DOC*)
(while (= 8 (logand 8 (getvar 'undoctl)))
(vla-endundomark *DOC*)
)
)
;;10 执行操作
(defun MyPlanDo ()
(cond ((= ra7 "1") ;局部保存
(cond ((= ra0 "1") ;//按图层
(setq fil (getLayer))
)
((= ra1 "1") ;//按颜色
(setq color (getcolor))
(setq en (car color))
(setq color (cadr color))
(setq layLis (ColorLayers color)) ;获得层
(setq fil (list '(-4 . "<OR")
(cons 62 color)
'(-4 . "<AND")
(cons 8 layLis)
'(-4 . "<OR")
(cons 62 0)
(cons 62 256)
'(-4 . "OR>")
'(-4 . "AND>")
'(-4 . "OR>")
)
)
)
((= ra2 "1") ;//按线型
(getLineType)
(TypeLayers LineType)
(setq fil (list '(-4 . "<OR")
(cons 6 LineType)
'(-4 . "<AND")
(cons 8 layLis)
'(-4 . "<OR")
(cons 6 "ByLayer")
(cons 6 "ByBlock")
'(-4 . "OR>")
'(-4 . "AND>")
'(-4 . "OR>")
)
)
)
)
)
(T ;显示or统计线长
(cond ((= ra0 "1")
(setq fil (cons (cons 0 "ARC,*LINE,CIRCLE,ELLIPSE") (getLayer)))
)
((= ra1 "1")
(setq color (getcolor))
(setq en (car color))
(setq color (cadr color))
(setq layLis (ColorLayers color)) ;获得层
(setq fil (list '(-4 . "<AND")
(cons 0 "ARC,*LINE,CIRCLE,ELLIPSE")
'(-4 . "<OR")
(cons 62 color)
'(-4 . "<AND")
(cons 8 layLis)
'(-4 . "<OR")
(cons 62 0)
(cons 62 256)
'(-4 . "OR>")
'(-4 . "AND>")
'(-4 . "OR>")
'(-4 . "AND>")
)
)
)
((= ra2 "1")
(getLineType)
(TypeLayers LineType)
(setq fil (list '(-4 . "<AND")
(cons 0 "ARC,*LINE,CIRCLE,ELLIPSE")
'(-4 . "<OR")
(cons 6 LineType)
'(-4 . "<AND")
(cons 8 layLis)
'(-4 . "<OR")
(cons 6 "ByLayer")
(cons 6 "ByBlock")
'(-4 . "OR>")
'(-4 . "AND>")
'(-4 . "OR>")
'(-4 . "AND>")
)
)
)
)
)
)
;;(setvar "nomutt" 1)
(cond ((= ra6 "1") ;线宽显示
(setvar "lwdisplay" 1)
(PreWidth en)
)
)
(cond ((= ra3 "1") (setq ss0 (ssget fil))) ;手选
((= ra4 "1") (setq ss0 (ssget "X" fil))) ;全选
)
;;(setvar "nomutt" 0)
(if ss0
(cond ((= ra5 "1") (HH:lens ss0)) ;统计线长
((= ra6 "1") (HHproSS ss0 len)) ;线宽显示
((= ra7 "1")
(cond ((= ra0 "1") (setq name (cdr (car fil))))
((= ra1 "1") (setq name color))
((= ra2 "1") (setq name LineType))
)
(HH:save ss0 name)
) ;保存文件
)
(gc)
)
)
;;11 本程序主程序
**** Hidden Message *****
;;下一步打算，加入中英文朗诵http://bbs.mjtd.com/forum.php?mod=viewthread&tid=58760&extra=page%3D2%26filter%3Dtypeid%26typeid%3D108%26typeid%3D108 学习黄总代码来了。。。 还得弹琴真是…… 呵呵，没音乐细胞可以乱弹琴不 谢谢谢谢谢谢谢谢谢谢谢谢 咔嚓声 什麼東西咔嚓了... 竟然要乱弹琴，呵呵 就是弹琴呗 不错不错，看看学习 弹一回琴~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 支持想看看 弹弹更健康！听听更有益！