沿线均布9点定位、定角集成《三领设计 V3.0 》
本帖最后由 尘缘一生 于 2024-5-27 19:45 编辑关于沿线均布，涉及不少东西，下面展示下《三领设计 v3.0》的现今集成-->
三领认为：关于沿线均布，如果不能准确定位和角度正确，就失去了开发的意义
下一步将来：三领将加定位开始点位往后定距-->OK
;;三领设计 V3.0 沿线均布9点定位---【开始】------
;by 尘缘一生QQ:15290049
(defun c:sl-alon-cure (/ ss lis nam)
(setq ss (ssget ":S"))
(setq lis (sl-ss-9pt-ang ss))
(sldis "均布间距" "间距=" "0" "12") ;取距离集成函数，返回sldis1全局变量，带有比例，自理即可
(setq nam (car (entsel "\n 请选择曲线:")))
(sl-along-cure (car lis) (cadr lis) (caddr lis) sldis1 nam)
)
;选择集(9基点)沿线均布---(一级)-----
;ss 选择 p0 ss基点 ang0 ss初始角度 dis 间距 nam 曲线
(defun sl-along-cure (ss p0 ang0 dis nam / pt ob p n m e ang)
(setq ob (en2obj nam) n 0 p (1+ (fix (/ (sllen nam) dis))) m (sslength ss)) ;SLLEN 曲线长度函数
(while (< n p)
(setq pt (vlax-curve-getPointAtDist ob (* dis n)))
(setq pt (vlax-curve-getClosestPointTo nam pt nil))
(if (> m 1)
(setq ang (+ (angle '(0.0 0.0 0.0) (vlax-curve-getFirstDeriv nam (vlax-curve-getparamatpoint nam pt))) pi2));切线的垂线角
(setq ang (angle '(0.0 0.0 0.0) (vlax-curve-getFirstDeriv nam (vlax-curve-getparamatpoint nam pt))));切线角
)
(aypercurve nam pt) ;此为曲线点位垂线辅助线
(setq e (entlast))
(command "copy" ss "" "_non" p0 "_non" pt)
(sl-ssrot (last_ent e) pt (- ang ang0))
(setq n (1+ n))
)
)
;;曲线垂线 nam曲线实体名 p曲线上点---(一级)------
(defun aypercurve (nam p / dd ang p1 p2)
(setq p (vlax-curve-getClosestPointTo nam p nil))
(setq dd (p2uu 50.0))
(setq ang (angle '(0.0 0.0 0.0) (vlax-curve-getFirstDeriv nam (vlax-curve-getparamatpoint nam p)))) ;切线
(setq p1 (polar p (+ ang pi2) dd))
(setq p2 (polar p (- ang pi2) dd))
(fy_lineformat (makeline p1 p2) "中心线" "CENTER" 0.4 6) ;画线函数
)
;选择集ss 以基点p0 旋转ang(弧度)---(一级)-----
;(sl-rot (ssget) (getpoint) (* pi 0.25))
(defun sl-ssrot (ss p0 ang / mat i o)
(setq mat (mat:rotation (trans p0 1 0) ang)) ;旋转矩阵，自理
(setq mat (vlax-tmatrix mat))
(repeat (setq i (sslength ss))
(setq o (en2obj (ssname ss (setq i (1- i)))))
(vla-transformby o mat)
)
;(sl-wzgz ss) 《三领设计》集成之 "文字归正"，可注销
(princ)
)
;;当前视口取比例值-----(一级)-----
(defun p2uu (pix)
(* pix (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE"))))
)
;;实体、选择集定9点、轴角度-----(一级)----
;;返回(ss p0 ang)
(defun sl-ss-9pt-ang (ss / bb ms1 ms2 loop p0 plis p1 p2 p3 p4 p5 p6 p7 p8 p9 ang n i nam)
(setq plis (getpt ss))
(setq plis (graham-scan plis))
(if (or (< (length plis) 3) (and (>= (length plis) 3) (<= (det (car plis) (cadr plis) (caddr plis)) 0.0)))
(setq plis (reverse plis))
)
(setq
plis (car (minarearectangle plis)) ;高飞鸟求凸包,以下求9点位
p1 (car plis)
p3 (cadr plis)
p9 (caddr plis)
p7 (cadddr plis)
p2 (sl:mid p1 p3)
p4 (sl:mid p1 p7)
p6 (sl:mid p3 p9)
p8 (sl:mid p7 p9)
p5 (sl:mid p1 p9)
)
(if (> (distance p1 p2) (distance p2 p3))
(setq ang (angle p1 p2))
(setq ang (angle p2 p3))
)
(setq ang (angle-sharp ang)) ;角度转为1,4象限
(setq ms1 "\n->定位 [逆转90度(TAB)/左下(1)/下中(2)/右下(3)/左中(4)/正中(5)/右中(6)/左上(7)/上中(8)/右上(9)/取角(A)](左键、右键、空格>定位)")
(setq p0 p5)
(setq ms2 "-->当前<正中>")
(princ (strcat ms1 ms2))
(setq loop T)
(while loop
(redraw)
(slslx p0 0) ;交叉矢量线
(grdraw-drawjt p0 (polar p0 ang (p2uu 80.0))) ;箭头矢量
(setq bb (grread T 8))
(cond
((or (= (car bb) 3) ;;左键
(= (car bb) 11);;右键设置为回车时
(= (car bb) 25);;右键设置为屏幕菜单时
(equal bb '(2 32));;空格键
)
(setq loop nil)
)
((member bb '((2 9))) ;;table 键
(setq ang (+ ang pi2))
)
((member bb '((2 65) (2 97)));;A 旋转定角
(setq ang (angle p0 (getpoint p0 "\n 定角->:")))
)
((equal bb '(2 49));; 1键
(setq p0 p1 ms2 "当前<左下>")
(princ (strcat ms1 ms2))
)
((equal bb '(2 50)) ;; 2键
(setq p0 p2 ms2 "当前<下中>")
(princ (strcat ms1 ms2))
)
((equal bb '(2 51)) ;; 3键
(setq p0 p3 ms2 "当前<右下>")
(princ (strcat ms1 ms2))
)
((equal bb '(2 52));; 4键
(setq p0 p4 ms2 "当前<左中>")
(princ (strcat ms1 ms2))
)
((equal bb '(2 53));; 5键
(setq p0 p5 ms2 "当前<正中>")
(princ (strcat ms1 ms2))
)
((equal bb '(2 54)) ;; 6键
(setq p0 p6 ms2 "当前<右中>")
(princ (strcat ms1 ms2))
)
((equal bb '(2 55)) ;; 7键
(setq p0 p7 ms2 "当前<左上>")
(princ (strcat ms1 ms2))
)
((equal bb '(2 56)) ;; 8键
(setq p0 p8 ms2 "当前<上中>")
(princ (strcat ms1 ms2))
)
((equal bb '(2 57));; 9键
(setq p0 p9 ms2 "当前<右上>")
(princ (strcat ms1 ms2))
)
)
)
(redraw)
(list ss p0 ang)
)
《三领设计 V3.0》
链接：https://pan.baidu.com/s/1tr_aurX1en3clo4H0FlwNw
提取码：v1gl
嗯，迷你的全能复制和沿线布块都可以做的完美。 lxl217114 发表于 2024-5-27 23:05
嗯，迷你的全能复制和沿线布块都可以做的完美。
你好，请问你说的全能复制和沿线布块，都是迷你的功能吗 weimeng555 发表于 2024-5-28 05:11
你好，请问你说的全能复制和沿线布块，都是迷你的功能吗
是的，没错。
继续增加，定2点均布，并与阵列集成，
;;三领设计 V3.0 沿线均布9点定位---【开始】------
;by 尘缘一生QQ:15290049
;;三领阵列----【开始】------
(defun c:sl-arry ()
(sl-arry (ssget ":S"))
)
;;选择集阵列----(一级)------
(defun sl-arry (ss / aw k1 k2 k3 k4 k5 k6 e nam lis pts p1 p2 div)
(setq
k1 "直线阵列"
k2 "环形阵列"
k3 "二维阵列"
k4 " 沿线均布 "
k5 "2P定长均布"
k6 "2P定量均布"
)
(setq aw (sl:do1ordo6 "三领阵列,均布 V3.0" k1 k2 k3 k4 k5 k6))
(if (or (= aw k4) (= aw k5) (= aw k6))
(setq lis (sl-ss-9pt-ang ss))
)
(if (or (= aw k4) (= aw k5))
(sldis "均布间距" "间距=" "0" "12")
)
(cond
((= aw k1)
(lin-arr ss)
)
((= aw k2)
(setq e (entlast))
(cir-arr ss)
(sl-wzgz (last_ent e))
)
((= aw k3)
(sed-arr ss)
)
((= aw k4)
(setq nam (car (entsel "\n 请选择曲线:")))
(sl-along-cure (car lis) (cadr lis) (caddr lis) sldis1 nam)
)
((or (= aw k5) (= aw k6))
(setq nam (car (entsel "\n 请选择曲线:")))
(setq p1 (getpoint "\n 请输入起点:")
p2 (getpoint p1 "\n 请输入终点:")
)
(if (= aw k5)
(setq pts (sl:DivdeCurve nam p1 p2 nil sldis1))
(setq div (atoi (inputbox "等分数" "?等分 " "2" "35"))
pts (sl:DivdeCurve nam p1 p2 t div)
)
)
(sl-along-2p-cure (car lis) (cadr lis) (caddr lis) pts nam)
)
)
)
;;等分曲线,返回点坐标(包含端点)----(一级)----
;;Curve = 曲线图元名 p1曲线上第一点 p2曲线上第二点
;;Flag = T 定数等分曲线 nil 定长等分曲线
;;n = 当 Flag = T 时 n 为等分数，当Flag = nil 时 n 为等分长度
;;(sl:DivdeCurve (car (entsel "\n选择曲线:")) (getpoint "\n 起点:") (getpoint "\n 终点:") T 5)
;;((2970.68 2531.75 0.0) (2975.88 2539.01 0.0) (2981.07 2546.27 0.0) (2986.26 2553.53 0.0) (2991.45 2560.79 0.0) (2996.64 2568.05 0.0))
(defun sl:DivdeCurve (curve p1 p2 flag n / d1 d2 d d0 pts)
(setq
p1 (vlax-curve-getclosestpointto Curve p1)
d1 (vlax-curve-getDistAtPoint Curve p1)
p2 (vlax-curve-getclosestpointto Curve p2)
d2 (vlax-curve-getDistAtPoint Curve p2)
)
(if Flag
(setq d (/ (- d2 d1) n))
(setq d (if (minusp (- d2 d1)) (* -1.0 n) n))
)
(setq d0 d1)
(setq pts (cons p1 pts))
(if (> d2 d1)
(while (apply '< (list (setq d0 (+ d0 d)) d2))
(setq pts (cons (vlax-curve-getPointAtDist curve d0) pts))
)
(while (apply '> (list (setq d0 (+ d0 d)) d2))
(setq pts (cons (vlax-curve-getPointAtDist curve d0) pts))
)
)
(setq pts (gps->lst-delsame (cons p2 pts)))
(reverse pts)
)
;;六键开关---------(一级)-------
;;调用形式 (sl:do1ordo6dname:对话框名称tog1:开关1 ...)
;;返回 tog1 tog2 tog3 tog4 tog5 tog6--字符串
;;(setq aw (sl:do1ordo6 (slmsg "三领阵列,均布 V3.0" "烩皚 V3.0" "sldesign array V3.0") k1 k2 k3 k4 k5 k6))
(defun sl:do1ordo6 (dname tog1 tog2 tog3 tog4 tog5 tog6 / dcl_id str)
(defun do1do4-dcl (/ lst_str)
(setq lst_str
(list
"num_1_2:dialog"
"{"
(strcat "label = \"" dname "\"" ";")
"initial_focus = tile1;"
$boxed_column
$row
":button {"
(strcat "label = \"" tog1 "\"" ";")
"key = \"tile1\" ;"
"}"
":button {"
(strcat "label = \"" tog2 "\"" ";")
"key = \"tile2\" ;"
"}"
":button {"
(strcat "label = \"" tog3 "\"" ";")
"key = \"tile3\" ;"
"}"
"}"
":tile {}"
$row
":button {"
(strcat "label = \"" tog4 "\"" ";")
"key = \"tile4\" ;"
"}"
":button {"
(strcat "label = \"" tog5 "\"" ";")
"key = \"tile5\" ;"
"}"
":button {"
(strcat "label = \"" tog6 "\"" ";")
"key = \"tile6\" ;"
"}}}"
$row
$canbt
"fixed_width = true;"
"alignment = centered;"
"}}"
)
)
(dcl2lisp lst_str)
)
;;---------------------------------
(setq dcl_id (load_dialog (do1do4-dcl)))
(new_dialog "num_1_2" dcl_id)
(set_tile "tile1" "1")
(action_tile "tile1" "(setq str tog1) (done_dialog 1)")
(action_tile "tile2" "(setq str tog2) (done_dialog 1)")
(action_tile "tile3" "(setq str tog3) (done_dialog 1)")
(action_tile "tile4" "(setq str tog4) (done_dialog 1)")
(action_tile "tile5" "(setq str tog5) (done_dialog 1)")
(action_tile "tile6" "(setq str tog6) (done_dialog 1)")
(action_tile "cancel" "(setq str \"\") (done_dialog 0)")
(start_dialog)
(slunloaddcl dcl_id)
str
)
;选择集(9基点)沿线点集均布---(一级)-----
;ss 选择 p0 ss基点 ang0 ss初始角度 pts 曲线点集 nam 曲线
(defun sl-along-2p-cure (ss p0 ang0 pts nam / pt ob p n m e ang)
(setq ob (en2obj nam) m (sslength ss))
(while pts
(setq pt (car pts))
(if (> m 1)
(setq ang (+ (angle '(0.0 0.0 0.0) (vlax-curve-getFirstDeriv nam (vlax-curve-getparamatpoint nam pt))) pi2));切线的垂线角
(setq ang (angle '(0.0 0.0 0.0) (vlax-curve-getFirstDeriv nam (vlax-curve-getparamatpoint nam pt))));切线角
)
(aypercurve nam pt) ;此为曲线点位垂线辅助线
(setq e (entlast))
(command "copy" ss "" "_non" p0 "_non" pt)
(sl-ssrot (last_ent e) pt (- ang ang0))
(setq pts (cdr pts))
)
)
lxl217114 发表于 2024-5-28 07:23
是的，没错。
好的，谢谢回帖，回头有空了，也尝试一手 很好→很棒！很好~很棒！！很好……很棒！！！ CAD直接沿路径列阵就干了。 thanks for sharing
页:
[1]