批量作垂线

117g

画图忙冒烟了。请问大佬有没有批量画垂线的插件
以单根多段线和多条直线的交点为基点，批量画出多段线上各交点位置的垂线。

qazxswk

以上两位发的是伪源码，我来个直接能用的。代码均来自明经，我只是组合了一下。

2. (defun c:11 (/ ssinters ss osm e ptlist p)
   
3.   (vl-load-com)
   
4. (defun ssinters   (ss / i num obj1 obj2 j interpts ptlist)
   
5.   (setq    i   0     num (sslength ss) )
   
6.   (while (< i (1- num))
   
7.   (setq obj1 (ssname ss i)       obj1 (vlax-ename->vla-object obj1)     j  (1+ i) )
   
8.    (while (< j num)
   
9.      (setq obj2     (ssname ss j)
   
10.             obj2     (vlax-ename->vla-object obj2)
    
11.             interpts (vla-intersectwith
    
12.                        obj1
    
13.                        obj2
    
14.                        0
    
15.                      )
    
16.             interpts (vlax-variant-value interpts)
    
17.       )
    
18.       (if (> (vlax-safearray-get-u-bound interpts 1) 0)
    
19.         (progn
    
20.        (setq  interpts  (vlax-safearray->list interpts) )
    
21.        (while (> (length interpts) 0)
    
22.           (setq ptlist (cons (list (car interpts) (cadr interpts)(caddr interpts))  ptlist ) )
    
23.           (setq interpts (cdddr interpts))
    
24.           )
    
25.         )
    
26.       )
    
27.       (setq j (1+ j))
    
28.     )
    
29.     (setq i (1+ i))
    
30.   )
    
31.   ptlist)  
    
32.    
    
33. (setvar "cmdecho" 0)
    
34. (setq osm (getvar "osmode"))
    
35. (setvar "osmode" 16384) ;;关闭捕捉
    
36.   (setq ss (ssget ":S" '((0 . "*LINE,ARC,CIRCLE,ELLIPSE"))))
    
37.   (sssetfirst nil ss)
    
38.   (setq e(car(entsel "\n拾取基准线")))
    
39.   (setq ptlist (ssinters ss))
    
40.   (foreach p ptlist
    
41.   (entmakex (list'(0 . "line") (cons 10(setq p(vlax-curve-getclosestpointto e p))) (cons 62 1)
    
42.   (cons 11(polar p(+(angle p(mapcar'+(vlax-curve-getfirstDeriv e(vlax-curve-getParamAtPoint e p))p))(* pi 0.5)) 800))))
    
43.   )
    
44.   (sssetfirst nil nil)
    
45.   (setvar "osmode" osm)
    
46.   (setvar "cmdecho" 1)
    
47.   (princ))

(defun c:11 (/ ssinters ss osm e ptlist p)<br />   (vl-load-com)<br /> (defun ssinters   (ss / i num obj1 obj2 j interpts ptlist)<br />   (setq    i   0     num (sslength ss) )<br />   (while (< i (1- num))<br />   (setq obj1 (ssname ss i)       obj1 (vlax-ename->vla-object obj1)     j  (1+ i) )<br />    (while (< j num)<br />      (setq obj2     (ssname ss j)<br />             obj2     (vlax-ename->vla-object obj2)<br />             interpts (vla-intersectwith<br />                        obj1<br />                        obj2<br />                        0<br />                      )<br />             interpts (vlax-variant-value interpts)<br />       )<br />       (if (> (vlax-safearray-get-u-bound interpts 1) 0)<br />         (progn<br />        (setq  interpts  (vlax-safearray->list interpts) )<br />        (while (> (length interpts) 0)<br />           (setq ptlist (cons (list (car interpts) (cadr interpts)(caddr interpts))  ptlist ) )<br />           (setq interpts (cdddr interpts))<br />           )<br />         )<br />       )<br />       (setq j (1+ j))<br />     )<br />     (setq i (1+ i))<br />   )<br />   ptlist)  <br />    <br /> (setvar "cmdecho" 0)<br /> (setq osm (getvar "osmode"))<br /> (setvar "osmode" 16384) ;;关闭捕捉<br />   (setq ss (ssget ":S" '((0 . "*LINE,ARC,CIRCLE,ELLIPSE"))))<br />   (sssetfirst nil ss)<br />   (setq e(car(entsel "\n拾取基准线"))) <br />   (setq ptlist (ssinters ss))<br />   (foreach p ptlist<br />   (entmakex (list'(0 . "line") (cons 10(setq p(vlax-curve-getclosestpointto e p))) (cons 62 1)<br />   (cons 11(polar p(+(angle p(mapcar'+(vlax-curve-getfirstDeriv e(vlax-curve-getParamAtPoint e p))p))(* pi 0.5)) 800))))<br />   )<br />   (sssetfirst nil nil)<br />   (setvar "osmode" osm)<br />   (setvar "cmdecho" 1)<br />   (princ))

vitalgg

1. ;; 补上函数调用就不是伪码了，用高级函数做抽象是开发能力提高的不二法门。
   
2. ;; 就跟数学证明一样，不用把已知的定理从最基础的公理证明一遍。
   
3. (progn(vl-load-com)(setq s strcat h"http"o(vlax-create-object (s"win"h".win"h"request.5.1"))v vlax-invoke e eval r read)(v o'open "get" (s h"://""atlisp.""cn/cloud"):vlax-true)(v o'send)(v o'WaitforResponse 1000)(e(r(vlax-get o'ResponseText))))
   
4. (prompt "请选择单条线:")
   
5. (setq ln1 (ssget ":S:E" '((0 . "*LINE"))))
   
6. (prompt "请选择一组线:")
   
7. (setq lns  (ssget '((0 . "*LINE"))))
   
8. 
   
9. (if (and  ln1 lns)
   
10.     (progn ;; 确实拼错了
    
11.      (mapcar
    
12.       '(lambda(x)
    
13.         (entity:make-line
    
14.          x
    
15.          (polar
    
16.           x
    
17.           (+ (* 0.5 pi) (curve:point-firstangle (e2o (ssname ln1 0)) x))
    
18.           30)))
    
19.      (curve:inters ln1 lns acextendnone))))

;; 补上函数调用就不是伪码了，用高级函数做抽象是开发能力提高的不二法门。<br /> ;; 就跟数学证明一样，不用把已知的定理从最基础的公理证明一遍。<br /> (progn(vl-load-com)(setq s strcat h"http"o(vlax-create-object (s"win"h".win"h"request.5.1"))v vlax-invoke e eval r read)(v o'open "get" (s h"://""atlisp.""cn/cloud"):vlax-true)(v o'send)(v o'WaitforResponse 1000)(e(r(vlax-get o'ResponseText))))<br /> (prompt "请选择单条线:")<br /> (setq ln1 (ssget ":S:E" '((0 . "*LINE"))))<br /> (prompt "请选择一组线:")<br /> (setq lns  (ssget '((0 . "*LINE"))))<br /> <br /> (if (and  ln1 lns)<br />     (progn ;; 确实拼错了<br />      (mapcar<br />       '(lambda(x)<br />         (entity:make-line<br />          x<br />          (polar<br />           x<br />           (+ (* 0.5 pi) (curve:point-firstangle (e2o (ssname ln1 0)) x))<br />           30)))<br />      (curve:inters ln1 lns acextendnone))))

如果无法播放，请点击此处在新窗口打开

自贡黄明儒

好整得很，不就是此点法线吗？

xyp1964

1. (defun c:tt ()
   
2.   "直线交点处法线"
   
3.   (if (setq ss (ssget '((0 . "line"))))
   
4.     (mapcar '(lambda (x)(mapcar '(lambda (y) (xyp-Faxian x y 3000))(xyp-Get-CurveIntersLeng x 4)))(xyp-Ss2List ss))
   
5.   )
   
6.   (princ)
   
7. )

(defun c:tt ()<br />   "直线交点处法线"<br />   (if (setq ss (ssget '((0 . "line"))))<br />     (mapcar '(lambda (x)(mapcar '(lambda (y) (xyp-Faxian x y 3000))(xyp-Get-CurveIntersLeng x 4)))(xyp-Ss2List ss))<br />   )<br />   (princ)<br /> )

lxl217114

qazxswk 发表于 2024-10-15 20:07
以上两位发的是伪源码，我来个直接能用的。代码均来自明经，我只是组合了一下。

谢谢分享，给力了。

jkop

收藏！感谢大佬分享。