晓东CAD家园-论坛-A/VLISP-统计线长之前，请乱弹琴-[源码]-1 “统计线长”的改良版2 问：这是“统计线长”工具吗？是的，同时是一把小钢琴3 创意来自：不死猫nonsmall的咔嚓声4 提示：开音响哟1 加载后输入命令：Lens 2 击0 1 ...

/db_自贡黄明儒_ 发表于 2013-8-24 20:06:36

统计线长之前，请乱弹琴----[源码]

本帖最后由 /db_自贡黄明儒_ 于 2013-8-26 11:46 编辑

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 *****

ysq101 发表于 2013-8-24 20:13:47

这是什么？？？？？？？？围观一下

Lisphk 发表于 2013-8-24 20:16:08

楼主，代码呢？

dbx5511 发表于 2013-8-27 11:40:28

看看，谢谢分享！

朱冰发表于 2013-8-28 12:05:29

这个，能统计平面的电缆不？

hzj268 发表于 2014-7-22 08:11:49

?什么情况?能把线段长度分类统计吗

杜流浪人 发表于 2014-7-23 16:23:05

{:soso_e179:}

viphappy 发表于 2014-8-19 21:15:10

感谢楼主提供

wyldd 发表于 2015-9-6 10:50:12

没看懂，下来，看看

896052897 发表于 2015-9-11 05:16:55

嗯嗯。。。

laiz3000 发表于 2015-10-3 14:56:56

:)good job

失业农民XCB 发表于 2015-10-29 11:26:35

279491611 发表于 2016-6-2 13:46:22

谢谢分享，学习学习

PO0O0 发表于 2016-6-15 16:58:06

我用得到叶,看看

cdjtsf 发表于 2016-12-17 21:02:14

谢谢，下载学习

页: [1] 2 3

晓东CAD家园-论坛's Archiver

统计线长之前，请乱弹琴----[源码]