社区 › AutoCAD工具插件 › 批量交点插入块（支持选块样板，多段线、曲线、直线）

屋檐下的路人 发表于 2021-4-25 22:13:04

学习~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

qq2431056687 发表于 2021-6-19 12:07:04

谢谢分享。

宁静港湾 发表于 2021-6-24 23:57:49

谢谢朋友，真是好人，

w379106181 发表于 2021-6-30 10:00:31

支持一下...
支持一下...

xiaojiajun160 发表于 2021-11-8 15:59:19

犀利！！牛噢 ！

dforme 发表于 2021-11-15 11:11:12

感谢，非常实用的程序

技术工作室 发表于 2022-9-7 12:22:10

学习学习支持一下

流动的清泉 发表于 2023-11-1 19:37:27

这个源码好像和你的不完全一样
(defun c:t1 ()

(vl-load-com)
(setq cmd (getvar "cmdecho"))
(setvar "cmdecho" 0 )
(setq blockent (ssname (ssget ＂L＂) 0))
(command "select" "")

(setvar "osmode" 15359)
(princ "\n★功能：在批量图元的相交点处插入块")
(princ "\n请选择多段线、样条曲线、直线、圆、圆弧或椭圆：")
(command "undo" "be")
(if (not (setq ss (ssget '((0 . "*LINE,ARC,CIRCLE,ELLIPSE")))))
    (progn (princ "\n提示：未选取图元，程序退出。\n") (exit))
)
(setq acad (vlax-get-acad-object))
(setq acaddocument (vla-get-activedocument acad))
(setq mspace (vla-get-modelspace acaddocument))



(setq blockname (cdr (assoc 2 (entget blockent))))
(setq blockX (cdr (assoc 41 (entget blockent))))

(setvar "osmode" 0)
(setq ptlist (ssinters ss))
(foreach pt ptlist
    (vla-insertblock
      mspace
      (vlax-3d-point pt)
      blockname
      blockX
      blockX
      blockX
      0
    )
)
(command "undo" "e")
(setvar "osmode" 15359)
(princ)
)

(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
          (setq interpts (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
)

tensir 发表于 2024-7-9 13:15:43

感谢作者的分享！

fengche1915@ 发表于 2024-8-27 10:23:43

;;;*****交点插块 程序开始*****
(defun c:t1 ()
(setvar "cmdecho" 0)
(vl-load-com)
(setvar "osmode" 15359)
(princ
    "\n★功能：在批量图元的相交点处插入块。\n提示：在执行此功能前请确定图块的基点是否在其中心位置，否则会出现插入点偏位现象。\n"
)
(princ "\n请选择多段线、样条曲线、直线、圆、圆弧或椭圆：")
(command "undo" "be")
(if (not (setq ss (ssget '((0 . "*LINE,ARC,CIRCLE,ELLIPSE")))))
    (progn (princ "\n提示：未选取图元，程序退出。\n") (exit))
)
(setq acad (vlax-get-acad-object))
(setq acaddocument (vla-get-activedocument acad))
(setq mspace (vla-get-modelspace acaddocument))
(while
    (progn (setq blockent   (entsel "\n请选择要插入交点的图块：")
               blockentname (car blockent)
         )
         (not      (if (= blockent nil)
                  nil
                  (= (cdr (assoc 0 (entget blockentname))) "INSERT")
                )
         )
    )
(princ
       "\n提示：选取的不是图块或未选取任何图元,请重新选取："
   )
)
(setq blockname (cdr (assoc 2 (entget blockentname))))
(initget 6)
(if (not (setq bili (getreal "\n插入比例<1.0>")))
    (setq bili 1.0)
)
(setvar "osmode" 0)
(setq ptlist (ssinters ss))
(foreach pt ptlist
    (vla-insertblock
      mspace
      (vlax-3d-point pt)
      blockname
      bili
      bili
      bili
      0
    )
)
(command "undo" "e")
(setvar "osmode" 15359)
(princ)
)

(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
          (setq      interpts
               (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
)
;;;*****交点插块 程序结束*****

查看完整版本: 批量交点插入块（支持选块样板，多段线、曲线、直线）