[求助] lisp中如何修改块的基点？

feng582304

我的思路是：把块还原成1：1，然后再指定基点，再做成同名块。

但有没有更方便的做法？谢谢！

sweetsea

【KAIXIN】 发表于 2011-12-1 16:58
(defun BlockToInsertXform (P1 TransformSpec)
  (3dTransformAB
    (nth 0 TransformSpec)

感谢分享！非常方便好用！

feng582304

有哪位高手可以教一下？回复一下啦！

 

tcsl9621

通过块表取得块对像。再读取块对像中的所有对像。移动其中的对像就可实现。注意在块定义中（0，0，0）点就是块的基点。

【KAIXIN】

(defun BlockToInsertXform (P1 TransformSpec)
  (3dTransformAB
    (nth 0 TransformSpec)
    (nth 1 TransformSpec)
    (nth 2 TransformSpec)
    (nth 3 TransformSpec)
    (nth 4 TransformSpec)
    P1
  ) ;_ end 3dTransformAB
) ;_ end defun

(defun InsertToBlockXform (P1 TransformSpec)
  (3dTransformBA
    (nth 0 TransformSpec)
    (nth 1 TransformSpec)
    (nth 2 TransformSpec)
    (nth 3 TransformSpec)
    (nth 4 TransformSpec)
    P1
  ) ;_ end 3dTransformBA
) ;_ end defun

(defun BlockToInsertSetup (InsertEname
                           /
                           InsertEList
                           ZAxis
                           NCSXAxis
                           InsertAngle
                          )
  ;; Get the Entity Association List of the insert and the Z
  ;; axis of the NCS (and OCS)
  (setq ZAxis       (cdr (assoc 210 (setq InsertEList (entget InsertEName))))
        ;; The OCS X axis is, in OCS, '(1 0 0).  The NCS X axis is
        ;; therefore, in OCS,
        ;; ((cos InsertAngle) (sin InsertAngle) 0.0).
        ;; Transforming this vector to WCS gives the NCS X axis in
        ;; WCS:
        InsertAngle (cdr (assoc 50 InsertEList))
        NCSXAxis    (trans (list (cos InsertAngle) (sin InsertAngle) 0.0)
                           (cdr (assoc 210 InsertEList))
                           0
                    ) ;_ end trans
  ) ;_ end setq
  ;; Set up the return value
  (list NCSXAxis
        ;; The Y axis of the NCS (it will be a unit vector
        ;; because it's the cross product of two unit
        ;; vectors at a right angle to each other)
        (VectorCrossProduct ZAxis NCSXAxis)
        ZAxis
        ;; The insertion point of the insert
        (trans (cdr (assoc 10 InsertEList)) ZAxis 0)
        ;; The scale factors
        (list (cdr (assoc 41 InsertEList))
              (cdr (assoc 42 InsertEList))
              (cdr (assoc 43 InsertEList))
        ) ;_ end list
  ) ;_ end list
) ;_ end defun

(defun VectorCrossProduct (InputVector1 InputVector2)
  (list (- (* (cadr InputVector1) (caddr InputVector2))
           (* (cadr InputVector2) (caddr InputVector1))
        ) ;_ end -
        (- (* (caddr InputVector1) (car InputVector2))
           (* (caddr InputVector2) (car InputVector1))
        ) ;_ end -
        (- (* (car InputVector1) (cadr InputVector2))
           (* (car InputVector2) (cadr InputVector1))
        ) ;_ end -
  ) ;_ end list
) ;_ end defun

(defun 3DTransformAB (XA YA ZA OA SA P1 /)
  ;; Scale the input point to "B" system units
  (setq P1 (mapcar '* P1 SA))
  ;; Translate and set up the return value
  (mapcar '+
          OA
          ;; The following does the rotation transformation
          (list (+ (* (car XA) (car P1))
                   (* (car YA) (cadr P1))
                   (* (car ZA) (caddr P1))
                ) ;_ end +
                (+ (* (cadr XA) (car P1))
                   (* (cadr YA) (cadr P1))
                   (* (cadr ZA) (caddr P1))
                ) ;_ end +
                (+ (* (caddr XA) (car P1))
                   (* (caddr YA) (cadr P1))
                   (* (caddr ZA) (caddr P1))
                ) ;_ end +
          ) ;_ end list
  ) ;_ end mapcar
) ;_ end defun

(defun 3DTransformBA (XA YA ZA OA SA P1 /)
  ;; Translate
  (setq P1 (mapcar '- P1 OA))
  ;; Scale and set up the return value
  (mapcar '/
          ;; The following does the rotation
          (list (+ (* (car XA) (car P1))
                   (* (cadr XA) (cadr P1))
                   (* (caddr XA) (caddr P1))
                ) ;_ end +
                (+ (* (car YA) (car P1))
                   (* (cadr YA) (cadr P1))
                   (* (caddr YA) (caddr P1))
                ) ;_ end +
                (+ (* (car ZA) (car P1))
                   (* (cadr ZA) (cadr P1))
                   (* (caddr ZA) (caddr P1))
                ) ;_ end +
          ) ;_ end list
          SA
  ) ;_ end mapcar
) ;_ end defun


(defun c:KK (/ doc blks LOOP sel InsertEName BlockName blkdef
           oldInsPt1 newInsPt1 oldInsPt2 newInsPt2
           ss idx XformSpec)
  (setq doc (vla-get-activedocument (vlax-get-acad-object)))
  (setq blks (vla-get-blocks doc) LOOP t)
  (while LOOP
    (setq sel (entsel "\n选择一个图块: "))
    (if (and sel (= (cdr (assoc 0 (entget (setq InsertEName (car sel))))) "INSERT"))
      (progn
    (setq LOOP nil)
    (setq oldInsPt1 (cdr (assoc 10 (entget InsertEName)))
          BlockName (cdr (assoc 2 (entget InsertEName)))
          XformSpec (BlockToInsertSetup InsertEName))
    (setq newInsPt1 (getpoint oldInsPt1 "\n选择新的插入点: "))
    (setq oldInsPt2 (InsertToBlockXform oldInsPt1 XformSpec)
          newInsPt2 (InsertToBlockXform newInsPt1 XformSpec))
    (setq blkdef (vla-item blks BlockName))
    (vlax-for obj blkdef
      (vla-move obj (vlax-3d-point newInsPt2) (vlax-3d-point oldInsPt2)))
    (setq ss (ssget "x" (list (cons 0 "INSERT")(cons 2 BlockName))))
    (setq idx 0)
    (repeat (sslength ss)
      (setq InsertEName (ssname ss idx)
        XformSpec (BlockToInsertSetup InsertEName))
      (setq oldInsPt1 (BlockToInsertXform oldInsPt2 XformSpec)
        newInsPt1 (BlockToInsertXform newInsPt2 XformSpec))
      (vla-move (vlax-ename->vla-object InsertEName)
            (vlax-3d-point oldInsPt1) (vlax-3d-point newInsPt1))
      (setq idx (1+ idx))
      );repeat
       );progn
    );end_if
  );while
  (princ)
);End_defun

cii

试了下，有错误

yoyoho

感谢 【KAIXIN】 分享程序,非常实用!

txllap

不错，高手！