等分矩形
(defun mkrec (pt n a h a1 h1 k1 k2)(if k1
(ifk2
(repeat n
(entmake
(list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 4)
'(70 . 1)
'(62 . 3)
(cons 10
(setq pt (mapcar '+ (list (* 0.5 dis) (* 0.5 dis)) pt))
)
(cons 10 (setq pt (mapcar '+ (list 0 h) pt)))
(cons 10 (setq pt (mapcar '+ (list a1 0) pt)))
(cons 10 (setq pt (mapcar '+ (list 0 (- h)) pt)))
)
)
(setq pt (mapcar '+ (list (* 0.5 dis) (* -0.5 dis)) pt))
)
(repeat n
(entmake
(list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 4)
'(70 . 1)
'(62 . 3)
(cons 10
(setq pt (mapcar '+ (list (* 0.5 dis) (* 0.5 dis)) pt))
)
(cons 10 (setq pt (mapcar '+ (list a 0) pt)))
(cons 10 (setq pt (mapcar '+ (list 0 h1) pt)))
(cons 10 (setq pt (mapcar '+ (list (- a) 0) pt)))
)
)
(setq pt (mapcar '+ (list (* -0.5 dis) (* 0.5 dis)) pt))
)
)
(ifk2
(repeat n
(grvecs
(list1
(setq pt (mapcar '+ (list (* 0.5 dis) (* 0.5 dis)) pt))
(setq pt (mapcar '+ (list 0 h) pt))
1
pt
(setq pt (mapcar '+ (list a1 0) pt))
1
pt
(setq pt (mapcar '+ (list 0 (- h)) pt))
1
pt
(mapcar '+ (list (- a1) 0) pt)
)
)
(setq pt (mapcar '+ (list (* 0.5 dis) (* -0.5 dis)) pt))
)
(repeat n
(grvecs
(list1
(setq pt (mapcar '+ (list (* 0.5 dis) (* 0.5 dis)) pt))
(setq pt (mapcar '+ (list a 0) pt))
1
pt
(setq pt (mapcar '+ (list 0 h1) pt))
1
pt
(setq pt (mapcar '+ (list (- a) 0) pt))
1
pt
(mapcar '+ (list 0 (- h1)) pt)
)
)
(setq pt (mapcar '+ (list (* -0.5 dis) (* 0.5 dis)) pt))
)
)
)
)
(defun c:tt (/ dis n pt ent minpt maxpt x1 x2 y1 y2 a h a1 h1 code loop pt0)
(vl-load-com)
(setvar "cmdecho" 0)
(or (setq dis (getdist "\n请输入格子间距<10>："))
(setq dis 10)
)
(or (setq n (getint "\n请输入要等分的个数<3>："))
(setq n 3)
)
(setq pt (getpoint "\n请选择矩形框你一点："))
(command "boundary" pt "")
(setq ent (entlast))
(vla-GetBoundingBox
(vlax-ename->vla-object ent)
'minpt
'maxpt
)
(setqminpt (vlax-safearray->list minpt)
maxpt (vlax-safearray->list maxpt)
)
(entdel ent)
(setqx1 (car minpt)
x2 (car maxpt)
y1 (cadr minpt)
y2 (cadr maxpt)
a(- x2 x1)
h(- y2 y1)
a1 (/ (- a (* dis n)) n)
h1 (/ (- h (* dis n)) n)
)
(setq loop t)
(while loop
(setq code (setq code (grread T 8)))
(cond ((= (car code) 5)
(setq pt0 (cadr code))
(redraw)
(grdraw pt pt0 1)
(mkrec minpt
n
(- a dis)
(- h dis)
a1
h1
nil
(or (< (* 0.25 pi) (angle pt pt0) (* 0.75 pi))
(< (* 1.25 pi) (angle pt pt0) (* 1.75 pi))
)
)
)
((= (car code) 3)
(setq pt0 (cadr code))
(redraw)
(grdraw pt pt0 1)
(mkrec minpt
n
(- a dis)
(- h dis)
a1
h1
nil
(or (< (* 0.25 pi) (angle pt pt0) (* 0.75 pi))
(< (* 1.25 pi) (angle pt pt0) (* 1.75 pi))
)
)
(setq loop nil)
)
(t nil)
)
)
(redraw)
(mkrec minpt
n
(- a dis)
(- h dis)
a1
h1
t
(or (< (* 0.25 pi) (angle pt pt0) (* 0.75 pi))
(< (* 1.25 pi) (angle pt pt0) (* 1.75 pi))
)
)
(princ)
)
本帖最后由 kkq0305 于 2021-9-5 01:49 编辑
(defun mkrec (pt n a h a1 h1 k1 k2)
(if k1
(if k2
(repeat n
(entmake
(list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 4)
'(70 . 1)
'(62 . 3)
(cons 10
(setq pt (mapcar '+ (list 0 0) pt))
)
(cons 10 (setq pt (mapcar '+ (list 0 h) pt)))
(cons 10 (setq pt (mapcar '+ (list a1 0) pt)))
(cons 10 (setq pt (mapcar '+ (list 0 (- h)) pt)))
)
)
(setq pt (mapcar '+ (list dis 0) pt))
)
(repeat n
(entmake
(list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 4)
'(70 . 1)
'(62 . 3)
(cons 10
(setq pt (mapcar '+ (list 0 0) pt))
)
(cons 10 (setq pt (mapcar '+ (list a 0) pt)))
(cons 10 (setq pt (mapcar '+ (list 0 h1) pt)))
(cons 10 (setq pt (mapcar '+ (list (- a) 0) pt)))
)
)
(setq pt (mapcar '+ (list 0 dis) pt))
)
)
(if k2
(repeat n
(grvecs
(list 1
(setq pt (mapcar '+ (list 0 0) pt))
(setq pt (mapcar '+ (list 0 h) pt))
1
pt
(setq pt (mapcar '+ (list a1 0) pt))
1
pt
(setq pt (mapcar '+ (list 0 (- h)) pt))
1
pt
(mapcar '+ (list (- a1) 0) pt)
)
)
(setq pt (mapcar '+ (list dis 0) pt))
)
(repeat n
(grvecs
(list 1
(setq pt (mapcar '+ (list 0 0) pt))
(setq pt (mapcar '+ (list a 0) pt))
1
pt
(setq pt (mapcar '+ (list 0 h1) pt))
1
pt
(setq pt (mapcar '+ (list (- a) 0) pt))
1
pt
(mapcar '+ (list 0 (- h1)) pt)
)
)
(setq pt (mapcar '+ (list 0 dis) pt))
)
)
)
)
(defun c:tt (/ dis n pt ent minpt maxpt x1 x2 y1 y2 a h a1 h1 code loop pt0)
(vl-load-com)
(setvar "cmdecho" 0)
(or (setq dis (getdist "\n请输入格子间距<10>："))
(setq dis 10)
)
(or (setq n (getint "\n请输入要等分的个数<3>："))
(setq n 3)
)
(setq pt (getpoint "\n请选择矩形框你一点："))
(command "boundary" pt "")
(setq ent (entlast))
(vla-GetBoundingBox
(vlax-ename->vla-object ent)
'minpt
'maxpt
)
(setq minpt (vlax-safearray->list minpt)
maxpt (vlax-safearray->list maxpt)
)
(entdel ent)
(setq x1 (car minpt)
x2 (car maxpt)
y1 (cadr minpt)
y2 (cadr maxpt)
a(- x2 x1)
h(- y2 y1)
a1 (/ (- a (* dis (1- n))) n)
h1 (/ (- h (* dis (1- n))) n)
)
(setq loop t)
(while loop
(setq code (setq code (grread T 8)))
(cond ((= (car code) 5)
(setq pt0 (cadr code))
(redraw)
(grdraw pt pt0 1)
(mkrec minpt
n
a
h
a1
h1
nil
(or (< (* 0.25 pi) (angle pt pt0) (* 0.75 pi))
(< (* 1.25 pi) (angle pt pt0) (* 1.75 pi))
)
)
)
((= (car code) 3)
(setq pt0 (cadr code))
(redraw)
(grdraw pt pt0 1)
(mkrec minpt
n
a
h
a1
h1
nil
(or (< (* 0.25 pi) (angle pt pt0) (* 0.75 pi))
(< (* 1.25 pi) (angle pt pt0) (* 1.75 pi))
)
)
(setq loop nil)
)
(t nil)
)
)
(redraw)
(mkrec minpt
n
a
h
a1
h1
t
(or (< (* 0.25 pi) (angle pt pt0) (* 0.75 pi))
(< (* 1.25 pi) (angle pt pt0) (* 1.75 pi))
)
)
(princ)
) kkq0305 发表于 2021-9-5 01:47
烦请大师帮忙改下，我改的出错
(defun getcorn (/ corn-get corn-name corn-lst corn-ss corn-xh corn-bd)
(princ "\n点取区域")
(setq corn-xh t)
(while corn-xh
(setq corn-get (grread 1 7 0)) ;把当前的转入设备的值赋给变量
(cond
((= 5 (car corn-get)) ;mousemove
(setq corn-lst nil)
(setq corn-name (4-line corn-get fp))
;画出4条直线，并返回每条线的起点终点
(mapcar
'(lambda (x)
(setq
corn-ss (ssget
"c" ;选择每条直线相交的图元，块除外
(cadr x)
(caddr x)
'((0 . "LWPOLYLINE,LINE"))
)
)
(mapcar '(lambda (y) (ssdel (car y) corn-ss)) corn-name)
;从选择集去除辅助线
(redraw)
(if (> (sslength corn-ss) 0)
(setq
corn-lst (cons (All-inters (car x) corn-ss) corn-lst)
)
;所有交点的表
)
)
corn-name
)
(setq corn-lst (reverse corn-lst))
(mapcar '(lambda (x) (entdel (car x))) corn-name) ;删除4条直线
(setq corn-bd (Lately-pt corn-lst))
(redraw)
(display corn-bd)
)
((= 3 (car corn-get)) ;变量为3开头时为点击左键
(setqcorn-xh nil)
)
((= 11 (car corn-get)) ;rightdown
(setq corn-bd nil corn-xh nil)
)
)
)
(redraw)
corn-bd
)
;;说明:判断表是不是4个元素
(defun Lately-pt (lst / min-x max-x min-y max-y)
(if (= (length lst) 4)
(progn
(setq max-y (car (vl-sort (mapcar 'cadr (nth 0 lst)) '<)))
(setq min-y (car (vl-sort (mapcar 'cadr (nth 1 lst)) '>)))
(setq min-x (car (vl-sort (mapcar 'car (nth 2 lst)) '>)))
(setq max-x (car (vl-sort (mapcar 'car (nth 3 lst)) '<)))
(list (list min-x min-y 0.0) (list max-x max-y 0.0))
)
)
)
;;说明:以鼠标为起点绘制4条直线
;;参数:get:当前鼠标坐标
;;参数:lst:当前屏幕坐标
;;返回:lst 4个图元名+起点+终点上下左右
(defun 4-line (get lst / line_name_s
line_name_x line_name_y line_name_z
pt1 pt2 pt3 pt4 pt5
)
(setq pt5 (cadr get))
;纵向直线上
(setq line_name_s
(entmakex
(list
'(0 . "LINE")
(cons 10 (trans pt5 1 0))
(cons
11
(trans (setq pt1 (list (caadr get) (cadadr (lst))))
1
0
)
)
)
)
)
;纵向直线下
(setq line_name_x
(entmakex
(list
'(0 . "LINE")
(cons 10 (trans pt5 1 0))
(cons
11
(trans (setq pt2 (list (caadr get) (cadar (lst))))
1
0
)
)
)
)
)
;横向直线左
(setq line_name_z
(entmakex
(list
'(0 . "LINE")
(cons 10 (trans pt5 1 0))
(cons
11
(trans (setq pt3 (list (caar (lst)) (cadadr get)))
1
0
)
)
)
)
)
;横向直线右
(setq line_name_y
(entmakex
(list
'(0 . "LINE")
(cons 10 (trans pt5 1 0))
(cons
11
(trans (setq pt4 (list (caadr (lst)) (cadadr get)))
1
0
)
)
)
)
)
(list
(list line_name_s pt5 pt1)
(list line_name_x pt5 pt2)
(list line_name_z pt5 pt3)
(list line_name_y pt5 pt4)
)
)
;屏幕两对角坐标
(defun fp (/ c03 c08 c04 c05 c07 c06 c09 c01 c02)
(setq c03 (getvar "viewctr")
c03 (trans c03 1 2)
c08 (getvar "viewsize")
c04 (getvar "screensize")
c07 (car c04)
c06 (cadr c04)
c09 (/ (* c08 c07) c06)
c01 (list (- (car c03) (* 0.5 c09)) (- (cadr c03) (* 0.5 c08)))
c02 (list (+ (car c03) (* 0.5 c09)) (+ (cadr c03) (* 0.5 c08)))
c01 (trans c01 2 1)
c02 (trans c02 2 1)
)
(list c01 c02)
)
(defun All-inters
(name ss / All-inters-pt All-inters-lst All-inters-xh)
(setq All-inters-xh 0)
(repeat (sslength ss)
(if (setq All-inters-pt
(tt:TwoEntsInters
name
(ssname ss All-inters-xh)
0
)
)
(setq All-inters-lst (append All-inters-pt All-inters-lst))
)
(setq All-inters-xh (1+ All-inters-xh))
)
All-inters-lst
)
(defun c:tt (/ dis n pt ent minpt maxpt x1 x2 y1 y2 a h a1 h1 code loop pt0)
(vl-load-com)
(setvar "cmdecho" 0)
(or (setq dis (getdist "\n请输入格子间距<18>："))
(setq dis 18)
)
(or (setq n (getint "\n请输入要等分的个数<3>："))
(setq n 3)
)
(setq pt (getpoint "\n请选择矩形框你一点："))
(command "boundary" pt "")
(setq ent (entlast))
(vla-GetBoundingBox
(vlax-ename->vla-object ent)
; 'minpt
; 'maxpt
)
;(setq minpt (vlax-safearray->list minpt)
; maxpt (vlax-safearray->list maxpt)
)
(entdel ent)
(setq x1 (car minpt)
; x2 (car maxpt)
;y1 (cadr minpt)
;y2 (cadr maxpt)
a(- x2 x1)
h(- y2 y1)
a1 (/ (- a (* dis (1- n))) n)
h1 (/ (- h (* dis (1- n))) n)
)
(setq loop t)
(while loop
(setq code (setq code (grread T 8)))
(cond ((= (car code) 5)
(setq pt0 (cadr code))
(redraw)
(grdraw pt pt0 1)
;(mkrec minpt
n
a
h
a1
h1
nil
(or (< (* 0.25 pi) (angle pt pt0) (* 0.75 pi))
(< (* 1.25 pi) (angle pt pt0) (* 1.75 pi))
)
)
)
((= (car code) 3)
(setq pt0 (cadr code))
(redraw)
(grdraw pt pt0 1)
; (mkrec minpt
n
a
h
a1
h1
nil
(or (< (* 0.25 pi) (angle pt pt0) (* 0.75 pi))
(< (* 1.25 pi) (angle pt pt0) (* 1.75 pi))
)
)
(setq loop nil)
)
(t nil)
)
)
(redraw)
;(mkrec minpt
n
a
h
a1
h1
t
(or (< (* 0.25 pi) (angle pt pt0) (* 0.75 pi))
(< (* 1.25 pi) (angle pt pt0) (* 1.75 pi))
)
)
(princ)
) 前排:lol:lol:lol 板凳端上，，:lol谢谢楼主分享 漂亮的很哦 膜拜大佬，感谢分享，收下学习了 谢谢楼主的分享。。。。 本帖最后由 qianyi0710 于 2021-9-5 21:00 编辑
kkq0305 发表于 2021-9-5 01:47
非常感谢，下载下来学习下，(格子间距) 要是独立直线就好。要是直线就完美了。 (defun mkrec (pt n a h a1 h1 k1 k2)
(if k1
(if k2
(repeat (1- n)
(entmake
(list
'(0 . "LINE")
(cons 10 (setq pt (mapcar '+ (list a1 0) pt)))
(cons 11 (setq pt (mapcar '+ (list 0 h) pt)))
)
)
(entmake
(list
'(0 . "LINE")
(cons 10 (setq pt (mapcar '+ (list dis 0) pt)))
(cons 11 (setq pt (mapcar '+ (list 0 (- h)) pt)))
)
)
)
(repeat (1- n)
(entmake
(list
'(0 . "LINE")
(cons 10 (setq pt (mapcar '+ (list 0 h1) pt)))
(cons 11 (setq pt (mapcar '+ (list a 0) pt)))
)
)
(entmake
(list
'(0 . "LINE")
(cons 10 (setq pt (mapcar '+ (list 0 dis) pt)))
(cons 11 (setq pt (mapcar '+ (list (- a) 0) pt)))
)
)
)
)
(if k2
(repeat n
(grvecs
(list 1
(setq pt (mapcar '+ (list 0 0) pt))
(setq pt (mapcar '+ (list 0 h) pt))
1
pt
(setq pt (mapcar '+ (list a1 0) pt))
1
pt
(setq pt (mapcar '+ (list 0 (- h)) pt))
1
pt
(mapcar '+ (list (- a1) 0) pt)
)
)
(setq pt (mapcar '+ (list dis 0) pt))
)
(repeat n
(grvecs
(list 1
(setq pt (mapcar '+ (list 0 0) pt))
(setq pt (mapcar '+ (list a 0) pt))
1
pt
(setq pt (mapcar '+ (list 0 h1) pt))
1
pt
(setq pt (mapcar '+ (list (- a) 0) pt))
1
pt
(mapcar '+ (list 0 (- h1)) pt)
)
)
(setq pt (mapcar '+ (list 0 dis) pt))
)
)
)
)
(defun c:CB (/ dis n pt ent minpt maxpt x1 x2 y1 y2 a h a1 h1 code loop pt0)
(vl-load-com)
(setvar "cmdecho" 0)
(or (setq dis (getdist "\n请输入层板厚度<18>："))
(setq dis 18)
)
(or (setq n (getint "\n请输入要等分的数<3>："))
(setq n 3)
)
(setq pt (getpoint "\n请选择矩形框内一点："))
(command "-boundary" "a" "i" "n" "" "o" "r" "" pt "")
(setq ent (entlast))
(vla-GetBoundingBox
(vlax-ename->vla-object ent)
'minpt
'maxpt
)
(setq minpt (vlax-safearray->list minpt)
maxpt (vlax-safearray->list maxpt)
)
(entdel ent)
(setq x1 (car minpt)
x2 (car maxpt)
y1 (cadr minpt)
y2 (cadr maxpt)
a(- x2 x1)
h(- y2 y1)
a1 (/ (- a (* dis (1- n))) n)
h1 (/ (- h (* dis (1- n))) n)
)
(setq loop t)
(while loop
(setq code (setq code (grread T 8)))
(cond ((= (car code) 5)
(setq pt0 (cadr code))
(redraw)
(grdraw pt pt0 1)
(mkrec minpt
n
a
h
a1
h1
nil
(or (< (* 0.25 pi) (angle pt pt0) (* 0.75 pi))
(< (* 1.25 pi) (angle pt pt0) (* 1.75 pi))
)
)
)
((= (car code) 3)
(setq pt0 (cadr code))
(redraw)
(grdraw pt pt0 1)
(mkrec minpt
n
a
h
a1
h1
nil
(or (< (* 0.25 pi) (angle pt pt0) (* 0.75 pi))
(< (* 1.25 pi) (angle pt pt0) (* 1.75 pi))
)
)
(setq loop nil)
)
(t nil)
)
)
(redraw)
(mkrec minpt
n
a
h
a1
h1
t
(or (< (* 0.25 pi) (angle pt pt0) (* 0.75 pi))
(< (* 1.25 pi) (angle pt pt0) (* 1.75 pi))
)
)
(princ)
)