统计线长之前,须先乱弹琴

自贡黄明儒 · 发表于 2013-8-26 11:53:03

本帖最后由自贡黄明儒于 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 本程序主程序

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

(if (null (getenv "HuangMR\\Lens"))
(setenv "HuangMR\\Lens" "52")
  );初赋值
  (vl-load-com)
  ;; *DOC*常用，故设置成全局，带*时VL编辑器会排在前面，易于去除
  (if *DOC*
nil
(setq *DOC* (vla-get-activedocument (vlax-get-acad-object)))
  )
  (Setq wmp (vlax-Create-Object "WMPlayer.OCX"))

  (setq osm1 (getvar "osmode"))
  (setvar "osmode" 0)
  (startundo *DOC*)                               ;可能对wblock无效
  (setq RETURN# (MyPlanDCL))                         ;执行对话框，取得用户选择
  (if (= RETURN# 1)
(MyPlanDo)
(gc)
  )
  (endundo *DOC*)
  (setvar "osmode" osm1)

  (if wmp (vlax-release-object wmp))
  ;;(if ss0 (command "_.Select" ss0 "")) (princ)
  ;;(if ss0 (ayEntSSHighLight ss0) )
)

;;下一步打算，加入中英文朗诵http://bbs.mjtd.com/forum.php?mod=viewthread&tid=58760&extra=page%3D2%26filter%3Dtypeid%26typeid%3D108%26typeid%3D108

fengyu6913 · 发表于 2024-8-11 12:59:41

学习黄总代码来了。。。

kpl · 发表于 2022-8-19 16:22:41

还得弹琴真是……

hao3ren · 发表于 2013-8-26 12:29:41

呵呵，没音乐细胞可以乱弹琴不

jxjaxa · 发表于 2013-8-26 12:40:46

谢谢谢谢谢谢谢谢谢谢谢谢

adslwang · 发表于 2013-8-26 13:07:27

咔嚓声什麼東西咔嚓了...

chendili · 发表于 2013-8-26 15:44:12

竟然要乱弹琴，呵呵

陨落 · 发表于 2013-8-26 15:59:26

就是弹琴呗

819534890 · 发表于 2013-8-26 16:55:19

不错不错，看看学习

龙城飞将36 · 发表于 2013-8-26 17:31:42

弹一回琴~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

freehand8008 · 发表于 2013-8-26 17:32:08

支持想看看

dz-2011 · 发表于 2013-8-26 18:37:39

弹弹更健康！听听更有益！

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

[源码] 统计线长之前,须先乱弹琴

本帖子中包含更多资源

评分

点评

点评