设为首页收藏本站CAD论坛CAD教程CAD下载明经币充值
切换到宽版

明经CAD社区

 找回密码
 注册

QQ登录

只需一步，快速开始

搜索
明经CAD社区»社区 › 开发篇 › AutoLISP/Visual LISP 编程技术 › 沿线均布9点定位、定角集成《三领设计 V3.0 》
返回列表 发新帖
查看: 896|回复: 8

[资源] 沿线均布9点定位、定角集成《三领设计 V3.0 》

[复制链接]
尘缘一生
发表于 2024-5-27 19:43:19 | 显示全部楼层 |阅读模式
本帖最后由 尘缘一生 于 2024-5-27 19:45 编辑

关于沿线均布，涉及不少东西，下面展示下《三领设计 v3.0》的现今集成-->
三领认为：关于沿线均布，如果不能准确定位和角度正确，就失去了开发的意义
下一步将来：三领将加定位开始点位往后定距-->OK
  2. ;;三领设计 V3.0 沿线均布9点定位---【开始】------
  3. ;by 尘缘一生  QQ:15290049
  4. (defun c:sl-alon-cure (/ ss lis nam)
  5.   (setq ss (ssget ":S"))
  6.   (setq lis (sl-ss-9pt-ang ss))
  7.   (sldis "均布间距" "间距=" "0" "12") ;取距离集成函数，返回sldis1全局变量，带有比例，自理即可
  8.   (setq nam (car (entsel "\n 请选择曲线:")))
  9.   (sl-along-cure (car lis) (cadr lis) (caddr lis) sldis1 nam)
  10. )
  11. ;选择集(9基点)沿线均布---(一级)-----
  12. ;ss 选择 p0 ss基点 ang0 ss初始角度 dis 间距 nam 曲线
  13. (defun sl-along-cure (ss p0 ang0 dis nam / pt ob p n m e ang)
  14.   (setq ob (en2obj nam) n 0 p (1+ (fix (/ (sllen nam) dis))) m (sslength ss)) ;SLLEN 曲线长度函数
  15.   (while (< n p)
  16.     (setq pt (vlax-curve-getPointAtDist ob (* dis n)))
  17.     (setq pt (vlax-curve-getClosestPointTo nam pt nil))
  18.     (if (> m 1)
  19.       (setq ang (+ (angle '(0.0 0.0 0.0) (vlax-curve-getFirstDeriv nam (vlax-curve-getparamatpoint nam pt))) pi2));切线的垂线角
  20.       (setq ang (angle '(0.0 0.0 0.0) (vlax-curve-getFirstDeriv nam (vlax-curve-getparamatpoint nam pt))));切线角
  21.     )
  22.     (aypercurve nam pt) ;此为曲线点位垂线辅助线
  23.     (setq e (entlast))
  24.     (command "copy" ss "" "_non" p0 "_non" pt)
  25.     (sl-ssrot (last_ent e) pt (- ang ang0))
  26.     (setq n (1+ n))
  27.   )
  28. )
  29. ;;曲线垂线 nam曲线实体名 p曲线上点---(一级)------
  30. (defun aypercurve (nam p / dd ang p1 p2)
  31.   (setq p (vlax-curve-getClosestPointTo nam p nil))
  32.   (setq dd (p2uu 50.0))
  33.   (setq ang (angle '(0.0 0.0 0.0) (vlax-curve-getFirstDeriv nam (vlax-curve-getparamatpoint nam p)))) ;切线
  34.   (setq p1 (polar p (+ ang pi2) dd))
  35.   (setq p2 (polar p (- ang pi2) dd))
  36.   (fy_lineformat (makeline p1 p2) "中心线" "CENTER" 0.4 6) ;画线函数
  37. )
  38. ;选择集ss 以基点p0 旋转ang(弧度)---(一级)-----
  39. ;(sl-rot (ssget) (getpoint) (* pi 0.25))
  40. (defun sl-ssrot (ss p0 ang / mat i o)
  41.   (setq mat (mat:rotation (trans p0 1 0) ang)) ;旋转矩阵，自理
  42.   (setq mat (vlax-tmatrix mat))
  43.   (repeat (setq i (sslength ss))
  44.     (setq o (en2obj (ssname ss (setq i (1- i)))))
  45.     (vla-transformby o mat)
  46.   )
  47.   ;(sl-wzgz ss) 《三领设计》集成之 "文字归正"，可注销
  48.   (princ)
  49. )
  50. ;;当前视口取比例值-----(一级)-----
  51. (defun p2uu (pix)
  52.   (* pix (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE"))))
  53. )
  54. ;;实体、选择集定9点、轴角度-----(一级)----
  55. ;;返回(ss p0 ang)
  56. (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)
  57.   (setq plis (getpt ss))
  58.   (setq plis (graham-scan plis))
  59.   (if (or (< (length plis) 3) (and (>= (length plis) 3) (<= (det (car plis) (cadr plis) (caddr plis)) 0.0)))
  60.     (setq plis (reverse plis))
  61.   )
  62.   (setq
  63.     plis (car (minarearectangle plis)) ;高飞鸟求凸包,以下求9点位
  64.     p1 (car plis)
  65.     p3 (cadr plis)
  66.     p9 (caddr plis)
  67.     p7 (cadddr plis)
  68.     p2 (sl:mid p1 p3)
  69.     p4 (sl:mid p1 p7)
  70.     p6 (sl:mid p3 p9)
  71.     p8 (sl:mid p7 p9)
  72.     p5 (sl:mid p1 p9)
  73.   )
  74.   (if (> (distance p1 p2) (distance p2 p3))
  75.     (setq ang (angle p1 p2))
  76.     (setq ang (angle p2 p3))
  77.   )
  78.   (setq ang (angle-sharp ang)) ;角度转为1,4象限
  79.   (setq ms1 "\n->定位 [逆转90度(TAB)/左下(1)/下中(2)/右下(3)/左中(4)/正中(5)/右中(6)/左上(7)/上中(8)/右上(9)/取角(A)](左键、右键、空格>定位)")
  80.   (setq p0 p5)
  81.   (setq ms2 "-->当前<正中>")
  82.   (princ (strcat ms1 ms2))
  83.   (setq loop T)
  84.   (while loop
  85.     (redraw)
  86.     (slslx p0 0) ;交叉矢量线
  87.     (grdraw-drawjt p0 (polar p0 ang (p2uu 80.0))) ;箭头矢量
  88.     (setq bb (grread T 8))
  89.     (cond
  90.       ((or (= (car bb) 3) ;;左键
  91.          (= (car bb) 11)  ;;右键设置为回车时
  92.          (= (car bb) 25)  ;;右键设置为屏幕菜单时
  93.          (equal bb '(2 32))  ;;空格键
  94.        )
  95.         (setq loop nil)
  96.       )
  97.       ((member bb '((2 9)))      ;;table 键
  98.         (setq ang (+ ang pi2))
  99.       )
  100.       ((member bb '((2 65) (2 97)))  ;;A 旋转定角
  101.         (setq ang (angle p0 (getpoint p0 "\n 定角->:")))
  102.       )
  103.       ((equal bb '(2 49))  ;; 1键
  104.         (setq p0 p1 ms2 "当前<左下>")
  105.         (princ (strcat ms1 ms2))
  106.       )
  107.       ((equal bb '(2 50)) ;; 2键
  108.         (setq p0 p2 ms2 "当前<下中>")
  109.         (princ (strcat ms1 ms2))
  110.       )
  111.       ((equal bb '(2 51)) ;; 3键
  112.         (setq p0 p3 ms2 "当前<右下>")
  113.         (princ (strcat ms1 ms2))
  114.       )
  115.       ((equal bb '(2 52))  ;; 4键
  116.         (setq p0 p4 ms2 "当前<左中>")
  117.         (princ (strcat ms1 ms2))
  118.       )
  119.       ((equal bb '(2 53))  ;; 5键
  120.         (setq p0 p5 ms2 "当前<正中>")
  121.         (princ (strcat ms1 ms2))
  122.       )
  123.       ((equal bb '(2 54)) ;; 6键
  124.         (setq p0 p6 ms2 "当前<右中>")
  125.         (princ (strcat ms1 ms2))
  126.       )
  127.       ((equal bb '(2 55)) ;; 7键
  128.         (setq p0 p7 ms2 "当前<左上>")
  129.         (princ (strcat ms1 ms2))
  130.       )
  131.       ((equal bb '(2 56)) ;; 8键
  132.         (setq p0 p8 ms2 "当前<上中>")
  133.         (princ (strcat ms1 ms2))
  134.       )
  135.       ((equal bb '(2 57))  ;; 9键
  136.         (setq p0 p9 ms2 "当前<右上>")
  137.         (princ (strcat ms1 ms2))
  138.       )
  139.     )
  140.   )
  141.   (redraw)
  142.   (list ss p0 ang)
  143. )


《三领设计 V3.0》
链接：https://pan.baidu.com/s/1tr_aurX1en3clo4H0FlwNw
提取码：v1gl



本帖子中包含更多资源

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

x

评分

参与人数 1明经币 +1 金钱 +10 收起 理由
tranque + 1 + 10 赞一个!

查看全部评分

"觉得好，就打赏"
打赏
还没有人打赏，支持一下
回复

使用道具 举报

lxl217114
发表于 2024-5-27 23:05:45 | 显示全部楼层
嗯，迷你的全能复制和沿线布块都可以做的完美。
回复 支持 反对

使用道具 举报

weimeng555
发表于 2024-5-28 05:11:05 | 显示全部楼层
lxl217114 发表于 2024-5-27 23:05
嗯，迷你的全能复制和沿线布块都可以做的完美。

你好，请问你说的全能复制和沿线布块，都是迷你的功能吗
回复 支持 反对

使用道具 举报

lxl217114
发表于 2024-5-28 07:23:42 | 显示全部楼层
weimeng555 发表于 2024-5-28 05:11
你好，请问你说的全能复制和沿线布块，都是迷你的功能吗

是的，没错。
回复 支持 反对

使用道具 举报

尘缘一生
 楼主| 发表于 2024-5-28 10:27:59 | 显示全部楼层



继续增加，定2点均布，并与阵列集成，
  2. ;;三领设计 V3.0 沿线均布9点定位---【开始】------
  3. ;by 尘缘一生  QQ:15290049
  4. ;;三领阵列----【开始】------
  5. (defun c:sl-arry ()
  6.   (sl-arry (ssget ":S"))
  7. )
  8. ;;选择集阵列----(一级)------
  9. (defun sl-arry (ss / aw k1 k2 k3 k4 k5 k6 e nam lis pts p1 p2 div)
  10.   (setq
  11.     k1 "直线阵列"
  12.     k2 "环形阵列"
  13.     k3 "二维阵列"
  14.     k4 " 沿线均布 "
  15.     k5 "2P定长均布"
  16.     k6 "2P定量均布"
  17.   )
  18.   (setq aw (sl:do1ordo6 "三领阵列,均布 V3.0" k1 k2 k3 k4 k5 k6))
  19.   (if (or (= aw k4) (= aw k5) (= aw k6))
  20.     (setq lis (sl-ss-9pt-ang ss))
  21.   )
  22.   (if (or (= aw k4) (= aw k5))
  23.     (sldis "均布间距" "间距=" "0" "12")
  24.   )
  25.   (cond
  26.     ((= aw k1)
  27.       (lin-arr ss)
  28.     )
  29.     ((= aw k2)
  30.       (setq e (entlast))
  31.       (cir-arr ss)
  32.       (sl-wzgz (last_ent e))
  33.     )
  34.     ((= aw k3)
  35.       (sed-arr ss)
  36.     )
  37.     ((= aw k4)
  38.       (setq nam (car (entsel "\n 请选择曲线:")))
  39.       (sl-along-cure (car lis) (cadr lis) (caddr lis) sldis1 nam)
  40.     )
  41.     ((or (= aw k5) (= aw k6))
  42.       (setq nam (car (entsel "\n 请选择曲线:")))
  43.       (setq p1 (getpoint "\n 请输入起点:")
  44.         p2 (getpoint p1 "\n 请输入终点:")
  45.       )
  46.       (if (= aw k5)
  47.         (setq pts (sl:DivdeCurve nam p1 p2 nil sldis1))
  48.         (setq div (atoi (inputbox "等分数" "?等分 " "2" "35"))
  49.           pts (sl:DivdeCurve nam p1 p2 t div)
  50.         )
  51.       )
  52.       (sl-along-2p-cure (car lis) (cadr lis) (caddr lis) pts nam)
  53.     )
  54.   )
  55. )
  56. ;;等分曲线,返回点坐标(包含端点)----(一级)----
  57. ;;Curve = 曲线图元名 p1曲线上第一点 p2曲线上第二点
  58. ;;Flag = T 定数等分曲线 nil 定长等分曲线
  59. ;;n = 当 Flag = T 时 n 为等分数，当Flag = nil 时 n 为等分长度
  60. ;;(sl:DivdeCurve (car (entsel "\n选择曲线:")) (getpoint "\n 起点:") (getpoint "\n 终点:") T 5)
  61. ;;((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))
  62. (defun sl:DivdeCurve (curve p1 p2 flag n / d1 d2 d d0 pts)
  63.   (setq
  64.     p1 (vlax-curve-getclosestpointto Curve p1)
  65.     d1 (vlax-curve-getDistAtPoint Curve p1)
  66.     p2 (vlax-curve-getclosestpointto Curve p2)
  67.     d2 (vlax-curve-getDistAtPoint Curve p2)
  68.   )
  69.   (if Flag
  70.     (setq d (/ (- d2 d1) n))
  71.     (setq d (if (minusp (- d2 d1)) (* -1.0 n) n))
  72.   )
  73.   (setq d0 d1)
  74.   (setq pts (cons p1 pts))
  75.   (if (> d2 d1)
  76.     (while (apply '< (list (setq d0 (+ d0 d)) d2))
  77.       (setq pts (cons (vlax-curve-getPointAtDist curve d0) pts))
  78.     )
  79.     (while (apply '> (list (setq d0 (+ d0 d)) d2))
  80.       (setq pts (cons (vlax-curve-getPointAtDist curve d0) pts))
  81.     )
  82.   )
  83.   (setq pts (gps->lst-delsame (cons p2 pts)))
  84.   (reverse pts)
  85. )
  86. ;;六键开关---------(一级)-------
  87. ;;调用形式 (sl:do1ordo6  dname:对话框名称  tog1:开关1 ...)
  88. ;;返回 tog1 tog2 tog3 tog4 tog5 tog6--字符串
  89. ;;(setq aw (sl:do1ordo6 (slmsg "三领阵列,均布 V3.0" "烩皚 V3.0" "sldesign array V3.0") k1 k2 k3 k4 k5 k6))
  90. (defun sl:do1ordo6 (dname tog1 tog2 tog3 tog4 tog5 tog6 / dcl_id str)
  91.   (defun do1do4-dcl (/ lst_str)
  92.     (setq lst_str
  93.       (list
  94.         "num_1_2:dialog"
  95.         "{"
  96.         (strcat "label = "" dname """ ";")
  97.         "initial_focus = tile1;"
  98.         $boxed_column
  99.         $row
  100.         ":button {"
  101.         (strcat "label = "" tog1 """ ";")
  102.         "key = "tile1" ;"
  103.         "}"
  104.         ":button {"
  105.         (strcat "label = "" tog2 """ ";")
  106.         "key = "tile2" ;"
  107.         "}"
  108.         ":button {"
  109.         (strcat "label = "" tog3 """ ";")
  110.         "key = "tile3" ;"
  111.         "}"
  112.         "}"
  113.         ":tile {}"
  114.         $row
  115.         ":button {"
  116.         (strcat "label = "" tog4 """ ";")
  117.         "key = "tile4" ;"
  118.         "}"
  119.         ":button {"
  120.         (strcat "label = "" tog5 """ ";")
  121.         "key = "tile5" ;"
  122.         "}"
  123.         ":button {"
  124.         (strcat "label = "" tog6 """ ";")
  125.         "key = "tile6" ;"
  126.         "}}}"
  127.         $row
  128.         $canbt
  129.         "fixed_width = true;"
  130.         "alignment = centered;"
  131.         "}}"
  132.       )
  133.     )
  134.     (dcl2lisp lst_str)
  135.   )
  136.   ;;---------------------------------
  137.   (setq dcl_id (load_dialog (do1do4-dcl)))
  138.   (new_dialog "num_1_2" dcl_id)
  139.   (set_tile "tile1" "1")
  140.   (action_tile "tile1" "(setq str tog1) (done_dialog 1)")
  141.   (action_tile "tile2" "(setq str tog2) (done_dialog 1)")
  142.   (action_tile "tile3" "(setq str tog3) (done_dialog 1)")
  143.   (action_tile "tile4" "(setq str tog4) (done_dialog 1)")
  144.   (action_tile "tile5" "(setq str tog5) (done_dialog 1)")
  145.   (action_tile "tile6" "(setq str tog6) (done_dialog 1)")
  146.   (action_tile "cancel" "(setq str "") (done_dialog 0)")
  147.   (start_dialog)
  148.   (slunloaddcl dcl_id)
  149.   str
  150. )
  151. ;选择集(9基点)沿线点集均布---(一级)-----
  152. ;ss 选择 p0 ss基点 ang0 ss初始角度 pts 曲线点集 nam 曲线
  153. (defun sl-along-2p-cure (ss p0 ang0 pts nam / pt ob p n m e ang)
  154.   (setq ob (en2obj nam) m (sslength ss))
  155.   (while pts
  156.     (setq pt (car pts))
  157.     (if (> m 1)
  158.       (setq ang (+ (angle '(0.0 0.0 0.0) (vlax-curve-getFirstDeriv nam (vlax-curve-getparamatpoint nam pt))) pi2));切线的垂线角
  159.       (setq ang (angle '(0.0 0.0 0.0) (vlax-curve-getFirstDeriv nam (vlax-curve-getparamatpoint nam pt))));切线角
  160.     )
  161.     (aypercurve nam pt) ;此为曲线点位垂线辅助线
  162.     (setq e (entlast))
  163.     (command "copy" ss "" "_non" p0 "_non" pt)
  164.     (sl-ssrot (last_ent e) pt (- ang ang0))
  165.     (setq pts (cdr pts))
  166.   )
  167. )


本帖子中包含更多资源

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

x
回复 支持 反对

使用道具 举报

weimeng555
发表于 2024-5-28 15:54:45 | 显示全部楼层
lxl217114 发表于 2024-5-28 07:23
是的，没错。

好的，谢谢回帖，回头有空了，也尝试一手
回复 支持 反对

使用道具 举报

寒潮大冬瓜
发表于 2024-5-28 15:54:56 | 显示全部楼层
很好→很棒！很好~很棒！！很好……很棒！！！
回复 支持 反对

使用道具 举报

kozmosovia
发表于 2024-5-28 15:56:10 | 显示全部楼层
CAD直接沿路径列阵就干了。
回复 支持 反对

使用道具 举报

sachindkini
发表于 2024-7-8 18:55:22 | 显示全部楼层
thanks for sharing
回复 支持 反对

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码，在未取得本站及作者授权的情况下，不得用于商业用途

GMT+8, 2024-11-25 13:10 , Processed in 0.201398 second(s), 27 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表