AutoLisp mc对图器.lsp

admin

1. (defun c:dt (/ dc VC-Apt VC-Bpt bb mouse a aa bb VC-Ap VC-Bp VC-ID VC-A-PZ VC-b-PZ vc-idA vc-idb vc-idx)
   
2.                                          (YL_begin)
   
3.                                          (setvar "OSMODE" 6079)
   
4.                                          (if (/= (getvar "tilemode") 1)  (setvar "tilemode" 1));返回模型空间
   
5.                                          (setq dc (vlax-get-acad-object))
   
6.                                          (foreach x '(ActiveDocument viewports count)  (setq dc (vlax-get dc x)));;获取视口数量
   
7.                                          (cond
   
8.                                                  ((> dc 2)  ;;大于等于3个视口
   
9.                                                          (if (and
   
10.                                                                                  (setq VC-Ap (getpoint "\n指定第1视口的中心点 : "))
    
11.                                                                                  (setq VC-Bp (getpoint VC-Ap "\n指定第2视口的中心点 : ")))
    
12.                                                                  (progn
    
13.                                                                          (command "-vports" "si"  "-vports" "2" "v");;重新创建垂直双视口
    
14.                                                                          (setvar "cvport" (car (car (reverse (vports)))))        ;;返回视口
    
15.                                                                  )
    
16.                                                                  (princ "未指定两点。程序退出")))
    
17.                                                  ((= dc 2) ;;于等于2个视口
    
18.                                                          (PROGN
    
19.                                                                  (setvar "cvport" (car (car (reverse (vports)))))
    
20.                                                                  (setq VC-PZ (getvar 'ViewCtr))
    
21.                                                                  (setvar "cvport" (car (car (reverse (vports)))))
    
22.                                                                  (setq VC-A-PZ (vlax-ldata-get "字典" "VC-A-PZ"))
    
23.                                                                  (setq VC-B-PZ (vlax-ldata-get "字典" "VC-B-PZ"))
    
24.                                                                  (if (or (equal VC-PZ VC-A-PZ 1e-8)
    
25.                                                                                           (equal VC-PZ VC-B-PZ 1e-8)
    
26.                                                                                  )  ;;判断此双视口是否由本插件生成，以继续执行
    
27.                                                                          (PROGN
    
28.                                                                                  (setq VC-Ap        (vlax-ldata-get "字典" "PTA"));;读取基点A
    
29.                                                                                  (setq VC-Bp        (vlax-ldata-get "字典" "PTB"));;读取基点B
    
30.                                                                          )
    
31.                                                                          (PROGN
    
32.                                                                                  (setvar "OSMODE" 6079)
    
33.                                                                                  (if (and
    
34.                                                                                                          (setq VC-Ap (getpoint "\n指定第1视口的中心点 : "))
    
35.                                                                                                          (setq VC-Bp (getpoint VC-Ap "\n指定第2视口的中心点 : ")))
    
36.                                                                                          (progn       
    
37.                          (setq ZY (car (caddr (car (vports)))))
    
38.                                                                                                  (command "-vports" "si" "-vports" "2" "v");;重新创建垂直双视口
    
39.                         (if (equal zy 0.5)
    
40.                                                                                                     (setvar "cvport" (car (car (reverse (vports)))))
    
41.                                                                                           )
    
42.                                                                                          )
    
43.                                                                                          (princ "未指定两点。程序退出")
    
44.                                                                                  )
    
45.                                                                          )
    
46.                                                                  )                                                                         
    
47.                                                          )
    
48.                                                  )
    
49.                                                  ((= dc 1) ;;于等于1个视口
    
50.                                                          (if (and
    
51.                                                                                  (setq VC-Ap (getpoint "\n指定第1视口的中心点 : "))
    
52.                                                                                  (setq VC-Bp (getpoint VC-Ap "\n指定第2视口的中心点 : ")))
    
53.                                                                  (progn
    
54.                                                                          (command "-vports" "2" "v");;创建垂直双视口
    
55.                                                                          (setvar "cvport" (car (car (reverse (vports)))))        ;;返回视口
    
56.                                                                  )
    
57.                                                                  (princ "未指定两点。程序退出"))
    
58.                                                  )
    
59.                                          )
    
60.                                                                                                  (vlax-ldata-PUt "字典" "PTA" VC-Ap);;保存基点A
    
61.                                                                                                  (vlax-ldata-PUt "字典" "PTB" VC-Bp);;保存基点B
    
62.        
    
63.                                          (setq bb T) ;BB为真，进入循环
    
64.                                          (while bb
    
65.                                                  (setq mouse (grread t 12 0));获取设备按键值
    
66.                                                  (setq a (car mouse) aa (cadr mouse))
    
67.                                                  (cond
    
68.                                                          ((and (= a 5) (= nil (equal (getvar 'ViewCtr) (vlax-ldata-get "字典" "VC-A-PZ"))));视口中心坐标发生变
    
69.                                                                  (PROGN
    
70.                                                                           (setq ZYx (car (caddr (car (vports)))))
    
71.                                                                          (IF (equal ZYx 0.5)
    
72.                                                                                  (SETQ VC-APT VC-AP VC-BPT VC-BP)
    
73.                                                                                  (SETQ VC-APT VC-BP VC-BPT VC-AP)
    
74.                                                                          )
    
75.                                                                          (VCB-VCA VC-Apt VC-Bpt)           ;;另一个视口跟随当前视口缩放
    
76.                                                                  )
    
77.                                                          )
    
78.                                                          ((and (= a 2) (= aa 32));空格暂停对比.                                                         
    
79.                                                                  (setq bb nil);结束对比                                                                                                                                  
    
80.                                                          )
    
81.                                                          ((or (= 25 a) (= 11 a) ;右键
    
82.                                                                         (and (= a 2) (= aa 13));或回车
    
83.                                                                 )
    
84.                                                                  (progn
    
85.                                                                          (setq bb nil);结束对比
    
86.                                                                          (command "-vports" "si" );还原层单视口
    
87.                                                                  )
    
88.                                                          )
    
89.                                                  )
    
90.                                          )
    
91.                                          (YL_end)
    
92. 
    
93.                                  )
    
94. ;钩子
    
95. (defun VCB-VCA (VC-Apt VC-Bpt / ptmin ptminn ptmax ptmaxn)
    
96.         (vlax-ldata-PUt "字典" "VC-A-PZ" (getvar 'ViewCtr))
    
97.         (setq ptmin (car (viewpnts)) ptmax (cadr (viewpnts)))        ;获取当前模型视口对角点
    
98.         (setq ptminn (polar  ptmin  (angle VC-ApT VC-BpT) (distance VC-ApT VC-BpT)))
    
99.         (setq ptmaxn (polar  ptmax  (angle VC-ApT VC-BpT) (distance VC-ApT VC-BpT)))
    
100.         (setvar "cvport" (car (car (reverse (vports)))))        ;;切换视口
     
101.         (zoom-pts ptminn  ptmaxn)
     
102.         (vlax-ldata-PUt "字典" "VC-B-PZ" (getvar 'ViewCtr)) ;;临时保存视口中心点坐标
     
103.         (setvar "cvport" (car (car (reverse (vports)))))        ;;返回视口
     
104. )
     
105. ;通过两点来缩放当前视口
     
106. (defun zoom-pts ( pt1 pt2 )
     
107.         (vla-zoomwindow
     
108.                 (vlax-get-acad-object)
     
109.                 (vlax-3d-point pt1)
     
110.                 (vlax-3d-point pt2)
     
111.         ))
     
112. 
     
113. ;;;117.3 [功能] 返回当前视窗左下角和右上角 坐标
     
114. (defun viewpnts        (/ A B C D X)
     
115.   (setq d (getvar "screensize"))              ;屏像素
     
116.   (setq        b (* (getvar "viewsize") 0.5)          ;viewsize屏竖长
     
117.         a (* b (/ (car d) (cadr d)))                            ;屏横长
     
118.         x (trans (getvar "viewctr") 1 2)                    ;屏中点viewctr
     
119.         c (list (- (car x) a) (- (cadr x) b) 0.0)
     
120.         d (list (+ (car x) a) (+ (cadr x) b) 0.0)
     
121.   )
     
122.   (list (trans c 2 1) (trans d 2 1))
     
123. )
     
124. 
     
125. ;;;;===============================必备函数=============================
     
126. ;;*****************************************************************************
     
127. ;;功 能：绘图程序的初始化处理，记录当前层名、线型、颜色、捕捉方式、文本样式、文本高度,
     
128. ;; 控制点标记可见方式、主单位值消零处理方式、命令行回显方式、然后关闭目标捕捉,
     
129. ;; 设置线形随层、颜色随层、设置命令行不回显、不显示控制点标记、对主单位值后续零作消零处理
     
130. ;;说 明：和函数YL_end配对使用。
     
131. (defun YL_begin ()
     
132.         (setq oderr *error*) ;;保存原来的*error*
     
133.         (setq *error* YL_err) ;;将*error*用自己的错误处理函数替代
     
134.         (setq odltp (getvar "celtype")) ;;记录当前线型设置
     
135.         (setq odclr (getvar "cecolor")) ;;记录当前颜色设置
     
136.         (setq odosm (getvar "osmode")) ;;记录当前捕捉方式
     
137.         (setq odlay (getvar "clayer")) ;;记录当前层
     
138.         (setq odsty (getvar "textstyle")) ;;记录当前文本样式
     
139.         (setq odtsz (getvar "textsize")) ;;记录当前文本高度
     
140.         (setq odbpm (getvar "blipmode")) ;;记录当前控制点标记是否可见
     
141.         (setq odzin (getvar "dimzin")) ;;记录主单位值消零处理方式
     
142.         (setq odcmd (getvar "cmdecho")) ;;记录命令行回显方式
     
143.         (setvar "celtype" "bylayer") ;;设置线形随层
     
144.         (setvar "cecolor" "bylayer") ;;设置颜色随层
     
145.         (setvar "cmdecho" 0) ;;设置命令行不回显
     
146.         (setvar "blipmode" 0) ;;不显示控制点标记
     
147.         (setvar "dimzin" 8) ;;对主单位值后续零作消零处理,因为DIMZIN 对 AutoLISP rtos 和 angtos 函数执行实数向字符串转换操作有影响。
     
148.         (setvar "osmode" 0) ;;关闭对象捕捉方式
     
149. )
     
150. ;;*****************************************************************************
     
151. ;;YL_end
     
152. ;;功 能：程序结束，恢复程序开始前的设置。
     
153. ;; 恢复YL_begin设置的系统变量表中的数值。
     
154. ;;说 明：和函数YL_begin配对使用。
     
155. (defun YL_end ()
     
156.         (setvar "celtype" odltp)
     
157.         (setvar "cecolor" odclr)
     
158.         (setvar "osmode" odosm)
     
159.         (setvar "textstyle" odsty)
     
160.         (setvar "textsize" odtsz)
     
161.         (setvar "blipmode" odbpm)
     
162.         (setvar "dimzin" odzin) ;;恢复主单位值消零处理方式
     
163.         (setvar "cmdecho" odcmd)
     
164.         (setq *error* oderr) ;;恢复原来的*error*
     
165.         (princ)
     
166. )
     
167. ;;*****************************************************************************
     
168. ;;YL_err
     
169. ;;功 能：错误处理函数。
     
170. (defun YL_err (msg)
     
171.         (princ (strcat "\n错误:" msg "\n")) ;;打印错误原因
     
172.         (YL_end) ;;调用函数YL_end恢复程序开始前的设置
     
173.         (setq *error* oderr) ;;恢复原来的*error*
     
174.         (princ)
     
175. )

复制代码