[源码] 原地更换图框

admin1

1. (defun c:htk(/ ent entname i mspace newtk obj oldtk p1 p2 p3 p4 pt ptins ptlist ptmid1 sc scale1 ss thisdrawing y xx yy)
   
2.         (vl-load-com)
   
3.   (setq thisdrawing (vla-get-activedocument (vlax-get-acad-object)))
   
4.         (setq mspace (vla-get-modelspace thisdrawing))
   
5.         (vla-StartUndoMark thisdrawing)
   
6.         (setq ent (entget(car(entsel "选择旧图框"))))
   
7.         (setq oldtk(cdr(assoc '2 ent)))
   
8.         (setq entname (car(entsel "选择新图框:")))
   
9.         (setq ent (entget entname))
   
10.         (setq newtk(cdr(assoc '2 ent)))
    
11.         (setq ptins (cdr(assoc '10 ent)))
    
12.         (setq ptlist (ax:getboundingbox entname))
    
13.         (setq p1 (car ptlist))
    
14.         (setq p3 (cadr ptlist))
    
15.         (setq p2 (list (car p1) (cadr p3)))
    
16.         (setq p4 (list (car p3) (cadr p1)))
    
17.         (setq scale1 (vla-get-XScaleFactor (*en2obj* entname)))
    
18.         (setq y (/ (- (cadr p2) (cadr p1)) scale1))
    
19.         (setq xx (/ (- (car ptins) (car p1)) scale1))
    
20.         (setq yy (/ (- (cadr ptins) (cadr p1)) scale1))
    
21.         (setq ss nil)
    
22.         (setq ss (ssget "X" (list '(0 . "insert") (cons '2 oldtk))))
    
23.         ;(prompt "/n 选择需要替换的图框")
    
24.         ;(setq ss (ssget  '((0 . "insert") (cons '2 oldtk))))
    
25.         ;(setvar "osmode" 0);关闭点捕捉
    
26.         ;(if (null ss)
    
27.         ;        (setq ss(ssget "X" '((0 . "insert") (cons '2 oldtk))))
    
28.         ;)
    
29.         (setq i 0)
    
30.         (if (and ss newtk oldtk)
    
31.                 (repeat (sslength ss)
    
32.                   (setq entname (ssname ss i))
    
33.                   (setq ptlist (ax:getboundingbox entname))
    
34.                   (setq p1 (car ptlist))
    
35.                   (setq p3 (cadr ptlist))
    
36.                   (setq p2 (list (car p1) (cadr p3)))
    
37.                   (setq p4 (list (car p3) (cadr p1)))
    
38.                   (setq ptmid1 (mid-piont p1 p3))
    
39.                   (entdel entname)
    
40.                   (setq sc (/ (- (cadr p2) (cadr p1)) y))
    
41.                   (setq pt (list(+ (car p1) (* xx sc)) (+ (cadr p1) (* yy sc)) 0))
    
42.                   (setq obj(vla-InsertBlock  mspace (vlax-3d-point pt)  newtk sc sc sc 0))
    
43.                   (setq i (1+ i))
    
44.           )
    
45.         )
    
46.         (vla-EndUndoMark thisdrawing)
    
47.         (setvar "osmode" 15359)
    
48.         (princ)       
    
49. )
    
50. 
    
51. ;;;返回图元对象边框的最大和最小点
    
52. (defun ax:getboundingbox (entname / entpl entpr ptlist)
    
53.   (vla-getboundingbox (vlax-ename->vla-object entname) 'entpl 'entpr)
    
54.   (setq ptlist (mapcar 'vlax-safearray->list (list entpl entpr)))
    
55.   (mapcar '(lambda (x) (trans x 0 1)) ptlist)
    
56. )
    
57. 
    
58. 
    
59. ;;说明:中点子程序
    
60. ;;参数:p1:
    
61. ;;参数:p3:
    
62. ;;返回:ptmid （包含x y）
    
63. (defun mid-piont (p11 p22 / p333 p111)
    
64.         (setq p111 p11)
    
65.         (setq p333 p22)
    
66.         (setq xm (+ (/ (-(car p333) (car p111)) 2) (car p111)))
    
67.         (setq ym (+ (/ (-(cadr p333) (cadr p111)) 2) (cadr p111)))
    
68.         (setq mm(list xm ym))
    
69. )
    
70. 
    
71. (prompt "更换图框 HTK")

复制代码