批量旋转对象

sz721 · 发表于 2015-11-20 09:39

本帖最后由 sz721 于 2016-1-18 08:18 编辑

使所有选定的对象（多行文字，单行文字，引线标示和图块）匹配当前UCS。

下载地址看5楼。

xiaolong1487 · 发表于 2015-11-20 11:49

看起来不错哦！

lucas_3333 · 发表于 2015-11-20 11:55

长老批量发源码啊,赞!

香田里浪人 · 发表于 2015-11-20 21:19

好像不能运行

Gu_xl · 发表于 2015-11-21 20:48

转发别人的源码时，请保留版权信息！
源码来源：http://www.cadtutor.net/forum/sh ... of-objects-to-zero-(based-on-current-UCS)

习习谷风 · 发表于 2016-1-17 00:57

这个尊重别人劳动成果很重要

tumu2008323 · 发表于 2016-1-17 19:09

谁可以上传一下吗？五楼地址注册了还是不能下载啊

lucas_3333 · 发表于 2016-1-17 19:14

tumu2008323 发表于 2016-1-17 19:09
谁可以上传一下吗？五楼地址注册了还是不能下载啊

;;; ------------------------------------------------------------------------
;;; ZeroRotation.lsp v1.2
;;;
;;; Copyright?03.09.09
;;; Alan J. Thompson (alanjt)
;;;
;;; Contact: alanjt @ TheSwamp
;;; Permission to use, copy, modify, and distribute this software
;;; for any purpose and without fee is hereby granted, provided
;;; that the above copyright notice appears in all copies and
;;; that both that copyright notice and the limited warranty and
;;; restricted rights notice below appear in all supporting
;;; documentation.
;;;
;;; The following program(s) are provided "as is" and with all faults.
;;; Alan J. Thompson DOES NOT warrant that the operation of the program(s)
;;; will be uninterrupted and/or error free.
;;;
;;; Set objects (Multileaders, Text, Mtext, Blocks) with a
;;; rotation of 0 (relative to current UCS).
;;;
;;; Revision History:
;;;
;;; v1.1 (10.23.09) 1. Minor rewrite for speed optimization.
;;; v1.2 (05.31.11) 1. Complete rewrite.
;;;
;;; ------------------------------------------------------------------------
(defun c:TE () (c:ZeroRotation))
(defun c:ZeroRotation (/ *error* AT:UCSAngle ang ss name)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;; SUBROUTINES ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun *error* (msg)
(and *AcadDoc* (vla-endundomark *AcadDoc*))
(if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*,")))
(princ (strcat "\nError: " msg))
)
)
(defun AT:UCSAngle (/)
;; Return current UCS angle
;; Alan J. Thompson, 04.06.10
((lambda (x) (atan (cadr x) (car x))) (trans (getvar 'UCSXDIR) 0 (trans '(0. 0. 1.) 1 0 T) T))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;; MAIN ROUTINE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(vl-load-com)
(vla-startundomark
(cond (*AcadDoc*)
((setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
)
)
(if (ssget "_:L" '((0 . "INSERT,MTEXT,MULTILEADER,TEXT")))
(progn
(setq ang (AT:UCSAngle))
(vlax-for x (setq ss (vla-get-activeselectionset *AcadDoc*))
(cond ((vl-position (setq name (vla-get-objectname x)) '("AcDbBlockReference" "AcDbText"))
(vla-put-rotation x ang)
)
((eq name "AcDbMText") (vla-put-rotation x 0.))
((and (eq name "AcDbMLeader") (eq (vla-get-contenttype x) 2))
(vla-put-textrotation x 0.)
)
)
)
(vla-delete ss)
)
)
(*error* nil)
(princ)
)

;;; ------------------------------------------------------------------------ 
;;;  ZeroRotation.lsp v1.2 
;;; 
;;;  Copyright?03.09.09 
;;;  Alan J. Thompson (alanjt) 
;;; 
;;;  Contact: alanjt @ TheSwamp 
;;;  Permission to use, copy, modify, and distribute this software 
;;;  for any purpose and without fee is hereby granted, provided 
;;;  that the above copyright notice appears in all copies and 
;;;  that both that copyright notice and the limited warranty and 
;;;  restricted rights notice below appear in all supporting 
;;;  documentation. 
;;; 
;;;  The following program(s) are provided "as is" and with all faults. 
;;;  Alan J. Thompson DOES NOT warrant that the operation of the program(s) 
;;;  will be uninterrupted and/or error free. 
;;; 
;;;  Set objects (Multileaders, Text, Mtext, Blocks) with a 
;;;  rotation of 0 (relative to current UCS). 
;;; 
;;;  Revision History: 
;;; 
;;;  v1.1 (10.23.09) 1. Minor rewrite for speed optimization. 
;;;     v1.2 (05.31.11) 1. Complete rewrite. 
;;; 
;;; ------------------------------------------------------------------------ 
 
(defun c:TE () (c:ZeroRotation)) 
(defun c:ZeroRotation (/ *error* AT:UCSAngle ang ss name) 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;; SUBROUTINES ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
 
 
  (defun *error* (msg) 
    (and *AcadDoc* (vla-endundomark *AcadDoc*)) 
    (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*,"))) 
      (princ (strcat "\nError: " msg)) 
    ) 
  ) 
 
 
  (defun AT:UCSAngle (/) 
    ;; Return current UCS angle 
    ;; Alan J. Thompson, 04.06.10 
    ((lambda (x) (atan (cadr x) (car x))) (trans (getvar 'UCSXDIR) 0 (trans '(0. 0. 1.) 1 0 T) T)) 
  ) 
 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;; MAIN ROUTINE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
 
  (vl-load-com) 
 
  (vla-startundomark 
    (cond (*AcadDoc*) 
          ((setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object)))) 
    ) 
  ) 
 
  (if (ssget "_:L" '((0 . "INSERT,MTEXT,MULTILEADER,TEXT"))) 
    (progn 
      (setq ang (AT:UCSAngle)) 
      (vlax-for x (setq ss (vla-get-activeselectionset *AcadDoc*)) 
        (cond ((vl-position (setq name (vla-get-objectname x)) '("AcDbBlockReference" "AcDbText")) 
               (vla-put-rotation x ang) 
              ) 
              ((eq name "AcDbMText") (vla-put-rotation x 0.)) 
              ((and (eq name "AcDbMLeader") (eq (vla-get-contenttype x) 2)) 
               (vla-put-textrotation x 0.) 
              ) 
        ) 
      ) 
      (vla-delete ss) 
    ) 
  ) 
  (*error* nil) 
  (princ) 
)

tumu2008323 · 发表于 2016-1-17 19:18

lucas_3333 发表于 2016-1-17 19:14

多谢

litianwu8900 · 发表于 2023-8-28 21:52

输入TE,没反应，这是为什么，2020CAD上测试的。

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

[源码] 批量旋转对象

点评

评分