线割外形穿线孔绘制

yu960312 · 发表于 2022-5-15 02:44

本帖最后由 yu960312 于 2022-5-15 03:32 编辑

(defun C:AC(/ en P1 P2 P3 P4 P5)
(COMMAND "UCS" "W")
(setvar "cmdecho" 0)
(setvar "cecolor" "1");改变当前颜色
(setvar "ORTHOMODE" 0);关闭正交
(if (null L)(setq L 2.0))
(if (null W)(setq W 2.0))
(if (null R)(setq R 0.5))
(while ;循环执行
(setq L11 L W11 W R11 R)
(setq T 0)

(while (/= T nil) ;循环设置参数
(princ "\n---绘制穿丝孔---")
(princ (strcat "\n当前设置[ 引线: " (rtos L 2 4) " MM "))
(princ (strcat "偏距: " (rtos W 2 4) " MM "))
(princ (strcat "半径: " (rtos R 2 4) " MM ] "))
(initget "LL WW RR")
(setq en(entsel "\n选择线段或[引线(LL) /偏距(WW) /半径(RR)]"))

(cond
((= en "LL");L
(progn
(setq L(getreal (strcat "\n引线:<" (rtos L 2 4) ">")))
(if (= nil L)(setq L L11))
)
)

((= en "WW");W
(progn
(setq W(getreal (strcat "\n偏距:<" (rtos W 2 4) ">")))
(if (= nil W)(setq W W11))
)
)

((= en "RR");R
(progn
(setq R(getreal (strcat "\n半径:<" (rtos R 2 4) ">")))
(if (= nil R)(setq R R11))
)
)

((/= en "LL")(/= en "WW")(/= en "RR")
(setq T nil)
)
);结束cond
);结束循环设置参数

(if (= en nil)(exit))

(setq e (car en))
(setq enn (entget (car en)))
(setq ol(cdr (assoc 0 enn)))

(if (= ol "LWPOLYLINE")
(progn
(setq n(fix (vlax-curve-getparamatpoint e
(vlax-curve-getclosestpointto e (cadr en)))));点选在多段线上的第几段
(setq n1(vlax-curve-getclosestpointto e (cadr en)));点选的点在多段线上的位置
(setq P1(vlax-curve-getpointatparam e n));第一个端点坐标
(setq P2(vlax-curve-getpointatparam e (1+ n)));第二个端点坐标
))

(if (= ol "LINE")
(progn
(setq n1(vlax-curve-getclosestpointto e (cadr en)));点选的点在多段线上的位置
(setq P1(cdr (assoc 10 enn)));第一个端点坐标
(setq P2(cdr (assoc 11 enn)));第二个端点坐标
))

(setq MI(polar P1 (angle P1 P2) (* 0.5 (distance P1 P2))));线段中点坐标

(setq P3 (getpoint "\n指定一侧上的点:"))

(setq A2 (distance P1 N1));第一点到点选的点的距离
(setq A3 (distance P2 N1));第二点到点选的点的距离

(if (> A2 A3)
(progn
(setq P2P P2)
(setq P1P P1)
(setq P1 P2P)
(setq P2 P1P)
)
)

(setq ang1 (atof (angtos (angle P1 P2) 0 4)));获取点选线段的倾斜角度

(setq ang2(anga P1 P3 MI));获取点夹角角度为

;判断象限
(if (and (> ang2 90 ) (< ang2 180)) (SETQ XX 1));第一象限
(if (and (> ang2 0 ) (< ang2 90 )) (SETQ XX 2));第二象限
(if (and (> ang2 270) (< ang2 360)) (SETQ XX 3));第三象限
(if (and (> ang2 180) (< ang2 270)) (SETQ XX 4));第四象限

(cond
((= XX 1);第一象限
(progn
(setq P4(polar P2 (* pi (/ (angtof (rtos ang1) 0) (angtof (rtos 180) 0))) (* W -1)))
(setq P5(polar P4 (* pi (/ (angtof (rtos (+ 270 ang1)) 0) (angtof (rtos 180) 0))) (* L -1)))
))

((= XX 2);第二象限
(progn
(setq P4(polar P1 (* pi (/ (angtof (rtos ang1) 0) (angtof (rtos 180) 0))) W))
(setq P5(polar P4 (* pi (/ (angtof (rtos (+ 270 ang1)) 0) (angtof (rtos 180) 0))) (* L -1)))
))

((= XX 3);第三象限
(progn
(setq P4(polar P1 (* pi (/ (angtof (rtos ang1) 0) (angtof (rtos 180) 0))) W))
(setq P5(polar P4 (* pi (/ (angtof (rtos (+ 270 ang1)) 0) (angtof (rtos 180) 0))) L))
))

((= XX 4);第四象限
(progn
(setq P4(polar P2 (* pi (/ (angtof (rtos ang1) 0) (angtof (rtos 180) 0))) (* W -1)))
(setq P5(polar P4 (* pi (/ (angtof (rtos (+ 270 ang1)) 0) (angtof (rtos 180) 0))) L))
))
)

(entmakex (list '(0 . "CIRCLE") (cons 10 P5) (cons 40 R)))
(princ "\n")
(princ "绘制完毕!")
);结束循环绘制
(princ)
)

(defun anga(PT1 PT2 PT3) ;已知PT1 PT2 PT3 三点，求三点夹角A角度
(setq ang(- (angle PT1 PT3) (angle PT2 PT3)))
(if (> ang (* 2.0 pi)) (setq ang(- (* 2.0 pi) ang)))
(setq ang(atof (angtos ang 0 4)))
)

zm880928 · 发表于 2022-5-15 09:07

yu960312 发表于 2022-5-15 08:49
慢走丝呀，外形要修刀呀

我也是慢走丝，我的意思为什么要靠角落偏移固定距离。直接指定一个点，往里或者往外拉一个固定距离不就完事了。，

andyding · 发表于 2023-7-3 21:06

仿写了一个，凑个热闹。

(defun c:ac (/ N OLDOR OLDOS P1 P11 P2 P22 P33 P44 PMD PP SS SSNA SSP1 X
Y)
(setq oldos (getvar "osmode"))
(setq oldor (getvar "orthomode"))
(defun PickClosePt (obj p);;;多段线所点击点最近的一个顶点
(setq pp (vlax-curve-getclosestpointto obj (trans p 1 0))
n (fix (vlax-curve-getparamatpoint obj pp))
)
(setq p1 (vlax-curve-getPointAtParam obj n))
(setq p2 (vlax-curve-getPointAtParam obj (1+ n)))
(if (< (distance pp p1) (distance pp p2))
p1
p2
)
)
(princ "\n请选择要画穿线孔的多义线：")
(if (and (setq ss (entsel))
(= (cdr (assoc 0 (entget (car ss)))) "LWPOLYLINE")
)
(progn
(setvar "osmode" 0)
(setvar "orthomode" 1)
(setq ssna (vlax-ename->vla-object (car ss)))
(setq ssp1 (cadr ss))
(setq p11 (PickClosePt ssna ssp1))
(setq pmd (mapcar '(lambda (X Y) (* (+ X Y) 0.5)) P1 P2))
(cond ((and (= (cadr p11) (cadr pmd)) (> (car p11) (car pmd)))
(setq p22 (list (- (car p11) 2.0) (cadr p11)))
);;;2.0为起割点距离
((and (= (cadr p11) (cadr pmd)) (< (car p11) (car pmd)))
(setq p22 (list (+ (car p11) 2.0) (cadr p11)))
)
((and (= (car p11) (car pmd)) (> (cadr p11) (cadr pmd)))
(setq p22 (list (car p11) (- (cadr p11) 2.0)))
)
((and (= (car p11) (car pmd)) (< (cadr p11) (cadr pmd)))
(setq p22 (list (car p11) (+ (cadr p11) 2.0)))
)
)
(princ "\n请选择下一点：")
(if (setq p33 (getpoint p22))
(progn
(cond ((and (= (cadr p33) (cadr p22)) (> (car p33) (car p22)))
(setq p44 (list (+ (car p22) 2.0) (cadr p22)))
);;;2.0为起割点到穿丝孔距离
((and (= (cadr p33) (cadr p22)) (< (car p33) (car p22)))
(setq p44 (list (- (car p22) 2.0) (cadr p22)))
)
((and (= (car p33) (car p22)) (> (cadr p33) (cadr p22)))
(setq p44 (list (car p22) (+ (cadr p22) 2.0)))
)
((and (= (car p33) (car p22)) (< (cadr p33) (cadr p22)))
(setq p44 (list (car p22) (- (cadr p22) 2.0)))
)
)
(entmake
(list '(0 . "LINE") (cons 10 p22) (cons 11 p44) (cons 62 1))
)
(entmake (list '(0 . "Circle")
(cons 10 p44)
(cons 40 0.5);;;0.5为穿丝孔半径
(cons 62 1)
)
)
(setvar "osmode" oldos)
(setvar "orthomode" oldor)
)
(progn (princ "\n未选择到点，程序结束!")
(setvar "osmode" oldos)
(setvar "orthomode" oldor)
)
)
)
(progn (princ "\n未选择到图形或图形不是多义线,程序结束!")
(setvar "osmode" oldos)
(setvar "orthomode" oldor)
)
)
(princ)
)

(defun c:ac (/ N OLDOR OLDOS P1        P11 P2 P22 P33 P44 PMD PP SS SSNA SSP1 X 
             Y) 
  (setq oldos (getvar "osmode")) 
  (setq oldor (getvar "orthomode")) 
  (defun PickClosePt (obj p);;;多段线所点击点最近的一个顶点 
    (setq pp (vlax-curve-getclosestpointto obj (trans p 1 0)) 
          n  (fix (vlax-curve-getparamatpoint obj pp)) 
    ) 
    (setq p1 (vlax-curve-getPointAtParam obj n)) 
    (setq p2 (vlax-curve-getPointAtParam obj (1+ n))) 
    (if        (< (distance pp p1) (distance pp p2)) 
      p1 
      p2 
    ) 
  ) 
  (princ "\n请选择要画穿线孔的多义线：") 
  (if (and (setq ss (entsel)) 
           (= (cdr (assoc 0 (entget (car ss)))) "LWPOLYLINE") 
      ) 
    (progn 
      (setvar "osmode" 0) 
      (setvar "orthomode" 1) 
      (setq ssna (vlax-ename->vla-object (car ss))) 
      (setq ssp1 (cadr ss)) 
      (setq p11 (PickClosePt ssna ssp1)) 
      (setq pmd (mapcar '(lambda (X Y) (* (+ X Y) 0.5)) P1 P2)) 
      (cond ((and (= (cadr p11) (cadr pmd)) (> (car p11) (car pmd))) 
             (setq p22 (list (- (car p11) 2.0) (cadr p11))) 
            );;;2.0为起割点距离 
            ((and (= (cadr p11) (cadr pmd)) (< (car p11) (car pmd))) 
             (setq p22 (list (+ (car p11) 2.0) (cadr p11))) 
            ) 
            ((and (= (car p11) (car pmd)) (> (cadr p11) (cadr pmd))) 
             (setq p22 (list (car p11) (- (cadr p11) 2.0))) 
            ) 
            ((and (= (car p11) (car pmd)) (< (cadr p11) (cadr pmd))) 
             (setq p22 (list (car p11) (+ (cadr p11) 2.0))) 
            ) 
      ) 
      (princ "\n请选择下一点：") 
      (if (setq p33 (getpoint p22)) 
        (progn 
          (cond        ((and (= (cadr p33) (cadr p22)) (> (car p33) (car p22))) 
                 (setq p44 (list (+ (car p22) 2.0) (cadr p22))) 
                );;;2.0为起割点到穿丝孔距离 
                ((and (= (cadr p33) (cadr p22)) (< (car p33) (car p22))) 
                 (setq p44 (list (- (car p22) 2.0) (cadr p22))) 
                ) 
                ((and (= (car p33) (car p22)) (> (cadr p33) (cadr p22))) 
                 (setq p44 (list (car p22) (+ (cadr p22) 2.0))) 
                ) 
                ((and (= (car p33) (car p22)) (< (cadr p33) (cadr p22))) 
                 (setq p44 (list (car p22) (- (cadr p22) 2.0))) 
                ) 
          ) 
          (entmake 
            (list '(0 . "LINE") (cons 10 p22) (cons 11 p44) (cons 62 1)) 
          ) 
          (entmake (list '(0 . "Circle") 
                         (cons 10 p44) 
                         (cons 40 0.5);;;0.5为穿丝孔半径 
                         (cons 62 1) 
                   ) 
          ) 
          (setvar "osmode" oldos) 
          (setvar "orthomode" oldor) 
        ) 
        (progn (princ "\n未选择到点，程序结束!") 
               (setvar "osmode" oldos) 
               (setvar "orthomode" oldor) 
        ) 
      ) 
    ) 
    (progn (princ "\n未选择到图形或图形不是多义线,程序结束!") 
           (setvar "osmode" oldos) 
           (setvar "orthomode" oldor) 
    ) 
  ) 
  (princ) 
)

loveu515 · 发表于 2023-6-8 11:37

各位帮忙给看看是怎么回事？
一是退出命令时提示错误：quit / exit abort。这个倒没什么影响。
二是执行完命令后，再新建文件会提示：**express tools**-unable to load acetutil.arx ，必须重启CAD才能解决。

ninja37 · 发表于 2022-5-15 08:03

谢谢楼主，这个我们很需要。谢谢你的无私分享。

ninja37 · 发表于 2022-5-15 08:28

大师，我想问一下，这个程序能不能改改。现在只能产生一个圆能不能一同产生一个引入线，，从圆心垂直倒多义线的引入线

zm880928 · 发表于 2022-5-15 08:46

我也是线割行业，你的插件为什么要有偏移距离。

yu960312 · 发表于 2022-5-15 08:49

zm880928 发表于 2022-5-15 08:46
我也是线割行业，你的插件为什么要有偏移距离。

慢走丝呀，外形要修刀呀

zm880928 · 发表于 2022-5-15 08:50

ninja37 发表于 2022-5-15 08:28
大师，我想问一下，这个程序能不能改改。现在只能产生一个圆能不能一同产生一个引入线，，从圆心垂直倒 ...

你是做快走丝的吧

fan_zh · 发表于 2022-5-15 12:41

收藏学习了感谢楼主

xyp1964 · 发表于 2022-5-15 14:13

ninja37 · 发表于 2022-5-15 21:48

zm880928 发表于 2022-5-15 08:50
你是做快走丝的吧

快丝没做过中丝慢丝都做过

账号		自动登录	找回密码
密码			注册

[源码] 线割外形穿线孔绘制

本帖子中包含更多资源

点评

本帖子中包含更多资源

本帖子中包含更多资源