设为首页收藏本站

晓东CAD家园-论坛

 找回密码
 立即注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

查看: 115|回复: 10

[曲线] 同心圆或两直线加中心线

[复制链接]

已领礼包: 21个

财富等级: 恭喜发财

发表于 2021-9-25 12:06:45 | 显示全部楼层 |阅读模式
  • 插件名称 : 同心圆或两直线加中心线
  • 作  者 : 马坤
  • 运行环境 :不限 
  • 发布时间 :2021-09-25
  • 命令名称 :yj1
  • 插件介绍 :同心圆或两直线加中心线
  • 备  注 : (点击图片可以放大)
(点击图片可以放大)

晓东温馨提示 1、运行环境为 晓东工具箱XDRX API 的插件,请下载最新版本的 晓东工具箱XDRX API开发环境 一键安装
2、在ACAD中如何加载插件,请看 论坛插件使用方法
3、如果您有要求需要定制插件,请到 编程申请 论坛发帖求助

插件详细内容

马上注册,结交更多好友,享用更多功能,让你轻松玩转社区。

您需要 登录 才可以下载或查看,没有帐号?立即注册

x
本帖最后由 qxlonmsn 于 2021-9-25 12:12 编辑

  • (vl-load-com)
  • (setq somde (getvar "osmode"))
  • (setq secho (getvar "cmdecho"))
  • (setvar "osmode" 0)
  • (setvar "cmdecho" 0)   
  • (defun fy-LineFormat (obj lay lt sc col / qm40) ;线的格式
  •     ;图元名/obj对象 图层 线型 圆0.8/线0.4 颜色
  •     (vl-load-com)
  •     (if (= (type obj) 'ENAME) (setq obj (vlax-ename->vla-object obj)))
  •     (vla-put-layer obj lay)
  •     (vla-put-Linetype obj lt)
  •     (vla-put-Color obj col)
  •     (setq qm40 (cdr (assoc 40 (tblsearch "ltype" lt))))
  •     (if (and (/= qm40 0) (/= sc 0))
  •       (vla-put-LinetypeScale obj (* (vla-get-Length obj) (/ sc qm40 (getvar "LTSCALE"))))
  •     )
  •     (vla-update obj)
  •     (princ)
  •   )
  • (defun ss->elst  (ss / elst)
  •   (setq i 0)
  •   (repeat (sslength ss)
  •     (setq elst (cons (ssname ss i) elst)
  •     i    (1+ i)
  •     )
  •   )
  •   (reverse elst)
  • )
  • (defun elst->ss  (elst / ss2)
  •   (setq ss2 (ssadd))
  •   (setq i 0)
  •   (repeat (length elst)
  •     (ssadd (nth i elst) ss2)
  •     (setq i (1+ i))
  •   )
  •   ss2
  • )
  • (vl-load-com)
  • ;;更新表中元素
  • ;;(substn 5 3 (list 1 2 3 4 5 6 7))
  • ;;(1 2 3 5 5 6 7)
  • ;;(substn (list 5) 3 (list (list 1) (list 2) (list 3) (list 4) (list 5) (list 6) (list 7)))
  • ;;((1) (2) (3) (5) (5) (6) (7))
  • (defun substn (a n l)
  •   (if l
  •     (if  (= 0 n)
  •       (cons a (cdr l))
  •       (cons (car l) (substn a (1- n) (cdr l)))
  •     )
  •   )
  • )
  • (defun YJ (SS)
  •   ;;(setq SS (ssget '((0 . "circle"))))
  •   (setq tol 0.01)
  •   (setq retlst '())
  •   (setq i 0)
  •   (while (setq ent (ssname ss i))
  •     (setq cenPt (cdr (assoc 10 (entget ent))))
  •     (setq radious (cdr (assoc 40 (entget ent))))
  •     (setq j 0)
  •     (setq flag nil)
  •     (repeat (length retlst)
  •       (setq lst (car (nth j retlst)))
  •       (if (and (equal (car lst) (car cenPt) tol)
  •          (equal (cadr lst) (cadr cenPt) tol)
  •     )
  •   (progn
  •     (setq entlst (cadr (nth j retlst)))
  •     (setq entlst (cons (list ent radious) entlst))
  •     (setq retlst (substn (list lst entlst) j retlst))
  •     (setq flag T)
  •   )
  •       )
  •       (setq j (1+ j))
  •     )
  •     (if  (Not flag)
  •       (progn
  •   (setq
  •     retlst (cons (list cenPt (list (list ent radious))) retlst)
  •   )
  •       )
  •     )
  •     (setq i (1+ i))
  •   )
  •   ;;while
  •   (setq i 0)
  •   (repeat (length retlst)
  •     (setq cenPt (car (nth i retlst)))
  •     (setq lst (cadr (nth i retlst)))
  •     (setq lst (vl-sort lst
  •            '(lambda  (s1 s2)
  •         (> (cadr s1) (cadr s2))
  •       )
  •         )
  •     )
  •     (setq radious (cadr (nth 0 lst)))
  •     (setq pt1 (polar cenPt 0 (* 1.2 radious)))
  •     (setq pt2 (polar cenPt (* 0.5 pi) (* 1.2 radious)))
  •     (setq pt3 (polar cenPt (* 1 pi) (* 1.2 radious)))
  •     (setq pt4 (polar cenPt (* 1.5 pi) (* 1.2 radious)))
  •     ;;(Command "line" pt1 pt3 PT2 PT4 "")
  •     (COMMAND "-LINETYPE" "S" "CENTER2" "")
  •     (entmake
  •       (list '(0 . "LINE") (cons 62 1) (cons 10 pt1) (cons 11 pt3))
  •     )
  •     (entmake
  •       (list '(0 . "LINE") (cons 62 1) (cons 10 pt2) (cons 11 pt4))
  •     )
  •     (setq i (1+ i))
  •   )
  •   (setvar "osmode" somde)
  •   (setvar "cmdecho" secho)
  • )
  • (defun C:YJ1 ()
  •   (setq SSlst (ss->elst (ssget '((0 . "CIRCLE,LINE")))))
  •   ;;分离出圆和直线
  •   (setq liness '())
  •   (setq circless '())
  •   (setq i 0)
  •   (repeat (length sslst)
  •     (setq entlst (entget (nth i sslst)))
  •     (if  (= (cdr (assoc 0 entlst)) "LINE")
  •       (setq liness (cons (nth i sslst) liness))
  •     )
  •     (if  (= (cdr (assoc 0 entlst)) "CIRCLE")
  •       (setq circless (cons (nth i sslst) circless))
  •     )
  •     (setq i (1+ i))
  •   )
  •   ;;处理圆的标注
  •   (YJ (elst->ss circless))
  •   ;;判断直线个数
  •   (if (= (length liness) 2)
  •     (princ)
  •     (exit)
  •   )
  •   (setq obj (vlax-get-acad-object))
  •   (setq doc (vla-get-ActiveDocument Obj))
  •   (setq msp (vla-get-ModelSpace doc))
  •   ;;(setq en1 (car (entsel "\n请选择第一条直线")))
  •   ;;(setq en2 (car (entsel "\n请选择第二条直线")))
  •   (setq en1 (nth 0 liness))
  •   (setq en2 (nth 1 liness))
  •   (setq  p1 (vlax-curve-getstartpoint en1)
  •   p2 (vlax-curve-getendpoint en1)
  •   p3 (vlax-curve-getstartpoint en2)
  •   p4 (vlax-curve-getendpoint en2)
  •   p5 (inters p1 p2 p3 p4 nil)
  •   )
  •   (if (= nil p5)
  •     (不平行 en1 en2)
  •     (平行 en1 en2)
  •   )
  • )
  • (defun 平行 (line1 line2)
  •   ;;(setq ee (entsel "\n请选择第一条直线:"))
  •   ;;两线平行时
  •   (setq ename1 line1)
  •   (redraw ename1 3)
  •   (setq  alist (entget ename1)
  •   sp1   (cdr (assoc 10 alist))
  •   ep1   (cdr (assoc 11 alist))
  •   )
  •   ;;(setq ee (entsel "\n请选择第二条直线:"))
  •   (setq ename2 line2)
  •   (setq  alist (entget ename2)
  •   sp2   (cdr (assoc 10 alist))
  •   ep2   (cdr (assoc 11 alist))
  •   )
  •   (setq flg (inters sp1 sp2 ep1 ep2))
  •   (if (/= flg nil)
  •     (setq dum sp2
  •     sp2 ep2
  •     ep2 dum
  •     )
  •   )
  •   (setq  p1x (car sp1)
  •   p1y (cadr sp1)
  •   p2x (car sp2)
  •   p2y (cadr sp2)
  •   mix (min p1x p2x)
  •   mxx (max p1x p2x)
  •   miy (min p1y p2y)
  •   mxy (max p1y p2y)
  •   pmx (+ mix (/ (- mxx mix) 2.0))
  •   pmy (+ miy (/ (- mxy miy) 2.0))
  •   smp (list pmx pmy)
  •   )
  •   (setq  p1x (car ep1)
  •   p1y (cadr ep1)
  •   p2x (car ep2)
  •   p2y (cadr ep2)
  •   mix (min p1x p2x)
  •   mxx (max p1x p2x)
  •   miy (min p1y p2y)
  •   mxy (max p1y p2y)
  •   pmx (+ mix (/ (- mxx mix) 2.0))
  •   pmy (+ miy (/ (- mxy miy) 2.0))
  •   emp (list pmx pmy)
  •   )
  •   (COMMAND "-LINETYPE" "S" "CENTER2" "")
  •   (entmake
  •     (list '(0 . "LINE") (cons 62 1) (cons 10 smp) (cons 11 emp))
  •   )
  •   (redraw)
  • ;|
  •   (while (setq ent (ssname ss 0))
  •     (setq ss (ssdel ent ss))
  •     (setq cenPt (cdr (assoc 10 (entget ent))))
  •     (setq radious (cdr (assoc 40 (entget ent))))
  •     (setq pt1 (polar cenPt 0 (* 1.2 radious)))
  •     (setq pt2 (polar cenPt (* 0.5 pi) (* 1.2 radious)))
  •     (setq pt3 (polar cenPt (* 1 pi) (* 1.2 radious)))
  •     (setq pt4 (polar cenPt (* 1.5 pi) (* 1.2 radious)))
  •     ;;(Command "line" pt1 pt3 PT2 PT4 "")
  •     (COMMAND "-LINETYPE" "S" "CENTER2" "")
  •     (entmake
  •       (list '(0 . "LINE") (cons 62 1) (cons 10 pt1) (cons 11 pt3))
  •     )
  •     (entmake
  •       (list '(0 . "LINE") (cons 62 1) (cons 10 pt2) (cons 11 pt4))
  •     )
  •   )
  •   ;;while
  • |;
  •   (PrinC)
  • )
  • (defun 不平行 (line1 line2)
  •   (setq somde (getvar "osmode"))
  •   (setq secho (getvar "cmdecho"))
  •   (setvar "osmode" 0)
  •   (setvar "cmdecho" 0)
  •   (vl-load-com)
  •   ;;两线不平行时
  •   (setq obj (vlax-get-acad-object))
  •   (setq doc (vla-get-ActiveDocument Obj))
  •   (setq msp (vla-get-ModelSpace doc))
  •   ;;(setq en1 (car (entsel "\n请选择第一条直线")))
  •   ;;(setq en2 (car (entsel "\n请选择第二条直线")))
  •   (setq en1 line1)
  •   (setq en2 line2)
  •   (setq  p1 (vlax-curve-getstartpoint en1)
  •   p2 (vlax-curve-getendpoint en1)
  •   p3 (vlax-curve-getstartpoint en2)
  •   p4 (vlax-curve-getendpoint en2)
  •   p5 (inters p1 p2 p3 p4 nil)
  •   )
  •   ;;将p1和p3调整为靠近p5
  •   (if (< (distance p5 p2) (distance p5 p1))
  •     (progn
  •       (setq tmpPt p1)
  •       (setq p1 p2)
  •       (setq p2 tmpPt)
  •     )
  •   )
  •   (if (< (distance p5 p4) (distance p5 p3))
  •     (progn
  •       (setq tmpPt p3)
  •       (setq p3 p4)
  •       (setq p4 tmpPt)
  •     )
  •   )
  •   (setq ang1 (angle p5 P2))
  •   (setq ang2 (angle p5 P4))
  •   (setq  midang (- (max ang1 ang2)
  •       (* 0.5 (- (max ang1 ang2) (min ang1 ang2)))
  •          )
  •   )
  •   (setq p6 (polar p5 midang 1.0))
  •   (setq p7 (inters p5 p6 P1 P3 nil))
  •   ;;注意这里若p5与p6重合,或者p1和p3重合时,由于线段距离为0,p7是求不出来的
  •   (setq p8 (inters p5 p6 P2 P4 nil))
  •   ;;同上
  •     (fy-LineFormat (makeline p7 p8) lay lt sc4 col)
  •   (COMMAND "-LINETYPE" "S" "CENTER2" "")
  •   (entmake
  •     (list '(0 . "LINE") (cons 62 1) (cons 10 P7) (cons 11 P8))
  •   )
  •   (setvar "osmode" somde)
  •   (setvar "cmdecho" secho)
  • )

论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!

已领礼包: 541个

财富等级: 财运亨通

发表于 2021-9-25 16:53:48 | 显示全部楼层
自定义函数竟然可以用中文命名
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 2128个

财富等级: 金玉满堂

发表于 2021-9-25 17:00:23 | 显示全部楼层
做个对论坛有益的人。
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 5157个

财富等级: 富甲天下

发表于 2021-9-25 18:55:37 | 显示全部楼层
这个代码值得学习和分享。
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 5952个

财富等级: 富甲天下

发表于 2021-9-25 19:31:09 | 显示全部楼层
谢谢楼主分享的源代码!
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 3764个

财富等级: 富可敌国

发表于 2021-9-26 08:51:17 | 显示全部楼层
做一个热心并受欢迎的人
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 6252个

财富等级: 富甲天下

发表于 2021-9-27 00:18:07 | 显示全部楼层
同心圆或两直线加中心线
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2021-9-27 09:27:33 | 显示全部楼层
正在找   谢谢分享。。。。。。。
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 21个

财富等级: 恭喜发财

 楼主| 发表于 2021-9-27 10:36:10 | 显示全部楼层
还是有点BUG的  单个的圆 或者 单个的线  要报错
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 3764个

财富等级: 富可敌国

发表于 2021-9-27 22:53:28 | 显示全部楼层
做一个热心并受欢迎的人
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 3764个

财富等级: 富可敌国

发表于 2021-9-28 08:36:13 | 显示全部楼层
做一个热心并受欢迎的人
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

QQ|申请友链|小黑屋|手机版|Archiver|辽公网安备|晓东CAD家园 ( 辽ICP备15016793号 )  

GMT+8, 2021-10-21 20:11 , Processed in 0.972165 second(s), 51 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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