[源码]动态粗糙度
本帖最后由 cabinsummer 于 2016-12-24 15:08 编辑只贴出源码，原理详见我以前的帖子http://bbs.mjtd.com/thread-90666-1-1.html
roughness:dialog
{
label="粗糙度";
spacer;
:row
{
:column
{
:image_button
{
key = "RM";
aspect_ratio = 1;
width = 8;
fixed_width= true;
color = graphics_background;
allow_accept = true;
}
:image_button
{
key = "UN";
aspect_ratio = 1;
width = 8;
fixed_width= true;
color = graphics_background;
allow_accept = true;
}
:image_button
{
key = "BS";
aspect_ratio = 1;
width = 8;
fixed_width= true;
color = graphics_background;
allow_accept = true;
}
}
:list_box
{
key="RV";
value=8;
width=16;
height=14;
allow_accept=true;
}
}
:errtile
{
width=18;
}
ok_cancel;
}
(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)
)
)
)
命令：rough
按a键数值增加，按s键数值减少
本帖最后由 langjs 于 2022-5-27 11:18 编辑
这个程序真好用，加入我的工具箱了。修改了一下，把幻灯片和对话框整合到sp里了
;;;; ****************************************************************
;;; *风之影粗糙度绘制，langjs修改
;;; ****************************************************************
(defun c:ccd (/ $value a ang b bname c code dcl_pt dcl_re dclname do dra drb edata ename era erb f kname llist loop myerr
nearpnt olderr os p00 p1d p1u p2d p2u p3d p3u pcd pcu pqy prcs ptd ptu ra rb scl snappnt value x
)
(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)
)
(defun image (a b c)
(if (= a 0)
(progn
(start_image "RM")
(fill_image 0 0 48 48 4)
(vector_image 20 40 40 5 5)
(vector_image 20 40 12 26 5)
(vector_image 28 26 12 26 5)
(vector_image 20 41 40 6 5)
(vector_image 20 41 12 27 5)
(vector_image 28 27 12 27 5)
(end_image)
)
(progn
(start_image "RM")
(fill_image 0 0 48 48 5)
(vector_image 20 40 40 5 7)
(vector_image 20 40 12 26 7)
(vector_image 28 26 12 26 7)
(vector_image 20 41 40 6 7)
(vector_image 20 41 12 27 7)
(vector_image 28 27 12 27 7)
(end_image)
)
)
(if (= b 0)
(progn
(start_image "UN")
(fill_image 0 0 48 48 4)
(vector_image 20 40 40 5 5)
(vector_image 20 40 12 26 5)
(vector_image 20 41 40 6 5)
(vector_image 20 41 12 27 5)
(vector_image 18 26 23 26 5)
(vector_image 17 27 18 27 5)
(vector_image 23 27 24 27 5)
(vector_image 16 28 17 28 5)
(vector_image 24 28 25 28 5)
(vector_image 16 29 16 32 5)
(vector_image 25 29 25 32 5)
(vector_image 16 33 17 33 5)
(vector_image 24 33 25 33 5)
(vector_image 17 34 18 34 5)
(vector_image 23 34 24 34 5)
(vector_image 18 35 23 35 5)
(end_image)
)
(progn
(start_image "UN")
(fill_image 0 0 48 48 5)
(vector_image 20 40 40 5 7)
(vector_image 20 40 12 26 7)
(vector_image 20 41 40 6 7)
(vector_image 20 41 12 27 7)
(vector_image 18 26 23 26 7)
(vector_image 17 27 18 27 7)
(vector_image 23 27 24 27 7)
(vector_image 16 28 17 28 7)
(vector_image 24 28 25 28 7)
(vector_image 16 29 16 32 7)
(vector_image 25 29 25 32 7)
(vector_image 16 33 17 33 7)
(vector_image 24 33 25 33 7)
(vector_image 17 34 18 34 7)
(vector_image 23 34 24 34 7)
(vector_image 18 35 23 35 7)
(end_image)
)
)
(if (= c 0)
(progn
(start_image "BS")
(fill_image 0 0 48 48 4)
(vector_image 20 40 40 5 5)
(vector_image 20 40 12 26 5)
(vector_image 20 41 40 6 5)
(vector_image 20 41 12 27 5)
(end_image)
)
(progn
(start_image "BS")
(fill_image 0 0 48 48 5)
(vector_image 20 40 40 5 7)
(vector_image 20 40 12 26 7)
(vector_image 20 41 40 6 7)
(vector_image 20 41 12 27 7)
(end_image)
)
)
)
(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) (cons 7 (getvar "DIMTXSTY")) '(8 . "DIM") '(40 . 2.5) '
(62 . 3) '(72 . 4) (cons 1 value)
)
)
(cond
((= prcs 1)
(entmake (list '(0 . "LINE") '(62 . 4) (cons 10 p1u) (cons 11 p2u) '(8 . "DIM")))
)
((= prcs 2)
(entmake (list '(0 . "CIRCLE") '(62 . 4) (cons 10 pcu) '(40 . 1.33) '(8 . "DIM")))
)
)
(entmake (list '(0 . "LINE") '(62 . 4) (cons 10 p00) (cons 11 p2u) '(8 . "DIM")))
(entmake (list '(0 . "LINE") '(62 . 4) (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) (cons 7 (getvar "DIMTXSTY")) '(8 . "DIM") '(40 . 2.5) '
(62 . 3) '(72 . 4) (cons 1 value)
)
)
(cond
((= prcs 1)
(entmake (list '(0 . "LINE") '(62 . 4) (cons 10 p1d) (cons 11 p2d) '(8 . "DIM")))
)
((= prcs 2)
(entmake (list '(0 . "CIRCLE") '(62 . 4) (cons 10 pcd) '(40 . 1.33) '(8 . "DIM")))
)
)
(entmake (list '(0 . "LINE") '(62 . 4) (cons 10 p00) (cons 11 p2d) '(8 . "DIM")))
(entmake (list '(0 . "LINE") '(62 . 4) (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") (cons 7 (getvar "DIMTXSTY")) '(8 . "DIM") '(10 0.0 0.0 0.0) (cons 40 (* scl 4.0))
(cons 41 0.8) '(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)
)
)
)
(setvar "cmdecho" 0)
(vl-load-com)
(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 dclname (vl-filename-mktemp "rough.dcl")
f (open dclname "w")
)
(write-line "roughness:dialog{ label=\"风之影粗糙度\"; spacer; " f)
(write-line " :row { :column {" f)
(write-line ":image_button { key = \"RM\"; aspect_ratio = 1; width = 8; fixed_width = true; color = graphics_background; allow_accept = true; }"
f
)
(write-line ":image_button { key = \"UN\"; aspect_ratio = 1; width = 8; fixed_width = true; color = graphics_background; allow_accept = true; } "
f
)
(write-line ":image_button { key = \"BS\"; aspect_ratio = 1; width = 8; fixed_width = true; color = graphics_background; allow_accept = true; } } "
f
)
(write-line ":list_box { key=\"RV\"; value=8; width=16; height=14; allow_accept=true; } } " f)
(write-line ":errtile { width=18; } ok_cancel;}" f)
(close f)
(setq dcl_re (load_dialog dclname))
(new_dialog "roughness" dcl_re "" dcl_pt)
(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)
(image 0 0 0)
(set_tile "RV" "8")
(set_tile "error" (strcat "粗糙度为 Ra3.2"))
(action_tile "RM" "(image 1 0 0) (setq prcs 1)")
(action_tile "UN" "(image 0 1 0)(setq prcs 2)")
(action_tile "BS" "(image 0 0 1)(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 dcl_re)
(vl-file-delete dclname)
(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 '(-9.0 3.0 0.0))
(create_ra)
(create_rb)
(entdel erb)
(prompt "\n选择插入点，增加，减小：")
(setq ename era)
(setq loop t)
(while loop
(setq code (grread t 15 0))
(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)
)
楼主的工具 总是那么实用都是精品 程序提前在我的群200499529中共享。 好程序
一个字
很好 本帖最后由 仲文玉 于 2011-12-19 16:28 编辑
支持风之影
群：200499529已满，可加入新超级群：62555795 好强劲的风啊！ 字高如果能为当前标注样式的字体与字高是不是会更完美些呢？ 强，程序很人性化了 本帖最后由 jfxia 于 2012-1-5 20:28 编辑
楼主，我加载你的程序经常列死机，不知怎么回事
抱歉，，不好意思，是因为找不到SLB文件，所以死机
但如找不到能自动中断就好点，
谢楼主分享
jfxia 发表于 2012-1-5 20:16 static/image/common/back.gif
楼主，我加载你的程序经常列死机，不知怎么回事
源码都给你了。别人用都没问题，好好检查一下自己的CAD 一个字
好程序
很好用