向块内添加多段线

dcl1214 · 发表于 2024-8-17 14:01:35

(defun $block-add-pline$ (ent pts lst / $kuai-wai-pt->kuai-nei-pt$ blk name obj points)
;向块内添加多段线;($block-add-pline$(car(entsel))(list (getpoint "请绘制直线起点准备添加到块中")(getpoint "请绘制终点"))nil)
(defun $kuai-wai-pt->kuai-nei-pt$ (ent pts
/ dxf
enum:blk lst
nestref revnest
zx:disptomatrix
zx:mxm zx:mxp
zx:mxv zx:refgeom
zx:revrefgeom
zx:trp pts-new
)
;块外坐标转换为块内坐标,返回的是三维坐标
(defun zx:mxm (m q)
; 矩阵相乘
(mapcar (function (lambda (r) (zx:mxv (zx:trp q) r))) m)
)
(defun zx:mxv (m v)
; 向量或点的矩阵变换(向量乘矩阵)
(mapcar (function (lambda (r) (apply '+ (mapcar '* r v))))
m
)
)
(defun zx:trp (m)
; 矩阵转置
(apply 'mapcar (cons 'list m))
)
(defun zx:DispToMatrix (mat disp)
; 把位移矢量添加到矩阵中
(reverse
(cons '(0. 0. 0. 1.)
(reverse
(mapcar (function (lambda (a b)
(reverse (cons b (reverse a)))
)
)
mat
disp
)
)
)
)
)
(defun zx:mxp (m p)
; 点的矩阵(4x4 matrix) 变换
(reverse
(cdr
(reverse (zx:mxv m (reverse (cons '1.0 (reverse p)))))
)
)
)
;; 功能：图块的变换矩阵
(defun zx:RefGeom (ename / DXF ang nrm mat DISP sx sy sz sa ca)
(setq DXF (entget ename)
ang (cdr (assoc 50 DXF))
nrm (cdr (assoc 210 DXF))
sx (cdr (assoc 41 DXF))
sy (cdr (assoc 42 DXF))
sz (cdr (assoc 43 DXF))
sa (sin ang)
ca (cos ang)
)
(list
(setq mat
(ZX:mxm
(mapcar (function (lambda (v) (trans v 0 nrm T)))
'((1.0 0.0 0.0) (0.0 1.0 0.0) (0.0 0.0 1.0))
)
(list
(list (* ca sx) (- (* sa sy)) 0.0)
(list (* sa sx) (* ca sy) 0.0)
(list 0 0 sz)
)
)
)
(setq disp
(mapcar
'-
(trans (cdr (assoc 10 DXF)) nrm 0)
(ZX:mxv
mat
(cdr (assoc 10 (tblsearch "BLOCK" (cdr (assoc 2 DXF)))))
)
)
)
)
(append
(mapcar 'append mat (mapcar 'list disp))
'((0. 0. 0. 1.))
)
)
;; 功能：图块的变换矩阵的逆矩阵,输入：块参照的图元名,输出：块参照的变换矩阵的逆矩阵
(defun zx:RevRefGeom (ename / dxf ang nrm mat disp)
(setq dxf (entget ename))
(setq ang (- (cdr (assoc 50 dxf))))
(setq nrm (cdr (assoc 210 dxf)))
(setq mat
(zx:mxm
(list (list (/ 1 (cdr (assoc 41 dxf))) 0.0 0.0)
(list 0.0 (/ 1 (cdr (assoc 42 dxf))) 0.0)
(list 0.0 0.0 (/ 1 (cdr (assoc 43 dxf))))
)
(zx:mxm
(list (list (cos ang) (- (sin ang)) 0.0)
(list (sin ang) (cos ang) 0.0)
'(0.0 0.0 1.0)
)
(mapcar (function (lambda (v) (trans v nrm 0 T)))
'((1.0 0.0 0.0) (0.0 1.0 0.0) (0.0 0.0 1.0))
)
)
)
)
(setq disp
(mapcar
'-
(cdr (assoc 10 (tblsearch "BLOCK" (cdr (assoc 2 dxf)))))
(zx:mxv mat (trans (cdr (assoc 10 dxf)) nrm 0))
)
)
(append
(mapcar 'append mat (mapcar 'list disp))
'((0. 0. 0. 1.))
)
)
;;块外边的点坐标（WCS）转为块内坐标。
(defun RevNest (ename pts / BLK DXF LST MAT PENT PT)
;转换到块内坐标
(setq mat (zx:RevRefGeom ename))
(mapcar (function (lambda (p) (zx:mxp mat p))) pts)
)
(if (and pts (= (type pts) 'list))
(progn
(setq pts (mapcar (function (lambda (a)
(list (car a) (cadr a) 0)
)
)
pts
)
) ;保证三维坐标
(setq pts-new (RevNest ent pts))
)
)
(if pts-new
pts-new
pts
)
)
(and ent
pts
(= (CDR (ASSOC 0 (ENTGET ENT))) "INSERT")
(setq pts (vl-remove nil pts))
(> (length pts) 1)
(progn
(SETQ OBJ (vl-catch-all-apply 'vlax-ename->vla-object (list ent)))
(and
(setq name (vl-catch-all-apply
'vla-get-effectivename
(list obj)
)
)
(setq
blk
(vl-catch-all-apply
'vla-item
(list (vla-get-blocks
(vla-get-activeDocument (vlax-get-acad-object))
)
name
)
)
) ;(vlax-dump-object blk t);查看属性块支持哪些方法
)
(setq
pts (mapcar (function (lambda (a) (list (car a) (cadr a) 0)))
pts
)
) ;保证是三维坐标
(and (setq pts ($kuai-wai-pt->kuai-nei-pt$ ent pts))
;块外坐标转换为块内坐标
(setq pts (apply 'append pts))
(setq points (vlax-make-safearray
vlax-vbDouble
(cons 0 (- (length pts) 1))
)
)
(vl-catch-all-apply 'vlax-safearray-fill (list points pts))
(progn
(vl-catch-all-apply
'vlax-invoke-method
(list blk 'AddPolyline points)
)
(vl-cmdf "_.attsync" "n" name) ;返回同步结果给and
)
)
)
)
)

(defun $block-add-pline$ (ent pts lst / $kuai-wai-pt->kuai-nei-pt$ blk name obj points) 
          ;向块内添加多段线;($block-add-pline$(car(entsel))(list (getpoint "请绘制直线起点准备添加到块中")(getpoint "请绘制终点"))nil) 
  (defun $kuai-wai-pt->kuai-nei-pt$ (ent   pts 
             /     dxf 
             enum:blk   lst 
             nestref   revnest 
             zx:disptomatrix 
             zx:mxm   zx:mxp 
             zx:mxv   zx:refgeom 
             zx:revrefgeom 
             zx:trp   pts-new 
            ) 
          ;块外坐标转换为块内坐标,返回的是三维坐标 
    (defun zx:mxm (m q) 
          ; 矩阵相乘 
      (mapcar (function (lambda (r) (zx:mxv (zx:trp q) r))) m) 
    ) 
    (defun zx:mxv (m v) 
          ; 向量或点的矩阵变换(向量乘矩阵) 
      (mapcar (function (lambda (r) (apply '+ (mapcar '* r v)))) 
        m 
      ) 
    ) 
    (defun zx:trp (m) 
          ; 矩阵转置 
      (apply 'mapcar (cons 'list m)) 
    ) 
    (defun zx:DispToMatrix (mat disp) 
          ; 把位移矢量添加到矩阵中 
      (reverse 
  (cons '(0. 0. 0. 1.) 
        (reverse 
    (mapcar  (function (lambda (a b) 
            (reverse (cons b (reverse a))) 
          ) 
      ) 
      mat 
      disp 
    ) 
        ) 
  ) 
      ) 
    ) 
    (defun zx:mxp (m p) 
          ; 点的矩阵(4x4 matrix) 变换 
      (reverse 
  (cdr 
    (reverse (zx:mxv m (reverse (cons '1.0 (reverse p))))) 
  ) 
      ) 
    ) 
    ;; 功能：图块的变换矩阵 
    (defun zx:RefGeom (ename / DXF ang nrm mat DISP sx sy sz sa ca) 
      (setq DXF  (entget ename) 
      ang  (cdr (assoc 50 DXF)) 
      nrm  (cdr (assoc 210 DXF)) 
      sx  (cdr (assoc 41 DXF)) 
      sy  (cdr (assoc 42 DXF)) 
      sz  (cdr (assoc 43 DXF)) 
      sa  (sin ang) 
      ca  (cos ang) 
      ) 
      (list 
  (setq mat 
         (ZX:mxm 
     (mapcar (function (lambda (v) (trans v 0 nrm T))) 
       '((1.0 0.0 0.0) (0.0 1.0 0.0) (0.0 0.0 1.0)) 
     ) 
     (list 
       (list (* ca sx) (- (* sa sy)) 0.0) 
       (list (* sa sx) (* ca sy) 0.0) 
       (list 0 0 sz) 
     ) 
         ) 
  ) 
  (setq disp 
         (mapcar 
     '- 
     (trans (cdr (assoc 10 DXF)) nrm 0) 
     (ZX:mxv 
       mat 
       (cdr (assoc 10 (tblsearch "BLOCK" (cdr (assoc 2 DXF))))) 
     ) 
         ) 
  ) 
      ) 
      (append 
  (mapcar 'append mat (mapcar 'list disp)) 
  '((0. 0. 0. 1.)) 
      ) 
    ) 
    ;; 功能：图块的变换矩阵的逆矩阵,输入：块参照的图元名,输出：块参照的变换矩阵的逆矩阵 
    (defun zx:RevRefGeom (ename / dxf ang nrm mat disp) 
      (setq dxf (entget ename)) 
      (setq ang (- (cdr (assoc 50 dxf)))) 
      (setq nrm (cdr (assoc 210 dxf))) 
      (setq mat 
       (zx:mxm 
         (list (list (/ 1 (cdr (assoc 41 dxf))) 0.0 0.0) 
         (list 0.0 (/ 1 (cdr (assoc 42 dxf))) 0.0) 
         (list 0.0 0.0 (/ 1 (cdr (assoc 43 dxf)))) 
         ) 
         (zx:mxm 
     (list (list (cos ang) (- (sin ang)) 0.0) 
           (list (sin ang) (cos ang) 0.0) 
           '(0.0 0.0 1.0) 
     ) 
     (mapcar (function (lambda (v) (trans v nrm 0 T))) 
       '((1.0 0.0 0.0) (0.0 1.0 0.0) (0.0 0.0 1.0)) 
     ) 
         ) 
       ) 
      ) 
      (setq disp 
       (mapcar 
         '- 
         (cdr (assoc 10 (tblsearch "BLOCK" (cdr (assoc 2 dxf))))) 
         (zx:mxv mat (trans (cdr (assoc 10 dxf)) nrm 0)) 
       ) 
      ) 
      (append 
  (mapcar 'append mat (mapcar 'list disp)) 
  '((0. 0. 0. 1.)) 
      ) 
    ) 
    ;;块外边的点坐标（WCS）转为块内坐标。 
    (defun RevNest (ename pts / BLK DXF LST MAT PENT PT) 
          ;转换到块内坐标 
      (setq mat (zx:RevRefGeom ename)) 
      (mapcar (function (lambda (p) (zx:mxp mat p))) pts) 
    ) 
    (if  (and pts (= (type pts) 'list)) 
      (progn 
  (setq pts (mapcar (function (lambda (a) 
              (list (car a) (cadr a) 0) 
            ) 
        ) 
        pts 
      ) 
  )        ;保证三维坐标 
  (setq pts-new (RevNest ent pts)) 
      ) 
    ) 
    (if  pts-new 
      pts-new 
      pts 
    ) 
  ) 
  (and ent 
       pts 
       (= (CDR (ASSOC 0 (ENTGET ENT))) "INSERT") 
       (setq pts (vl-remove nil pts)) 
       (> (length pts) 1) 
       (progn 
   (SETQ OBJ (vl-catch-all-apply 'vlax-ename->vla-object (list ent))) 
   (and 
     (setq name (vl-catch-all-apply 
      'vla-get-effectivename 
      (list obj) 
          ) 
     ) 
     (setq 
       blk 
        (vl-catch-all-apply 
    'vla-item 
    (list (vla-get-blocks 
      (vla-get-activeDocument (vlax-get-acad-object)) 
          ) 
          name 
    ) 
        ) 
     )        ;(vlax-dump-object blk t);查看属性块支持哪些方法 
   ) 
   (setq 
     pts (mapcar (function (lambda (a) (list (car a) (cadr a) 0))) 
           pts 
         ) 
   )        ;保证是三维坐标 
   (and (setq pts ($kuai-wai-pt->kuai-nei-pt$ ent pts)) 
          ;块外坐标转换为块内坐标 
        (setq pts (apply 'append pts)) 
        (setq points (vlax-make-safearray 
           vlax-vbDouble 
           (cons 0 (- (length pts) 1)) 
         ) 
        ) 
        (vl-catch-all-apply 'vlax-safearray-fill (list points pts)) 
        (progn 
    (vl-catch-all-apply 
      'vlax-invoke-method 
      (list blk 'AddPolyline points) 
    ) 
    (vl-cmdf "_.attsync" "n" name) ;返回同步结果给and 
        ) 
   ) 
       ) 
  ) 
)

xxyyzzlg · 发表于 2024-8-17 15:33:07

感谢分享源码，先收藏备用

树櫴希德 · 发表于 2024-8-17 15:54:31

xxyyzzlg 发表于 2024-8-17 15:33
感谢分享源码，先收藏备用

居然被你占了沙发

muai2010 · 发表于 2024-8-17 16:01:37

向快内添加和移除任意实体有木有

xxyyzzlg · 发表于 2024-8-17 16:14:50

树櫴希德发表于 2024-8-17 15:54
居然被你占了沙发

论坛被攻击，我捡了个漏

754169140 · 发表于 2024-8-19 10:08:08

感谢分享感谢分享感谢分享

magicheno · 发表于 2024-8-19 10:43:11

感谢大佬分享

glcsq · 发表于 2024-9-17 10:04:13

谢谢大佬，收藏学习。

树櫴希德 · 发表于 2024-9-29 16:41:25

怎么添加不了有成功的吗？

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

[源码] 向块内添加多段线

评分

点评