Atsai 发表于 2021-3-23 16:27
http://bbs.mjtd.com/thread-113576-1-1.html
适用于图块的框。
从来没有成功过 你那里有你测试成功的 测试图吗 辛苦共享一下
tranney 发表于 2021-3-24 01:42
他的我用过，很好用
你那里有完整的代码 或者程序吗他网址里面的代码 不全
依然小小鸟 发表于 2021-4-9 17:01
你那里有完整的代码 或者程序吗他网址里面的代码 不全
(defun MAT:mxp (m p)
(reverse (cdr (reverse (MAT:mxv m (append p '(1.0))))))
)
(defun MAT:mxm (m q)
(mapcar (function (lambda (r) (MAT:mxv (MAT:trp q) r))) m)
)
(defun Mat:DispToMatrix (mat disp)
(append
(mapcar 'append mat (mapcar 'list disp))
'((0. 0. 0. 1.))
)
)
(defun MAT:mxv (m v)
(mapcar (function (lambda (r) (apply '+ (mapcar '* r v)))) m)
)
(defun MAT:trp (m)
(apply 'mapcar (cons 'list m))
)
(defun MAT:Trans1 (from to Org Ang / Mat Rot Inv Cen)
(setq Mat (mapcar (function (lambda (v) (trans v from to T)))
'((1. 0. 0.) (0. 1. 0.) (0. 0. 1.))
)
)
(if (not (equal ang 0 1e-14))
(setq Rot (list (list (cos ang) (- (sin ang)) 0.)
(list (sin ang) (cos ang) 0.)
(list 0. 0. 1.)
)
mat (MAT:mxm mat Rot)
)
)
(setq Cen (trans Org to from))
(setq Inv (mat:trp mat))
(list
(Mat:DispToMatrix Inv (mat:mxv Inv (mapcar '- Cen))) ;from->to (trans pt from to)
(Mat:DispToMatrix mat Cen) ;to->from (trans pt to from)
)
)
(defun Mat:EntityMatrix (Ent / z dxf Cen obj an m1 mat Inv org)
(setq dxf (entget ent))
(if (setq Cen (cdr (assoc 10 dxf))) ;Insertpoint,center or startpoint,etc.
(if (null (caddr Cen))
(setq Cen (append Cen '(0.0)))
)
(setq Cen '(0 0 0))
)
(setq obj (vlax-ename->vla-object Ent))
(if (and (vlax-property-available-p obj 'elevation) ;If it has elevation value.
(wcmatch (vla-get-objectname obj) "*Polyline") ;It's a "AcDb2dPolyline" or "AcDbPolyline" object
)
(setq z (vla-get-elevation obj)
Cen (list (car Cen) (cadr Cen) (+ (caddr Cen) z)) ;add elevation value
)
)
(if (vlax-property-available-p obj 'rotation) ;if it has a rotaion angle
(setq an (vla-get-rotation obj))
(setq an 0)
)
(MAT:Trans1 0 Ent Cen an) ;return two matrices, the first is WCS->OCS,the second is OCS->WCS
)
(defun HH:Ent4pt (ent Flag / ENT LST MAT MAT1 MATLSTMATRIX
MAXPT MINPT OBJ ORIGINREVMATUCSFLAG WCSORGX XDIR
YDIR ZDIR
)
;;1 矩阵的变换与逆变换
(defun GetMatrix (lst org Revflag / I J MAT)
(setq mat (vlax-make-safearray vlax-vbDouble '(0 . 3) '(0 . 3)))
(setq i 0)
(repeat 3
(vlax-safearray-put-element mat i 3 (nth i org)) ;平移变换
(setq j 0)
(repeat 3
(if RevFlag
(vlax-safearray-put-element mat i j (nth j (nth i lst))) ;角度逆变换
(vlax-safearray-put-element mat i j (nth i (nth j lst))) ;角度的变换
)
(setq j (1+ j))
)
(setq i (1+ i))
)
(vlax-safearray-put-element mat 3 3 1)
mat ;返回矩阵
)
;;2 本程序主程序
(cond ((= (type ent) 'ENAME)
(setq obj (vlax-ename->vla-object ent))
)
((= (type ent) 'VLA-OBJECT) (setq obj ent))
(T (exit))
)
(and Flag
(setq Mat (Mat:EntityMatrix ent))
(setq Mat1 (cadr Mat))
(setq Mat (car Mat))
)
(setq UcsFlag (getvar "WORLDUCS"))
(if (= UcsFlag 0) ;UCS与WCS不同
(setq UcsFlag T ;设置标志位为true
xdir (getvar "UCSXDIR") ;X方向矢量
ydir (getvar "UCSYDIR") ;Y方向矢量
zdir (MAT:vxv xdir ydir) ;X和Y的方向矢量的叉积
origin(getvar "UCSORG") ;原点
WcsOrg(trans '(0 0 0) 0 1) ;WCS的原点相对UCS的坐标
matLst(list xdir ydir zdir) ;旋转的变换矩阵表
matrix(GetMatrix matLst origin nil) ;从WCS到UCS(ocs)的变换矩阵
revMat(GetMatrix matLst WcsOrg T) ;从UCS(ocs)到WCS的变换矩阵
)
(setq UcsFlag nil) ;否则不予变换
)
;;在UCS下先变换物体到WCS下，取得物体的包围框，然后把物体变换回到UCS
(cond ((and Flag UcsFlag) (vla-TransformBy obj (vlax-tmatrix Mat)))
(UcsFlag (vla-TransformBy obj revMat))
(Flag (vla-TransformBy obj (vlax-tmatrix Mat)))
)
(vla-GetBoundingBox obj 'minPt 'maxPt) ;得到包围框
(setq minPt (vlax-safearray->list minPt))
(setq maxPt (vlax-safearray->list maxPt))
(cond ((and Flag UcsFlag) (vla-TransformBy obj (vlax-tmatrix Mat1)))
(UcsFlag (vla-TransformBy obj matrix))
(Flag (vla-TransformBy obj (vlax-tmatrix Mat1)))
)
(setq lst (list minPt
(list (car maxPt) (cadr minpt) (caddr minPt))
maxPt
(list (car minpt) (cadr maxPt) (caddr minPt))
)
)
(COND (Flag nil)
(UcsFlag (setq mat1 (vlax-safearray->list matrix)))
)
(cond ((or Flag UcsFlag)
(setq lst (mapcar '(lambda (x) (mat:mxp mat1 x)) lst)) ;wcs坐标
(setq lst (mapcar '(lambda (x) (trans x ent 1)) lst))
)
)
lst
)
(defun c:zcai_skd (/ cp cl cs vpl os vplyes l0 svpc ptlst ssvp)
(vl-load-com)
(princ "\n说明：批量 图块(可旋转)产生视口")
(setvar "cmdecho" 0) ; Turn off command line echoing
(setq cp (getvar "ctab")) ; Store current tab name
(setq cl (getvar "clayer")) ; Store current layer name
(setq cs (getvar "osmode")) ; Store current osnap mode
(setq vpl "0-批量视口") ; ==>> Assume using Viewport layer for viewport frames, change code value here if needed <<==
(setq os (getvar "osmode")) ;读取锁点原设定
(setvar "osmode" 0)
(setq nselect
(getstring
"\n选择排序方式,(1)自选顺序(2)左->右(3)右->左(4)上->下(5)下->上：预设(1)"
)
)
(if (= nselect "")
(setq nselect "1")
)
(if (/= cp "Model") ; Must be started from a layout tab to establish destination, quit quietly if on Model tab
(progn
(setq vplyes 0) ; Assume viewport doesn't exist
(setq l0 (tblnext "LAYER" 1)) ; Get past 0 layer in layer list
(while (setq layers (tblnext "LAYER"))
;; Loop through layer list collection
(setq ln (cdr (assoc 2 layers))) ; Extract layer name from list
(if (= (strcase ln) (strcase vpl))
(setq vplyes 1)
) ; Check if viewport layer exists
)
(if (= vplyes 0)
(command "layer" "NEW" vpl "COLOR" "RED" vpl "")
) ; Make viewport layer and assign color to magenta if doesn't exist
(setvar "clayer" vpl) ; Change to viewport layer
(command "layer"
"ON"
(strcat "0," vpl)
"UNLOCK"
(strcat "0," vpl)
""
) ; Turn on and unlock viewport and 0 layer
(command "zoom" "ALL") ; View entire layout tab
(setvar "ctab" "Model") ; Activate Model tab
(command "zoom" "E") ; View entire Model Space area
(setq ss nil)
(if (setq ss (ssget '((0 . "INSERT"))))
(progn
(setq l (sslength ss)
i 0
)
(setq ent_lst nil)
(repeat (sslength ss)
(setq ent_lst (append ent_lst (list (ssname ss i)))
i (1+ i)
)
)
(princ "\n") ; Clean up command line
(setvar "ctab" cp) ; Return to layout tab program was started from
(command "pspace") ; Switch to Paper Space of layout tab
(setq ptlst nil)
(setq ptlst (HH:Ent4pt (nth 0 ent_lst) T))
(setq vpc1 (nth 0 ptlst))
(setq vpc2 (nth 1 ptlst))
(setq vpc3 (nth 2 ptlst))
(setq vpc4 (nth 3 ptlst))
(setq sf 1.0)
(setq vpyd (* sf (distance vpc2 vpc3)))
(defun viewpnts (/ a b c d x)
(setq b (getvar "viewsize")
c (car (getvar "screensize"))
d (cadr (getvar "screensize"))
a (* b (/ c d))
x (setq x (getvar "viewctr"))
x (trans x 1 2)
c (list (- (car x) (/ a 2.0)) (- (cadr x) (/ b 2.0)) 0.0)
d (list (+ (car x) (/ a 2.0)) (+ (cadr x) (/ b 2.0)) 0.0)
c (trans c 2 1)
d (trans d 2 1)
)
(list c d)
)
(setq c (nth 0 (viewpnts)))
(setq d (nth 1 (viewpnts)))
(setq mvpc (list (/ (+ (car c) (car d)) 2.0) (/ (+ (cadr c) (cadr d)) 2.0) 0.0))
(command "zoom" "C" mvpc (rtos (* (* 2 l) vpyd)))
(setq svpc
(getpoint
"\n选择插入点："
)
) ; Can't change layout tabs manually here
(cond
((= nselect "1")
(setq ent_lst ent_lst)
)
((= nselect "2")
(progn
;;按X座标排序
(setq
ent_lst (vl-sort ent_lst
'(lambda (e1 e2)
(< (cadr (assoc 10 (entget e1)))
(cadr (assoc 10 (entget e2)))
)
)
)
)
;;按X座标排序
)
)
((= nselect "3")
(progn
;;按X座标排序
(setq
ent_lst (vl-sort ent_lst
'(lambda (e1 e2)
(> (cadr (assoc 10 (entget e1)))
(cadr (assoc 10 (entget e2)))
)
)
)
)
;;按X座标排序
)
)
((= nselect "4")
(progn
;;按Y座标排序
(setq
ent_lst (vl-sort ent_lst
'(lambda (e1 e2)
(> (caddr (assoc 10 (entget e1)))
(caddr (assoc 10 (entget e2)))
)
)
)
)
;;按Y座标排序
)
)
((= nselect "5")
(progn
;;按Y座标排序
(setq
ent_lst (vl-sort ent_lst
'(lambda (e1 e2)
(< (caddr (assoc 10 (entget e1)))
(caddr (assoc 10 (entget e2)))
)
)
)
)
;;按Y座标排序
)
)
)
(mapcar
'(lambda (ssn)
(setq ptlst nil)
(setq ptlst (HH:Ent4pt ssn T))
(setq vpc1 (nth 0 ptlst))
(setq vpc2 (nth 1 ptlst))
(setq vpc3 (nth 2 ptlst))
(setq vpc4 (nth 3 ptlst))
(setq sf 1.0)
(setq vpxd (* sf (distance vpc1 vpc2)))
;; Determine horizontal length of selected window
(setq vpyd (* sf (distance vpc2 vpc3)))
;; Determine vertical height of selected window
(setq
vpc
(list (/ (+ (car vpc1) (car vpc3)) 2.0)
(/ (+ (cadr vpc1) (cadr vpc3)) 2.0)
0.0
)
)
;; Determine center point of selected model window
(command "mview"
(list (car svpc) (cadr svpc))
(strcat "@" (rtos vpxd) "," (rtos vpyd))
)
;; Create Paper Space viewport
(setq ssvp nil)
(setq ssvp (ssget "L"))
;; Start selection set with last viewport frame
(command "zoom"
"w"
(list (car svpc) (cadr svpc))
(strcat "@" (rtos vpxd) "," (rtos vpyd))
)
(command "mspace")
;; Open viewport window to Model Space
(command "ucsicon" "ON")
;; Turn on UCS icon for viewport
(command "ucs" "Z" "non" vpc1 "non" vpc2)
(command "Plan" "")
(command "ucs" "WORLD") ; Reset UCS to WCS
(command "zoom" "C" vpc (rtos vpyd))
;; Center view of viewport window using determined point
(command "zoom" "SCALE" (strcat (rtos sf) "XP"))
;; Set zoom scale of viewport window
(command "vports" "LOCK" "ON" ssvp "")
;; Lock scale and position of model in viewport
(command "pspace")
;; Close viewport window
(setq w (distance vpc1 vpc2))
(setq svpc (polar svpc 0 (* 1.5 w)))
)
ent_lst
)
)
)
)
(princ "\n这个LISP程式只能在Layout(布局)使用！")
;; Need to start on a layout tab so program knows where to create the new viewports
)
(command "zoom" "all")
(setvar "ctab" cp) ; Reset to stored tab name
(setvar "clayer" cl) ; Reset to stored layer name
(setvar "osmode" os) ;回复锁点原设定
(princ)
)
命令为zcai_skd
tranney 发表于 2021-4-10 21:34
命令为zcai_skd
运行失败，什么情况
tranney 发表于 2021-4-10 21:34
命令为zcai_skd
咝谐晒
p-3-ianlcc 发表于 2021-6-22 10:56
咝谐晒
成功了吗{:1_1:}
依然小小鸟 发表于 2021-6-22 12:14
成功了吗
成功了…不過，還在適試中！
p-3-ianlcc 发表于 2021-6-25 17:49
成功了…不過，還在適試中！
怎么操作呢
依然小小鸟 发表于 2021-6-26 09:47
怎么操作呢
您好
我是COPY「tranney」所提供的CODE使用
命令是：zcai_skd