【求助】请大侠门来编一个这样的程序！
本帖最后由 daidong013 于 2011-6-25 12:10 编辑请大侠门编一个这样的程序！ 本帖最后由 zhynt 于 2011-6-25 11:33 编辑
看不到图！！！ 回复 zhynt 的帖子
初次发图没发上去不好意思！~呵呵！~~ http://bbs.mjtd.com/thread-87683-1-2.html
看九楼 回复 zhynt 的帖子
九楼这个只是简单的等分工具，没有生成交叉的X线，希望大侠可以编一个！~~期待中！~ 本帖最后由 ljpnb 于 2011-6-25 14:37 编辑
简单版的：
(defun c:test (/ p1 p2 p3 p4 n os dx dy xlst ylst l p5 p6 ent1 ent2 ent3)
(setq p1 (getpoint "\n方框第一个角:"))
(setq p2 (getcorner p1 ":\n方框另一个角:"))
(setq n (getint ":\n输入等分数:"))
(setq os (getvar "osmode"))
(setvar "osmode" 0)
(setvar "cmdecho" 0)
(command "undo" "g")
(setq xlst (vl-sort (list (car p1) (car p2)) '<))
(setq ylst (vl-sort (list (cadr p1) (cadr p2)) '<))
(setq dx (- (nth 1 xlst) (nth 0 xlst)))
(setq dy (- (nth 1 ylst) (nth 0 ylst)))
(if (> dx dy)
(progn
(setq p1 (list (nth 1 xlst) (nth 0 ylst))
;;右下角
p2
(polar p1 pi dx)
;;左下角
p3
(polar p2 (* pi 0.5) dy)
;;左上角
p4
(polar p1 (* pi 0.5) dy)
;;右上角
)
(setq l dx)
)
(progn
(setq p1 (list (nth 1 xlst) (nth 1 ylst))
;;右上角
p2
(polar p1 (* pi 1.5) dy)
;;右下角
p3
(polar p2 pi dx)
;;左下角
p4
(polar p1 pi dx)
;;左上角
)
(setq l dy)
)
)
(setq p5 (polar p2 (angle p2 p1) (/ l n)))
(setq p6 (polar p3 (angle p2 p1) (/ l n)))
;;;(command "line" p1 p2 p3 p4 "")
(command "line" p2 p6 "")
(setq ent1 (entlast))
(command "line" p6 p5 "")
(setq ent2 (entlast))
(command "line" p5 p3 "")
(setq ent3 (entlast))
(if (> dx dy)
(progn
(command "-array" ent1 ent3 "" "r" 1 n (/ dx n))
(command "-array" ent2 "" "r" 1 (1- n) (/ dx n))
)
(progn
(command "-array" ent1 ent3 "" "r" n 1 (/ dy n))
(command "-array" ent2 "" "r" (1- n) 1 (/ dy n))
)
)
(command "undo" "e")
(setvar "osmode" os)
(setvar "cmdecho" 1)
(princ)
)
;拉框N等分 明经 ZZXXQQ 2011.6.25
(defun c:tt ()
(setvar "CMDECHO" 0)
(setq oldos (getvar "OSMODE"))
(while (and (setq n (getint "\n等分数 :"))
(setq p1 (getpoint "\n第一角点 :"))
(setq p2 (getcorner p1 "\n另一角点 :")))
(setvar "OSMODE" 0)
(setq dx (abs (- (car p2) (car p1)))
dy (abs (- (cadr p2) (cadr p1))))
(setq ptm (list (min (car p1) (car p2)) (min (cadr p1) (cadr p2)))
p2 (list (max (car p1) (car p2)) (max (cadr p1) (cadr p2)))
p1 ptm)
(if (> dx dy) (progn
(setq dd (/ dx n))
(repeat n
(setq p3 (polar p1 0 dd)
p4 (polar p1 (/ pi 2) dy)
p5 (polar p4 0 dd))
(command "_.LINE" p1 p3 p4 p5 p1 p4 "")
(setq p1 p3)
)
) (progn
(setq dd (/ dy n))
(repeat n
(setq p3 (polar p1 (/ pi 2) dd)
p4 (polar p1 0 dx)
p5 (polar p3 0 dx))
(command "_.LINE" p1 p3 p4 p5 p1 p4 "")
(setq p1 p3)
)
))
(command "_.LINE" p3 p5 "")
(setvar "OSMODE" oldos)
)
(setvar "CMDECHO" 1)
(princ)
)
本帖最后由 daidong013 于 2011-6-25 14:01 编辑
回复 ljpnb 的帖子
不错不错！~非常感谢大侠！~建议简单版的在完成后可以把四边的线去掉！~~
这样就不会有重线的问题了！~~
希望大侠还可以做个升级版的，这样如果是进缩20mm的话四边的线就可以保留了！~~~
回复 ZZXXQQ 的帖子
非常感谢大侠！~~画完后感觉还是6楼的好用些，因为四面的线都是段开的！~~
针对于简单版的最好是矩形的四面都不要线。 本帖最后由 zhynt 于 2011-6-25 14:39 编辑
;;升级版的：
(defun err (s)
(if (and
(/= s "console break")
(/= s "Function cancelled")
(/= s "quit/exit abort")
)
(progn
(setvar "LUPREC" oldlup)
(setvar "LUNITS" oldlun)
(setvar "osmode" oldos)
(setvar "cmdecho" oldcmd)
(setvar "clayer" oldlay)
(setq *error* olderr)
(princ (strcat "\n程序出错或用户退出:" s))
)
)
)
(defun c:ldf (/ wk_pt1 wk_pt2 wk_pt3 wk_pt4
nk_pt1 nk_pt2 nk_pt3 nk_pt4 olds
oldcmd oldlup oldlay nk_n nk_kd
ptax ptay ptaz ptbx ptby
ptbz l_pt1_pt4 l_pt2_pt3 l_n ang_pt1_pt4
)
(setq oldos (getvar "osmode"))
(if (< oldos 16384)
(setvar "osmode" (+ oldos 16384))
)
(setq oldcmd (getvar "cmdecho")
oldlun (getvar "LUNITS")
oldlup (getvar "LUPREC")
olderr *error*
*error* err
oldlay (getvar "clayer")
)
(setvar "cmdecho" 0)
(setvar "LUPREC" 8)
(setvar "LUNITS" 2)
(if (= (TBLOBJNAME "LAYER" "wk_line") nil)
(command "layer" "m" "wk_line" "c" "2" "" "")
)
(if (= (TBLOBJNAME "LAYER" "nk_line") nil)
(command "layer" "m" "nk_line" "c" "1" "" "")
)
(setvar "clayer" "wk_line")
(setq wk_pt1 (getpoint "\n指定第一角点")
wk_pt3 (getcorner wk_pt1 "\n指定第二角点:")
nk_n (getint "\n请输入大于零的等分数:")
wk_kd(getreal "\n输入边框宽度<20mm>:")
)
(if (= wk_kd nil)
(setq wk_kd 20.0)
)
(setq ptax (car wk_pt1)
ptay (cadr wk_pt1)
ptbx (car wk_pt3)
ptby (cadr wk_pt3)
)
(setq wk_pt2 (list ptax ptby)
wk_pt4 (list ptbx ptay)
)
(setq nk_pt1
(polar wk_pt1
(/ (- (angle wk_pt1 wk_pt2) (angle wk_pt1 wk_pt4)) 2.0)
(* wk_kd (* 2 (sqrt 2)))
)
)
(setq nk_pt3
(polar wk_pt3
(+ (/ (- (angle wk_pt3 wk_pt2) (angle wk_pt3 wk_pt4)) 2.0)
(/ (* pi 3.0) 2.0)
)
(* wk_kd (* 2 (sqrt 2)))
)
)
(setq ptax (car nk_pt1)
ptay (cadr nk_pt1)
ptbx (car nk_pt3)
ptby (cadr nk_pt3)
)
(setq nk_pt2 (list ptax ptby)
nk_pt4 (list ptbx ptay)
)
(setq l_pt1_pt4 (distance nk_pt1 nk_pt4)
l_pt1_pt2 (distance nk_pt1 nk_pt2)
ang_pt1_pt4 (angle nk_pt1 nk_pt4)
l_n (/ l_pt1_pt4 nk_n)
)
(command "_.rectang" wk_pt1 wk_pt3)
(setvar "clayer" "nk_line")
(command "_.rectang" nk_pt1 nk_pt3)
(setq n_pt1 nk_pt1
n_pt2 nk_pt2
)
(repeat (- nk_n 1)
(setq n_pt3 (polar n_pt1 ang_pt1_pt4 l_n)
n_pt4 (polar n_pt3 (+ ang_pt1_pt4 (/ pi 2.0)) l_pt1_pt2)
)
(command "_.line" n_pt1 n_pt4 n_pt3 n_pt2 "")
(setq n_pt1 n_pt3
n_pt2 n_pt4
)
)
(command "_.line" n_pt1 nk_pt3 "")
(command "_.line" nk_pt4 n_pt2 "")
(setvar "osmode" oldos)
(setvar "cmdecho" oldcmd)
(setvar "clayer" oldlay)
(setvar "LUPREC" oldlup)
(setvar "LUNITS" oldlun)
(princ)
)