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)
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.         ))
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. )
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. )

复制代码