离曲线端点 指定距离d 插入块

自贡黄明儒

千古文章多闲话，论坛多废贴，我为论坛废贴添砖加瓦

1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   
2. ;;离曲线d 插入块
   
3. ;;164.23 [功能] 多段线所击点离起点近
   
4. ;;示例(HH:PickToStart (car(setq en(entsel))) (cadr en))
   
5. (defun HH:PickToStart (curve p / L1 L2 PP)
   
6.   (setq pp (vlax-curve-getclosestpointto curve (trans p 1 0)))
   
7.   (setq  L2 (vlax-curve-getDistAtParam curve
   
8.               (vlax-curve-getEndParam curve)
   
9.      )
   
10.   )
    
11.   (setq L1 (vlax-curve-getDistAtPoint curve pp))
    
12.   (> (- L2 L1) L1)
    
13. )
    
14. 
    
15. (defun _HH:MyI (e d name / ANG ANGB ECURVE P P0 PARAM PRCS)
    
16.   (setq p0 (cadr e))
    
17.   (if (= (length e) 4)
    
18.     (progn
    
19.       (setq angB (cdr (assoc 50 (entget (car (last e))))))  ;块转角
    
20.       (setq prcs (MAT:TransNested p0 (last e) 1 2))      ;将点用户转换到块坐标系 By highflybird
    
21.       (setq Ecurve (car e))            ;块内图元
    
22.       (setq prcs (vlax-curve-getClosestPointTo Ecurve prcs))
    
23.       ;;计算击点离终点近还是起点近
    
24.       (if (HH:PickToStart Ecurve prcs)
    
25.   (setq p (vlax-curve-getPointAtDist Ecurve d))
    
26.   (setq
    
27.     p (vlax-curve-getPointAtDist Ecurve
    
28.                (- (vlax-curve-getDistAtParam Ecurve
    
29.                      (vlax-curve-getEndParam Ecurve)
    
30.             )
    
31.             d
    
32.                )
    
33.       )
    
34.   )
    
35.       )
    
36.       ;;Z坐标归0,不然后算出来的角度不对
    
37.       (setq prcs (mapcar '+ '(0 0) p))
    
38.       (setq Param (vlax-curve-getParamAtPoint Ecurve prcs))
    
39.       (setq ang (angle '(0 0) (vlax-curve-getFirstDeriv Ecurve param)))
    
40.       (setq ang (+ ang angB))
    
41.       ;;离曲线d0的点，从块中转出来
    
42.       (setq p (MAT:TransNested prcs (last e) 2 1))
    
43.     )
    
44.     (progn
    
45.       (setq Ecurve (car e))
    
46.       (setq prcs (vlax-curve-getClosestPointTo Ecurve (cadr e)))
    
47.       (if (HH:PickToStart Ecurve prcs)
    
48.   (setq p (vlax-curve-getPointAtDist Ecurve d))
    
49.   (setq
    
50.     p (vlax-curve-getPointAtDist Ecurve
    
51.                (- (vlax-curve-getDistAtParam Ecurve
    
52.                      (vlax-curve-getEndParam Ecurve)
    
53.             )
    
54.             d
    
55.                )
    
56.       )
    
57.   )
    
58.       )
    
59.       (setq prcs (mapcar '+ '(0 0) p))
    
60.       (setq Param (vlax-curve-getParamAtPoint Ecurve prcs))
    
61.       (setq ang (angle '(0 0) (vlax-curve-getFirstDeriv Ecurve param)))
    
62.     )
    
63.   )
    
64. 
    
65.   ;;1 插入块
    
66.   (entmake (list '(0 . "INSERT")
    
67.      (cons 2 name)
    
68.      (cons 10 p)
    
69.      (cons 50 Ang)
    
70.      (cons 8 "0")
    
71.      (cons 41 1)
    
72.      (cons 42 1)
    
73.      (cons 43 1)
    
74.      )
    
75.   )
    
76.   ;;2 旋转块
    
77.   ((if command-s  command-s vl-cmdf) "._rotate" (entlast) "" "non" p pause)
    
78.   (princ "\n 插入块 MyI")
    
79. )
    
80. 
    
81. (defun C:MyI (/ D D0 E EN MYI NAME NAME0)
    
82.   ((if command-s  command-s vl-cmdf) "_.ucs" "_w")
    
83.   (if (setq MyI (GETENV "HuangMR\\MyI"));(sETENV "HuangMR\\MyI" "")
    
84.     (progn
    
85.       (setq MyI (read MyI))
    
86.       (setq d0 (car MyI))
    
87.       (setq name0 (cdr MyI))
    
88.     )
    
89.   )
    
90. 
    
91.   (if d0
    
92.     (setq d (getreal (strcat "\n 块插入距离<" (vl-princ-to-string d0) ">:")))
    
93.     (setq d (getreal "\n 块插入距离:"))
    
94.   )
    
95.   (if d
    
96.     (setq d0 d)
    
97.     (setq d d0)
    
98.   )
    
99.   
    
100.   (if (setq e (LM:ssget "\n 拾取块名:" '("_+.:E:S" ((0 . "INSERT")))))
     
101.     (progn
     
102.       (setq e (ssname e 0))
     
103.       (setq en (entget e))
     
104.       (setq name (cdr (assoc 2 en)))
     
105.     )
     
106.     (if  name0
     
107.       (setq name (getstring (strcat "\n 块名<" name0 ">:")))
     
108.       (setq name (getstring "\n 块名:"))
     
109.     )
     
110.   )
     
111.   (if (/= name "")
     
112.     (setq name0 name)
     
113.     (setq name name0)
     
114.   )
     
115.   
     
116.   (if (and d name (/= name ""))
     
117.     (progn
     
118.       (setenv "HuangMR\\MyI" (vl-prin1-to-string (cons d name)))
     
119.       (if (and (tblobjname "BLOCK" name) (setq e (nentsel "\n 点取曲线:")))
     
120.   (_HH:MyI e d name)
     
121.       )
     
122.     )
     
123.   )
     
124.   (princ)
     
125. )
     
126. ;;离曲线d 插入块
     
127. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;<br /> ;;离曲线d 插入块<br /> ;;164.23 [功能] 多段线所击点离起点近<br /> ;;示例(HH:PickToStart (car(setq en(entsel))) (cadr en))<br /> (defun HH:PickToStart (curve p / L1 L2 PP)<br />   (setq pp (vlax-curve-getclosestpointto curve (trans p 1 0)))<br />   (setq  L2 (vlax-curve-getDistAtParam curve<br />               (vlax-curve-getEndParam curve)<br />      )<br />   )<br />   (setq L1 (vlax-curve-getDistAtPoint curve pp))<br />   (> (- L2 L1) L1)<br /> )<br /> <br /> (defun _HH:MyI (e d name / ANG ANGB ECURVE P P0 PARAM PRCS)<br />   (setq p0 (cadr e))<br />   (if (= (length e) 4)<br />     (progn<br />       (setq angB (cdr (assoc 50 (entget (car (last e))))))  ;块转角<br />       (setq prcs (MAT:TransNested p0 (last e) 1 2))      ;将点用户转换到块坐标系 <a href="http://bbs.mjtd.com/forum.php?mod=forumdisplay&fid=3&filter=typeid&typeid=108" target="_blank">By highflybird</a><br />       (setq Ecurve (car e))            ;块内图元<br />       (setq prcs (vlax-curve-getClosestPointTo Ecurve prcs))<br />       ;;计算击点离终点近还是起点近<br />       (if (HH:PickToStart Ecurve prcs)<br />   (setq p (vlax-curve-getPointAtDist Ecurve d))<br />   (setq<br />     p (vlax-curve-getPointAtDist Ecurve<br />                (- (vlax-curve-getDistAtParam Ecurve<br />                      (vlax-curve-getEndParam Ecurve)<br />             )<br />             d<br />                )<br />       )<br />   )<br />       )<br />       ;;Z坐标归0,不然后算出来的角度不对<br />       (setq prcs (mapcar '+ '(0 0) p))<br />       (setq Param (vlax-curve-getParamAtPoint Ecurve prcs))<br />       (setq ang (angle '(0 0) (vlax-curve-getFirstDeriv Ecurve param)))<br />       (setq ang (+ ang angB))<br />       ;;离曲线d0的点，从块中转出来<br />       (setq p (MAT:TransNested prcs (last e) 2 1))<br />     )<br />     (progn<br />       (setq Ecurve (car e))<br />       (setq prcs (vlax-curve-getClosestPointTo Ecurve (cadr e)))<br />       (if (HH:PickToStart Ecurve prcs)<br />   (setq p (vlax-curve-getPointAtDist Ecurve d))<br />   (setq<br />     p (vlax-curve-getPointAtDist Ecurve<br />                (- (vlax-curve-getDistAtParam Ecurve<br />                      (vlax-curve-getEndParam Ecurve)<br />             )<br />             d<br />                )<br />       )<br />   )<br />       )<br />       (setq prcs (mapcar '+ '(0 0) p))<br />       (setq Param (vlax-curve-getParamAtPoint Ecurve prcs))<br />       (setq ang (angle '(0 0) (vlax-curve-getFirstDeriv Ecurve param)))<br />     )<br />   )<br /> <br />   ;;1 插入块<br />   (entmake (list '(0 . "INSERT")<br />      (cons 2 name)<br />      (cons 10 p)<br />      (cons 50 Ang)<br />      (cons 8 "0")<br />      (cons 41 1)<br />      (cons 42 1)<br />      (cons 43 1)<br />      )<br />   )<br />   ;;2 旋转块<br />   ((if command-s  command-s vl-cmdf) "._rotate" (entlast) "" "non" p pause)<br />   (princ "\n 插入块 MyI")<br /> )<br /> <br /> (defun C:MyI (/ D D0 E EN MYI NAME NAME0)<br />   ((if command-s  command-s vl-cmdf) "_.ucs" "_w")<br />   (if (setq MyI (GETENV "HuangMR\\MyI"));(sETENV "HuangMR\\MyI" "")<br />     (progn<br />       (setq MyI (read MyI))<br />       (setq d0 (car MyI))<br />       (setq name0 (cdr MyI))<br />     )<br />   )<br /> <br />   (if d0<br />     (setq d (getreal (strcat "\n 块插入距离<" (vl-princ-to-string d0) ">:")))<br />     (setq d (getreal "\n 块插入距离:"))<br />   )<br />   (if d<br />     (setq d0 d)<br />     (setq d d0)<br />   )<br />   <br />   (if (setq e (LM:ssget "\n 拾取块名:" '("_+.:E:S" ((0 . "INSERT")))))<br />     (progn<br />       (setq e (ssname e 0))<br />       (setq en (entget e))<br />       (setq name (cdr (assoc 2 en)))<br />     )<br />     (if  name0<br />       (setq name (getstring (strcat "\n 块名<" name0 ">:")))<br />       (setq name (getstring "\n 块名:"))<br />     )<br />   )<br />   (if (/= name "")<br />     (setq name0 name)<br />     (setq name name0)<br />   )<br />   <br />   (if (and d name (/= name ""))<br />     (progn<br />       (setenv "HuangMR\\MyI" (vl-prin1-to-string (cons d name)))<br />       (if (and (tblobjname "BLOCK" name) (setq e (nentsel "\n 点取曲线:")))<br />   (_HH:MyI e d name)<br />       )<br />     )<br />   )<br />   (princ)<br /> )<br /> ;;离曲线d 插入块<br /> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

自贡黄明儒

以上实际 是我写的第二版，解决了画桁架上插入块的问题。实用上还是不方便，最后仿命令I，感觉好多了

czb203

自贡黄明儒 发表于 2022-12-24 08:33
以上实际 是我写的第二版，解决了画桁架上插入块的问题。实用上还是不方便，最后仿命令I，感觉好多了

大佬，第二版也分享下呗

guankuiwu

真不错！很好

p-3-ianlcc

自贡黄明儒 发表于 2022-12-24 08:33
以上实际 是我写的第二版，解决了画桁架上插入块的问题。实用上还是不方便，最后仿命令I，感觉好多了

黄大师太强了～
不知道有没有得分享呢？