117g 发表于 2024-10-15 17:06:55

批量作垂线


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

qazxswk 发表于 2024-10-15 20:07:52

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


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

vitalgg 发表于 2024-10-15 17:51:44

本帖最后由 vitalgg 于 2024-10-16 08:22 编辑


;; 补上函数调用就不是伪码了，用高级函数做抽象是开发能力提高的不二法门。
;; 就跟数学证明一样，不用把已知的定理从最基础的公理证明一遍。
(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))))
(prompt "请选择单条线:")
(setq ln1 (ssget ":S:E" '((0 . "*LINE"))))
(prompt "请选择一组线:")
(setq lns(ssget '((0 . "*LINE"))))

(if (andln1 lns)
    (progn ;; 确实拼错了
   (mapcar
      '(lambda(x)
      (entity:make-line
         x
         (polar
          x
          (+ (* 0.5 pi) (curve:point-firstangle (e2o (ssname ln1 0)) x))
          30)))
   (curve:inters ln1 lns acextendnone))))

http://s3.atlisp.cn/static/videos/inters-chui.mp4

自贡黄明儒 发表于 2024-10-15 17:53:05

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

xyp1964 发表于 2024-10-15 18:55:31

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

lxl217114 发表于 2024-10-16 16:39:33

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

谢谢分享，给力了。

jkop 发表于 2024-10-16 20:32:37

收藏！感谢大佬分享。
页: [1]
查看完整版本: 批量作垂线