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

/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 本程序主程序

(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 本程序主程序

游客，如果您要查看本帖隐藏内容请回复

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

显示全部楼层 · 发表于 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

谢谢，下载学习

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

失业农民XCB 该用户已被删除	发表于 2015-10-29 11:26:35 \| 显示全部楼层提示: 作者被禁止或删除内容自动屏蔽
失业农民XCB 该用户已被删除	论坛插件加载方法发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
	回复支持反对使用道具举报

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

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。