竖线改变

/db_自贡黄明儒_ · 发表于 2014-8-21 09:09:03

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

您需要登录才可以下载或查看，没有账号？立即注册

×

本帖最后由 /db_自贡黄明儒_ 于 2014-8-21 13:39 编辑

因工作需要，我写了个处理竖线的程序，使用起来不爽....
;;***********************************************************竖线缩放
;;竖线画好后，由于基础为200高，这些线批量缩，故写这程序黄明儒 2014.6.13
(defun C:HHVL (/ CMD1 E KEY KEY1 N NUM OSM1 P PE PS SS)
 ;;1 错误处理
 (defun *error* (msg)
(while (not (equal (getvar "cmdnames") "")) (command nil))
(cond (osm1 (setvar "osmode" osm1)))
(princ "\n 出错啦!")
(princ)
 )

 (vl-load-com)
 (or *DOC*
 (setq *DOC* (vla-get-ActiveDocument (vlax-get-acad-object)))
 )
;; (_StartUndo *DOC*)
 (setq cmd1 (getvar "cmdecho"))
 (setvar "cmdecho" 0)
 (initget "Total DElta")
 (setq key (getkword "\n竖线改变[保证总长(T)/端头缩减(DE)]:<T>"))
 (cond ((not key) (setq key "Total")))
 (initget "Up Down")
 (setq key1 (getkword "\n缩减竖线[上部(U)/下部(D)]:"))
 (cond ((not key1) (setq key1 "Up")))
 (initget 1)
 (cond ((equal key "Total") (setq Num (getreal "\n 总长为:")))
 (T (setq Num (getreal "\n /端头缩减:")))
 )
 (while (setq ss (ssget ":S" '((0 . "*LINE"))))
(repeat (setq n (sslength ss))
 (setq e (ssname ss (setq n (1- n))))
 (setq Ps (vlax-curve-getStartPoint e))
 (setq Pe (vlax-curve-getEndPoint e))
 (cond
 ((> (cadr Ps) (cadr Pe))
 (cond
 ((equal key1 "Up") (setq p Ps))
 (T (setq p pe))
 )
 )
 (T
 (cond
 ((equal key1 "Up") (setq p pe))
 (T (setq p Ps))
 )
 )
 )
 (command "_.LENGTHEN" key Num (list e p) "")
)
 )
 (setvar "cmdecho" cmd1)
;; (_EndUndo *DOC*)
 (gc)
 (princ)
)
;;***********************************************************竖线缩放

lucas3 · 发表于 2014-8-21 09:37:17

因工作需要，我写了个处理竖线的程序，使用起来不爽....

使用起来不爽？什么意思？不爽还发出来啊，哈哈

lucas3 · 发表于 2014-8-21 12:11:09

lucas3 发表于 2014-8-21 09:37
使用起来不爽？什么意思？不爽还发出来啊，哈哈

黄大师挖苦我了，究竟哪里不爽，说出来啊，论坛自有高人会帮忙的！

Free-Lancer · 发表于 2014-8-21 15:49:28

本帖最后由 Free-Lancer 于 2014-8-21 15:50 编辑

练习练习 DCL

(defun c:tt (/ id k1 k2 k3 k4 ChangeLine ShowDCL ss key1 key2 lst)
(defun ChangeLine (lst len / p1 p2)
(foreach ln lst
(mapcar 'set
'(p1 p2)
(vl-sort (list (vlax-curve-getstartpoint ln)
(vlax-curve-getendpoint ln)
)
'(lambda (x1 x2) (< (cadr x1) (cadr x2)))
)
)
(if (= key2 "k3") ;_Up
(if (= key1 "k1") ;_Totle
(setq p2 (polar p1 _pi2 len))
(setq p2 (polar p2 _pi2 len))
)
;;Down
(if (= key1 "k1")
(setq p1 (polar p2 _3pi len))
(setq p1 (polar p1 _3pi len))
)
)
(if (wcmatch (vla-get-objectname ln) "AcDbLine")
(progn
(vlax-put ln 'StartPoint p1)
(vlax-put ln 'EndPoint p2)
)
(vlax-put ln
'Coordinates
(list (car p1) (cadr p1) (car p2) (cadr p2))
)
)
)
)
(defun showdcl (lst / strl next d len fn id)
(setq strl '("sxsj:dialog { "
" label = \"竖线缩减\" ; "
" :column { "
" :row { "
" :boxed_radio_row { "
" label = \"模式\" ; "
" :radio_button { "
" key = \"k1\" ; "
" label = \"总长\" ;"
" } "
" :radio_button { "
" key = \"k2\" ; "
" label = \"端头\" ;"
" } "
" } "
" :boxed_radio_row { "
" label = \"选项\"; "
" :radio_button { "
" key = \"k3\" ; "
" label = \"上部\" ;"
" } "
" :radio_button { "
" key = \"k4\" ; "
" label = \"下部\" ;"
" } "
" } "
" } "
" :boxed_row { "
" label = \"数量\" ; "
" :edit_box { "
" key = \"len\" ; "
" label = \"长度\" ;"
" } "
" :button { "
" key = \"pick\" ; "
" label = \"拾取\" ;"
" } "
" } "
" } "
" ok_only; "
" errtile; "
"} "
)
fn (dcl:make strl)
next 2
key1 "k1"
key2 "k3"
)
(while (> next 1)
(setq id (dcl:load fn "sxsj"))
(if d
(set_tile "len" (vl-princ-to-string d))
)
(dcl:radioinit '("k1" "k2") key1)
(dcl:radioinit '("k3" "k4") key2)
(dcl:radioaction '("k1" "k2") key1)
(dcl:radioaction '("k3" "k4") key2)
(action_tile "len" "(dcl:checkin $value \"数值\" \"len\")")
(action_tile
"pick"
"(setq key1 (dcl:radiostatus '(\"k1\" \"k2\"))) (setq key2 (dcl:radiostatus '(\"k3\" \"k4\")))(done_dialog 6)"
)
(action_tile
"accept"
"(setq len (distof (get_tile \"len\")))(setq next 0)(done_dialog 0)(changeline lst len)"
)
(setq next (start_dialog))
(if (= next 6)
(setq d (getdist "\nDist: "))
)
)
(unload_dialog id) ;_卸载对话框
(vl-file-delete fn) ;_删除DCL文件
(princ)
)
(fy:begin)
(if (and (setq ss (ssget '((-4 . "<or")
(0 . "line")
(-4 . "<and")
(0 . "*Polyline")
(90 . 2)
(-4 . "and>")
(-4 . "or>")
)
)
)
(setq lst
(vl-remove-if-not
'(lambda (x / sp ep)
(setq sp (vlax-curve-getstartpoint x)
ep (vlax-curve-getendpoint x)
)
(or (equal (angle sp ep) _pi2 1e-3)
(equal (angle sp ep) _3pi 1e-3)
)
)
(fy:cset->objs)
)
)
)
(showdcl lst)
)
(princ)
)

(defun c:tt (/ id k1 k2 k3 k4 ChangeLine ShowDCL ss key1 key2 lst) 
  (defun ChangeLine (lst len / p1 p2) 
    (foreach ln        lst 
      (mapcar 'set 
              '(p1 p2) 
              (vl-sort (list (vlax-curve-getstartpoint ln) 
                             (vlax-curve-getendpoint ln) 
                       ) 
                       '(lambda (x1 x2) (< (cadr x1) (cadr x2))) 
              ) 
      ) 
      (if (= key2 "k3") ;_Up 
        (if (= key1 "k1") ;_Totle 
          (setq p2 (polar p1 _pi2 len)) 
          (setq p2 (polar p2 _pi2 len)) 
        ) 
        ;;Down 
        (if (= key1 "k1") 
          (setq p1 (polar p2 _3pi len)) 
          (setq p1 (polar p1 _3pi len)) 
        ) 
      ) 
      (if (wcmatch (vla-get-objectname ln) "AcDbLine") 
        (progn 
          (vlax-put ln 'StartPoint p1) 
          (vlax-put ln 'EndPoint p2) 
        ) 
        (vlax-put ln 
                  'Coordinates 
                  (list (car p1) (cadr p1) (car p2) (cadr p2)) 
        ) 
      ) 
    ) 
  ) 
  (defun showdcl (lst / strl next d len fn id) 
    (setq strl '("sxsj:dialog {                     " 
                 "    label = \"竖线缩减\" ;        " 
                 "    :column {                     " 
                 "        :row {                    " 
                 "        :boxed_radio_row {        " 
                 "            label = \"模式\" ;    " 
                 "            :radio_button {       " 
                 "               key = \"k1\" ;     " 
                 "                label = \"总长\" ;" 
                 "            }                     " 
                 "            :radio_button {       " 
                 "               key = \"k2\" ;     " 
                 "                label = \"端头\" ;" 
                 "            }                     " 
                 "            }                     " 
                 "        :boxed_radio_row {        " 
                 "           label = \"选项\";      " 
                 "            :radio_button {       " 
                 "                key = \"k3\" ;    " 
                 "                label = \"上部\" ;" 
                 "            }                     " 
                 "            :radio_button {       " 
                 "                key = \"k4\" ;    " 
                 "                label = \"下部\" ;" 
                 "            }                     " 
                 "        }                         " 
                 "        }                         " 
                 "        :boxed_row {              " 
                 "            label = \"数量\" ;    " 
                 "            :edit_box {           " 
                 "                key = \"len\" ;   " 
                 "                label = \"长度\" ;" 
                 "            }                     " 
                 "            :button {             " 
                 "                key = \"pick\" ;  " 
                 "                label = \"拾取\" ;" 
                 "            }                     " 
                 "        }                         " 
                 "    }                             " 
                 "    ok_only;                      " 
                 "    errtile;                      " 
                 "}                                 " 
                ) 
          fn   (dcl:make strl) 
          next 2 
          key1 "k1" 
          key2 "k3" 
    ) 
    (while (> next 1) 
      (setq id (dcl:load fn "sxsj")) 
      (if d 
        (set_tile "len" (vl-princ-to-string d)) 
      ) 
      (dcl:radioinit '("k1" "k2") key1) 
      (dcl:radioinit '("k3" "k4") key2) 
      (dcl:radioaction '("k1" "k2") key1) 
      (dcl:radioaction '("k3" "k4") key2) 
      (action_tile "len" "(dcl:checkin $value \"数值\" \"len\")") 
      (action_tile 
        "pick" 
        "(setq key1 (dcl:radiostatus '(\"k1\" \"k2\"))) (setq key2 (dcl:radiostatus '(\"k3\" \"k4\")))(done_dialog 6)" 
      ) 
      (action_tile 
        "accept" 
        "(setq len (distof (get_tile \"len\")))(setq next 0)(done_dialog 0)(changeline lst len)" 
      ) 
      (setq next (start_dialog)) 
      (if (= next 6) 
        (setq d (getdist "\nDist: ")) 
      ) 
    ) 
    (unload_dialog id) ;_卸载对话框 
    (vl-file-delete fn) ;_删除DCL文件 
    (princ) 
  ) 
  (fy:begin) 
  (if (and (setq ss (ssget '((-4 . "<or") 
                             (0 . "line") 
                             (-4 . "<and") 
                             (0 . "*Polyline") 
                             (90 . 2) 
                             (-4 . "and>") 
                             (-4 . "or>") 
                            ) 
                    ) 
           ) 
           (setq lst 
                  (vl-remove-if-not 
                    '(lambda (x / sp ep) 
                       (setq sp        (vlax-curve-getstartpoint x) 
                             ep        (vlax-curve-getendpoint x) 
                       ) 
                       (or (equal (angle sp ep) _pi2 1e-3) 
                           (equal (angle sp ep) _3pi 1e-3) 
                       ) 
                     ) 
                    (fy:cset->objs) 
                  ) 
           ) 
      ) 
    (showdcl lst) 
  ) 
  (princ) 
)

lucas3 · 发表于 2014-8-21 19:30:23

本帖最后由 lucas3 于 2014-8-21 19:42 编辑

Free-Lancer 发表于 2014-8-21 15:49
练习练习 DCL

Free-Lancer大师，您好！请问下面这个对话框要写入到lisp当中去，要怎样去做？

roughness
:dialog{ label="粗糙度";
spacer;
:row{
:column{
:image_button{ key = "RM"; aspect_ratio = 1; width = 8; fixed_width = true; color = -2; allow_accept = true; }
:image_button{ key = "UN"; aspect_ratio = 1; width = 8; fixed_width = true; color = -2; allow_accept = true; }
:image_button{ key = "BS"; aspect_ratio = 1; width = 8; fixed_width = true; color = -2; allow_accept = true; }
}
:list_box{ key="RV"; value=8; width=16; height=14; allow_accept=true; }
}
:row{
:errtile{ width= 14; }
:edit_box{ label = "比例:"; key = "SC"; edit_width = 3; }
}
ok_cancel;
}

我用这个DCL2LSP转换

(defun c:dcl2lsp ( / fname1 fn1 fname2 fn2 k fn1l fn2l )
(setq fname1 (getfiled "Select DCL file" "" "dcl" 16))
(setq fn1 (open fname1 "r"))
(setq fname2 (getfiled "File to save" "" "lsp" 1))
(setq fn2 (open fname2 "w"))
(while (setq fn1l (read-line fn1))
(setq fn2l fn1l)
(setq k 0)
(while (setq k (vl-string-search "\"" fn2l k))
(setq fn2l (vl-string-subst "\\\"" "\"" fn2l k))
(setq k (+ k 2))
)
(setq fn2l (strcat "(write-line \"" fn2l "\" fn)"))
(write-line fn2l fn2)
)
(close fn1)
(close fn2)
(princ)
)

转换后是这样的

(write-line "roughness" fn)
(write-line ":dialog{ label=\"粗糙度\";" fn)
(write-line " spacer;" fn)
(write-line " :row{" fn)
(write-line " :column{" fn)
(write-line " :image_button{ key = \"RM\"; aspect_ratio = 1; width = 8; fixed_width = true; color = -2; allow_accept = true; }" fn)
(write-line " :image_button{ key = \"UN\"; aspect_ratio = 1; width = 8; fixed_width = true; color = -2; allow_accept = true; }" fn)
(write-line " :image_button{ key = \"BS\"; aspect_ratio = 1; width = 8; fixed_width = true; color = -2; allow_accept = true; }" fn)
(write-line " }" fn)
(write-line " :list_box{ key=\"RV\"; value=8; width=16; height=14; allow_accept=true; }" fn)
(write-line " }" fn)
(write-line " :row{" fn)
(write-line " :errtile{ width= 14; }" fn)
(write-line " :edit_box{ label = \"比例:\"; key = \"SC\"; edit_width = 3; }" fn)
(write-line " }" fn)
(write-line " ok_cancel;" fn)
(write-line "}" fn)

(write-line "roughness" fn) 
(write-line ":dialog{ label=\"粗糙度\";" fn) 
(write-line " spacer;" fn) 
(write-line " :row{" fn) 
(write-line "  :column{" fn) 
(write-line "   :image_button{ key = \"RM\"; aspect_ratio = 1; width = 8; fixed_width = true; color = -2; allow_accept = true; }" fn) 
(write-line "   :image_button{ key = \"UN\"; aspect_ratio = 1; width = 8; fixed_width = true; color = -2; allow_accept = true; }" fn) 
(write-line "   :image_button{ key = \"BS\"; aspect_ratio = 1; width = 8; fixed_width = true; color = -2; allow_accept = true; }" fn) 
(write-line "  }" fn) 
(write-line "  :list_box{ key=\"RV\"; value=8; width=16; height=14; allow_accept=true; }" fn) 
(write-line " }" fn) 
(write-line " :row{" fn) 
(write-line "  :errtile{ width= 14; }" fn) 
(write-line "  :edit_box{ label = \"比例:\"; key = \"SC\"; edit_width = 3; }" fn) 
(write-line " }" fn) 
(write-line " ok_cancel;" fn) 
(write-line "}" fn)

那如何使用呢？

Free-Lancer · 发表于 2014-8-21 21:10:13

lucas3 发表于 2014-8-21 19:30
Free-Lancer大师，您好！请问下面这个对话框要写入到lisp当中去，要怎样去做？

这个dcl2lsp好像只是说明一个方法, 可以这样改改

(defun c:dcl2lsp (/ fname1 fn1 fname2 fn2 k fn1l fn2l)
(setq fname1 (getfiled "Select DCL file" "" "dcl" 16))
(setq fn1 (open fname1 "r"))
(setq fname2 (getfiled "File to save" "" "lsp" 1))
(setq fn2 (open fname2 "w"))
(write-line "(defun writedcl (fn)" fn2);_增加个函数定义
(while (setq fn1l (read-line fn1))
(setq fn2l fn1l)
(setq k 0)
(while (setq k (vl-string-search "\"" fn2l k))
(setq fn2l (vl-string-subst "\\\"" "\"" fn2l k))
(setq k (+ k 2))
)
(setq fn2l (strcat "(write-line \"" fn2l "\" fn)"))
(write-line fn2l fn2)
)
(write-line ")" fn2)
(close fn1)
(close fn2)
(princ)
)

使用时将生成的Lisp拷贝到程序中作为一个子函数，然后这样使用

(setq fl (vl-filename-mktemp (strcat "FYDCL" ".dcl"))
fn (open fl "w")
)
(writedcl fn);_执行函数写出临时DCL
(close fn)

lucas3 · 发表于 2014-8-22 10:28:52

Free-Lancer 发表于 2014-8-21 21:10
这个dcl2lsp好像只是说明一个方法, 可以这样改改

使用时将生成的Lisp拷贝到程序中作为一个子函数，然 ...

谢谢大师指点，只是程序中有

(setq DLG_ID (load_dialog "rough.dcl"))
(new_dialog "roughness" DLG_ID)

不知怎么调用，大师能帮忙改改吗？

;;http://bbs.mjtd.com/thread-91278-1-1.html
;;by cabinsummer
(defun c:rough(/ scl value prcs DLG_ID llist
p1u p2u p3u pcu ptu pqy
p1d p2d p3d pcd ptd
ename era erb dra drb
snappnt nearpnt tag code ang
max_x max_y do p00 ra rb
)
(defun do_list()
(start_list "RV" 1)
(setq value (nth (atoi $value) llist))
(end_list)
(set_tile "error" (strcat "粗糙度为 Ra" value))
)
(defun myerr(msg)
(command "undo" "e")
(setvar "osmode" os)
(entdel ename)
(setq *error* olderr)
)
(setvar "cmdecho" 0)
(setq os (getvar "osmode"))
(setq olderr *error*)
(setq *error* myerr)
(setvar "osmode" 0)
(command "undo" "be")
(setq scl (getvar "dimscale"))
(setq value "3.2")
(setq prcs 1)
(setq DLG_ID (load_dialog "rough.dcl"))
(new_dialog "roughness" DLG_ID)
(start_image "RM")
(setq max_x (dimx_tile "RM") max_y (dimy_tile "RM"))
(slide_image 5 5 (- max_x 10) (- max_y 10) (strcat (findfile "rough.slb") "(RM)"))
(end_image)
(start_image "UN")
(setq max_x (dimx_tile "UN") max_y (dimy_tile "UN"))
(slide_image 5 5 (- max_x 10) (- max_y 10) (strcat (findfile "rough.slb") "(UN)"))
(end_image)
(start_image "BS")
(setq max_x (dimx_tile "BS") max_y (dimy_tile "BS"))
(slide_image 5 5 (- max_x 10) (- max_y 10) (strcat (findfile "rough.slb") "(BS)"))
(end_image)
(setq llist '("" "0.025" "0.05" "0.1" "0.2" "0.4" "0.8" "1.6" "3.2" "6.3" "12.5" "25" "50"))
(start_list "RV")
(mapcar 'add_list llist)
(end_list)
(set_tile "RV" "8")
(set_tile "error" (strcat "粗糙度为 Ra3.2"))
(action_tile "RM" "(setq prcs 1)")
(action_tile "UN" "(setq prcs 2)")
(action_tile "BS" "(setq prcs 0)")
(action_tile "RV" "(do_list)")
(action_tile "accept" "(done_dialog 1)(setq do T)")
(action_tile "cancel" "(done_dialog 0)")
(start_dialog)
(unload_dialog DLG_ID)
(if do
(progn
(setq p00 '(0.0 0.0 0.0))
(setq p1u '(2.3094 4.0 0.0))
(setq p2u '(-2.3094 4.0 0.0))
(setq p3u '(5.7735 10.0 0.0))
(setq pcu '(0.0 2.67 0.0))
(setq ptu '(0.0 6.5 0.0))
(setq p1d '(-2.3094 -4.0 0.0))
(setq p2d '(2.3094 -4.0 0.0))
(setq p3d '(-5.7735 -10.0 0.0))
(setq pcd '(0.0 -2.67 0.0))
(setq ptd '(0.0 -6.5 0.0))
(setq pqy '(-12.0 3.0 0.0))
(create_ra)
(create_rb)
(entdel erb)
(prompt "选择插入点")
(setq ename era)
(setq loop T)
(while loop
(setq code (grread T 8))
(cond
((= (car code) 5)(do_move))
((= (car code) 3)(do_left))
((or (= (car code) 11)(= (car code) 25))(do_right))
((or (equal code '(2 97))(equal code'(2 65)))(do_a))
((or (equal code '(2 115))(equal code'(2 83)))(do_s))
)
)
)
)
(setvar "osmode" os)
(command "undo" "e")
(setq *error* olderr)
(princ)
)
(defun do_a()
(setq value (cadr (member value llist)))
(if value (progn (refresh ra)(refresh rb))(setq value "50"))
)
(defun do_s()
(setq value (cadr (member value (reverse llist))))
(if value (progn (refresh ra)(refresh rb))(setq value ""))
)
(defun refresh(bname / kname edata)
(tblnext "block" T)
(while (/= (cdr (assoc 2 (setq kname (tblnext "block")))) bname))
(setq edata (entget (cdr (assoc -2 kname))))
(entmod (subst (cons 1 value)(assoc 1 edata) edata))
(entupd ename)
)
(defun create_ra()
(entmake (list '(0 . "BLOCK")'(10 0 0 0)'(70 . 1)'(2 . "*U")))
(entmake (list '(0 . "TEXT")(cons 10 p00)(cons 11 ptu)'(8 . "DIM")'(40 . 2.5)'(62 . 3)'(72 . 4)(cons 1 value)))
(cond
((= prcs 1)(entmake (list '(0 . "LINE")(cons 10 p1u)(cons 11 p2u)'(8 . "DIM"))))
((= prcs 2)(entmake (list '(0 . "CIRCLE")(cons 10 pcu)'(40 . 1.33)'(8 . "DIM"))))
)
(entmake (list '(0 . "LINE")(cons 10 p00)(cons 11 p2u)'(8 . "DIM")))
(entmake (list '(0 . "LINE")(cons 10 p00)(cons 11 p3u)'(8 . "DIM")))
(setq ra (entmake '((0 . "ENDBLK"))))
(entmake (list '(0 . "INSERT")(cons 10 p00)(cons 41 scl)(cons 42 scl)(cons 2 ra)))
(setq era (entlast))
(setq dra (entget era))
)
(defun create_rb()
(entmake (list '(0 . "BLOCK")'(10 0 0 0)'(70 . 1)'(2 . "*U")))
(entmake (list '(0 . "TEXT")(cons 10 p00)(cons 11 ptd)'(8 . "DIM")'(40 . 2.5)'(62 . 3)'(72 . 4)(cons 1 value)))
(cond
((= prcs 1)(entmake (list '(0 . "LINE")(cons 10 p1d)(cons 11 p2d)'(8 . "DIM"))))
((= prcs 2)(entmake (list '(0 . "CIRCLE")(cons 10 pcd)'(40 . 1.33)'(8 . "DIM"))))
)
(entmake (list '(0 . "LINE")(cons 10 p00)(cons 11 p2d)'(8 . "DIM")))
(entmake (list '(0 . "LINE")(cons 10 p00)(cons 11 p3d)'(8 . "DIM")))
(setq rb (entmake '((0 . "ENDBLK"))))
(entmake (list '(0 . "INSERT")(cons 10 p00)(cons 41 scl)(cons 42 scl)(cons 2 rb)))
(setq erb (entlast))
(setq drb (entget erb))
)
(defun do_left()
(setq snappnt (cadr code))
(entdel ename)
(if (osnap snappnt "nea")
(progn
(entdel ename)
(create_ra)
(create_rb)
(entdel erb)
(setq ename era)
)
(progn
(entdel ename)
(setq dra (subst (cons 50 0.0)(assoc 50 dra) dra))
(setq dra (subst (cons 41 (* 1.25 (cdr (assoc 41 dra))))(assoc 41 dra) dra))
(setq dra (subst (cons 42 (* 1.25 (cdr (assoc 42 dra))))(assoc 42 dra) dra))
(entmod dra)
(entmake (list '(0 . "TEXT")'(8 . "DIM")'(10 0.0 0.0 0.0)(cons 40 (* scl 5.0))'(62 . 3)'(72 . 4)(cons 11 (mapcar '+ (mapcar (function (lambda (x)(* scl x))) pqy) snappnt))'(1 . "其余")))
(setq loop nil)
)
)
)
(defun do_right()
(setq loop nil)
(entdel ename)
)
(defun do_move()
(setq snappnt (cadr code))
(entdel ename)
(setq nearpnt (osnap snappnt "nea"))
(if nearpnt
(progn
(setq ang (angle nearpnt snappnt))
(cond
(
(and (>= ang (/ pi 6.0))(<= ang pi))
(setq ang (- ang (/ pi 2.0)))
(entdel era)
(setq ename era)
(setq dra (subst (cons 10 nearpnt)(assoc 10 dra) dra))
(setq nearpnt nil)
(setq dra (subst (cons 50 ang)(assoc 50 dra) dra))
(entmod dra)
)
(
(or (= ang 0.0)(and (> ang (* (/ pi 6.0) 7.0))(< ang (* pi 2.0))))
(setq ang (+ ang (/ pi 2.0)))
(entdel erb)
(setq ename erb)
(setq drb (subst (cons 10 nearpnt)(assoc 10 drb) drb))
(setq nearpnt nil)
(setq drb (subst (cons 50 ang)(assoc 50 drb) drb))
(entmod drb)
)
(T
(entdel era)
(setq ename era)
(setq nearpnt nil)
)
)
)
(progn
(entdel era)
(setq ename era)
(setq dra (subst (cons 10 snappnt)(assoc 10 dra) dra))
(setq dra (subst (cons 50 0.0)(assoc 50 dra) dra))
(entmod dra)
(setq nearpnt nil)
)
)
)

;;<a href=\"http://bbs.mjtd.com/thread-91278-1-1.html\" target=\"_blank\">http://bbs.mjtd.com/thread-91278-1-1.html</a> 
;;by cabinsummer 
(defun c:rough(/ scl value prcs DLG_ID llist 
               p1u p2u p3u pcu ptu pqy 
               p1d p2d p3d pcd ptd 
               ename era erb dra drb 
               snappnt nearpnt tag code ang 
               max_x max_y do p00 ra rb 
              ) 
  (defun do_list() 
    (start_list "RV" 1) 
    (setq value (nth (atoi $value) llist)) 
    (end_list) 
    (set_tile "error" (strcat "粗糙度为 Ra" value)) 
  ) 
  (defun myerr(msg) 
    (command "undo" "e") 
    (setvar "osmode" os) 
    (entdel ename) 
    (setq *error* olderr) 
  ) 
  (setvar "cmdecho" 0) 
  (setq os (getvar "osmode")) 
  (setq olderr *error*) 
  (setq *error* myerr) 
  (setvar "osmode" 0) 
  (command "undo" "be") 
  (setq scl (getvar "dimscale")) 
  (setq value "3.2") 
  (setq prcs 1) 
  (setq DLG_ID (load_dialog "rough.dcl")) 
  (new_dialog "roughness" DLG_ID) 
  (start_image "RM") 
  (setq max_x (dimx_tile "RM") max_y (dimy_tile "RM")) 
  (slide_image 5 5 (- max_x 10) (- max_y 10) (strcat (findfile "rough.slb") "(RM)")) 
  (end_image) 
  (start_image "UN") 
  (setq max_x (dimx_tile "UN") max_y (dimy_tile "UN")) 
  (slide_image 5 5 (- max_x 10) (- max_y 10) (strcat (findfile "rough.slb") "(UN)")) 
  (end_image) 
  (start_image "BS") 
  (setq max_x (dimx_tile "BS") max_y (dimy_tile "BS")) 
  (slide_image 5 5 (- max_x 10) (- max_y 10) (strcat (findfile "rough.slb") "(BS)")) 
  (end_image) 
  (setq llist '("" "0.025" "0.05" "0.1" "0.2" "0.4" "0.8" "1.6" "3.2" "6.3" "12.5" "25" "50")) 
  (start_list "RV") 
  (mapcar 'add_list llist) 
  (end_list) 
  (set_tile "RV" "8") 
  (set_tile "error" (strcat "粗糙度为 Ra3.2")) 
  (action_tile "RM" "(setq prcs 1)") 
  (action_tile "UN" "(setq prcs 2)") 
  (action_tile "BS" "(setq prcs 0)") 
  (action_tile "RV" "(do_list)") 
  (action_tile "accept" "(done_dialog 1)(setq do T)") 
  (action_tile "cancel" "(done_dialog 0)") 
  (start_dialog) 
  (unload_dialog DLG_ID) 
  (if do 
    (progn 
      (setq p00 '(0.0 0.0 0.0)) 
      (setq p1u '(2.3094 4.0 0.0)) 
      (setq p2u '(-2.3094 4.0 0.0)) 
      (setq p3u '(5.7735 10.0 0.0)) 
      (setq pcu '(0.0 2.67 0.0)) 
      (setq ptu '(0.0 6.5 0.0)) 
      (setq p1d '(-2.3094 -4.0 0.0)) 
      (setq p2d '(2.3094 -4.0 0.0)) 
      (setq p3d '(-5.7735 -10.0 0.0)) 
      (setq pcd '(0.0 -2.67 0.0)) 
      (setq ptd '(0.0 -6.5 0.0)) 
      (setq pqy '(-12.0 3.0 0.0)) 
      (create_ra) 
      (create_rb) 
      (entdel erb) 
      (prompt "选择插入点") 
      (setq ename era) 
      (setq loop T) 
      (while loop 
        (setq code (grread T 8)) 
        (cond 
          ((= (car code) 5)(do_move)) 
          ((= (car code) 3)(do_left)) 
          ((or (= (car code) 11)(= (car code) 25))(do_right)) 
          ((or (equal code '(2 97))(equal code'(2 65)))(do_a)) 
          ((or (equal code '(2 115))(equal code'(2 83)))(do_s)) 
        ) 
      ) 
    ) 
  ) 
  (setvar "osmode" os) 
  (command "undo" "e") 
  (setq *error* olderr) 
  (princ) 
) 
(defun do_a() 
  (setq value (cadr (member value llist))) 
  (if value (progn (refresh ra)(refresh rb))(setq value "50")) 
) 
(defun do_s() 
  (setq value (cadr (member value (reverse llist)))) 
  (if value (progn (refresh ra)(refresh rb))(setq value "")) 
) 
(defun refresh(bname / kname edata) 
  (tblnext "block" T) 
  (while (/= (cdr (assoc 2 (setq kname (tblnext "block")))) bname)) 
  (setq edata (entget (cdr (assoc -2 kname)))) 
  (entmod (subst (cons 1 value)(assoc 1 edata) edata)) 
  (entupd ename) 
) 
(defun create_ra() 
  (entmake (list '(0 . "BLOCK")'(10 0 0 0)'(70 . 1)'(2 . "*U"))) 
  (entmake (list '(0 . "TEXT")(cons 10 p00)(cons 11 ptu)'(8 . "DIM")'(40 . 2.5)'(62 . 3)'(72 . 4)(cons 1 value))) 
  (cond 
    ((= prcs 1)(entmake (list '(0 . "LINE")(cons 10 p1u)(cons 11 p2u)'(8 . "DIM")))) 
    ((= prcs 2)(entmake (list '(0 . "CIRCLE")(cons 10 pcu)'(40 . 1.33)'(8 . "DIM")))) 
  ) 
  (entmake (list '(0 . "LINE")(cons 10 p00)(cons 11 p2u)'(8 . "DIM"))) 
  (entmake (list '(0 . "LINE")(cons 10 p00)(cons 11 p3u)'(8 . "DIM"))) 
  (setq ra (entmake '((0 . "ENDBLK")))) 
  (entmake (list '(0 . "INSERT")(cons 10 p00)(cons 41 scl)(cons 42 scl)(cons 2 ra))) 
  (setq era (entlast)) 
  (setq dra (entget era)) 
) 
(defun create_rb() 
  (entmake (list '(0 . "BLOCK")'(10 0 0 0)'(70 . 1)'(2 . "*U"))) 
  (entmake (list '(0 . "TEXT")(cons 10 p00)(cons 11 ptd)'(8 . "DIM")'(40 . 2.5)'(62 . 3)'(72 . 4)(cons 1 value))) 
  (cond 
    ((= prcs 1)(entmake (list '(0 . "LINE")(cons 10 p1d)(cons 11 p2d)'(8 . "DIM")))) 
    ((= prcs 2)(entmake (list '(0 . "CIRCLE")(cons 10 pcd)'(40 . 1.33)'(8 . "DIM")))) 
  ) 
  (entmake (list '(0 . "LINE")(cons 10 p00)(cons 11 p2d)'(8 . "DIM"))) 
  (entmake (list '(0 . "LINE")(cons 10 p00)(cons 11 p3d)'(8 . "DIM"))) 
  (setq rb (entmake '((0 . "ENDBLK")))) 
  (entmake (list '(0 . "INSERT")(cons 10 p00)(cons 41 scl)(cons 42 scl)(cons 2 rb))) 
  (setq erb (entlast)) 
  (setq drb (entget erb)) 
) 
(defun do_left() 
  (setq snappnt (cadr code)) 
  (entdel ename) 
  (if (osnap snappnt "nea") 
    (progn 
      (entdel ename) 
      (create_ra) 
      (create_rb) 
      (entdel erb) 
      (setq ename era) 
    ) 
    (progn 
      (entdel ename) 
      (setq dra (subst (cons 50 0.0)(assoc 50 dra) dra)) 
      (setq dra (subst (cons 41 (* 1.25 (cdr (assoc 41 dra))))(assoc 41 dra) dra)) 
      (setq dra (subst (cons 42 (* 1.25 (cdr (assoc 42 dra))))(assoc 42 dra) dra)) 
      (entmod dra) 
      (entmake (list '(0 . "TEXT")'(8 . "DIM")'(10 0.0 0.0 0.0)(cons 40 (* scl 5.0))'(62 . 3)'(72 . 4)(cons 11 (mapcar '+ (mapcar (function (lambda (x)(* scl x))) pqy) snappnt))'(1 . "其余"))) 
      (setq loop nil) 
    ) 
  ) 
) 
(defun do_right() 
  (setq loop nil) 
  (entdel ename) 
) 
(defun do_move() 
  (setq snappnt (cadr code)) 
  (entdel ename) 
  (setq nearpnt (osnap snappnt "nea")) 
  (if nearpnt 
    (progn 
      (setq ang (angle nearpnt snappnt)) 
      (cond 
        ( 
          (and (>= ang (/ pi 6.0))(<= ang pi)) 
          (setq ang (- ang (/ pi 2.0))) 
          (entdel era) 
          (setq ename era) 
          (setq dra (subst (cons 10 nearpnt)(assoc 10 dra) dra)) 
          (setq nearpnt nil) 
          (setq dra (subst (cons 50 ang)(assoc 50 dra) dra)) 
          (entmod dra) 
        ) 
        ( 
          (or (= ang 0.0)(and (> ang (* (/ pi 6.0) 7.0))(< ang (* pi 2.0)))) 
          (setq ang (+ ang (/ pi 2.0))) 
          (entdel erb) 
          (setq ename erb) 
          (setq drb (subst (cons 10 nearpnt)(assoc 10 drb) drb)) 
          (setq nearpnt nil) 
          (setq drb (subst (cons 50 ang)(assoc 50 drb) drb)) 
          (entmod drb) 
        ) 
        (T 
          (entdel era) 
          (setq ename era) 
          (setq nearpnt nil) 
        ) 
      ) 
    ) 
    (progn 
      (entdel era) 
      (setq ename era) 
      (setq dra (subst (cons 10 snappnt)(assoc 10 dra) dra)) 
      (setq dra (subst (cons 50 0.0)(assoc 50 dra) dra)) 
      (entmod dra) 
      (setq nearpnt nil) 
    ) 
  ) 
)

Free-Lancer · 发表于 2014-8-22 11:04:49

需要 DCL 在 Support 路径

lucas3 · 发表于 2014-8-22 12:37:22

Free-Lancer 发表于 2014-8-22 11:04
需要 DCL 在 Support 路径

一般用lisp写的对话框不是在temp文件夹吗？越来越搞不懂了，您能拿上面这个程序改一下吗？

Free-Lancer · 发表于 2014-8-22 15:17:22

lucas3 发表于 2014-8-22 12:37
一般用lisp写的对话框不是在temp文件夹吗？越来越搞不懂了，您能拿上面这个程序改一下吗？

一般情况 DCL 是独立文件，加载 Lisp 时 DCL 需在 Support 路径，也可以将 lisp 和 DCL 一起编译为一个 vlx

你这个程序的 DCL 呢？

lucas3 · 发表于 2014-8-22 15:33:51

Free-Lancer 发表于 2014-8-22 15:17
一般情况 DCL 是独立文件，加载 Lisp 时 DCL 需在 Support 路径，也可以将 lisp 和 DCL 一起编译为一个 v ...

回大师，ＤＣＬ在５楼　，我曾经试过将lisp与DCL打包成一个vlx文件使用，结果无法正常使用，后来将DCL拷贝一份到支持路径下就可以使用了，这种问题在明经有也人提出过（http://bbs.mjtd.com/thread-100241-1-1.html )　所示想学习，最好能把dcl写进lisp……

Free-Lancer · 发表于 2014-8-22 15:56:21

lucas3 发表于 2014-8-22 15:33
回大师，ＤＣＬ在５楼　，我曾经试过将lisp与DCL打包成一个vlx文件使用，结果无法正常使用，后来将DCL拷 ...

你这里面还用到了 (findfile "rough.slb")

lucas3 · 发表于 2014-8-22 16:26:18

Free-Lancer 发表于 2014-8-22 15:56
你这里面还用到了 (findfile "rough.slb")

是的，这是风版的程序，上面贴出了原贴地址，我一起上传上来吧

lucas3 · 发表于 2014-8-22 17:27:30

Free-Lancer 发表于 2014-8-22 15:56
你这里面还用到了 (findfile "rough.slb")

大师帮忙改下，顺便学习一下，{:soso_e100:}谢谢！

csharp · 发表于 2014-8-22 17:45:05

lucas3 发表于 2014-8-22 17:27
大师帮忙改下，顺便学习一下，谢谢！

选择专家模式，直接编译就可以使用，将 slb 和 vlx 放到 Support 目录

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

[每日一码] 竖线改变

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

点评

点评

点评

评分

点评

点评

点评

点评

点评

点评

点评

点评

点评