【局部放大】源码公布

Gu_xl

flytoday 发表于 2013-7-26 13:45
相应的标注。。。与字没有放大~~~~~~~~~~~~~~~~

注释掉如下代码即可放大文字和标注线型等：
(gxl-setOverride (vlax-vla-object->ename unblk) scale)

richine001

哈哈，终于出来了哈，哈哈

自贡黄明儒

终于盼来了G版的源码，是各位给图员的福气
响应G版号召，贴出我改编的源码

1. ;;*************************************************************************放大主程序
   
2. ;;全局JBFD_GetScalStri放大倍数（字符），JBFD_BaseNumber标识（数字）,JBFD_ZoomStri视口
   
3. (defun C:FD (/              BASESYMBOL        BLI1         CLA1          CMD1           CP
   
4.              DCLID    DIM1     ENT        ENTCICL         ENTTEXT  FN           FNAME
   
5.              GETZOOM  LAY      LIN        NEWBLOCK NEWP          NEWSS           OSM1
   
6.              P1              P2       PL        RETURN#         SCALREAL SS           TEXTHEIGH
   
7.              X
   
8.             )
   
9.   ;;1 错误处理
   
10.   (defun *error* (s)
    
11.     (while (not (equal (getvar "cmdnames") "")) (command nil))
    
12.     (if        entText
    
13.       (command "_.erase" entText "")
    
14.     )
    
15.     (if        lay
    
16.       (setvar "clayer" lay)
    
17.     )
    
18.     (setvar "blipmode" bli1)
    
19.     (setvar "cmdecho" cmd1)
    
20.     (setvar "DIMASSOC" DIM1)
    
21.     (setvar "osmode" osm1)
    
22.     (princ s)
    
23.     (princ "出错啦!")
    
24.     (princ)
    
25.   )
    
26.   ;;2 对象是否在锁定层上
    
27.   (defun onlocked (ename / entlst)
    
28.     (setq entlst (tblsearch "LAYER" (cdr (assoc 8 (entget ename)))))
    
29.     (= 4 (logand 4 (cdr (assoc 70 entlst))))
    
30.   )
    
31.   ;;3  构成新的选择集,EntCicl不加入
    
32.   (defun ss=>NewSS (SS EntCicl / E N NEWSS)
    
33.     (setq NewSS (ssadd))
    
34.     (repeat (setq n (sslength ss))
    
35.       (setq e (ssname ss (setq n (1- n))))
    
36.       (if (or (equal e EntCicl) (onlocked e))
    
37.         nil
    
38.         (progn
    
39.           (command "_.copy" e "" (list 0 0 0) (list 0 0 0))
    
40.           (setq NewSS (ssadd (entlast) NewSS))
    
41.         )
    
42.       )
    
43.     )
    
44.     NewSS
    
45.   )
    
46.   ;;4 0层上生成块
    
47.   (defun NONAME_BLK (SS PCircl / A lay)
    
48.     (setq lay (getvar "clayer"))
    
49.     (setvar "clayer" "0")
    
50.     (setq A (rtos (* (getvar "CDATE") 1E8)))
    
51.     (if        (and SS PCircl)
    
52.       (progn
    
53.         (command "_.BLOCK" A PCircl SS "")
    
54.         (command "_.INSERT" A "@" "" "" "")
    
55.       )
    
56.     )
    
57.     (setvar "clayer" lay)
    
58.     (entlast)
    
59.   )
    
60.   ;;5 画引线
    
61.   (defun HdrawLeader (EntCicl BaseSymbol      Textheigh              CP      /
    
62.                       A              AA      B              BB      C              CC      D
    
63.                       DD      EE      ENTTEXT FF      I              TEXTLIS
    
64.                      )
    
65.     (command "_.text" CP Textheigh "" BaseSymbol)
    
66.     (setq entText (entlast))
    
67. 
    
68.     (setq TextLis (entget entText))
    
69.     (setq i T)
    
70.     (while i
    
71.       (setq a (grread T 4 0)
    
72.             b (car a)
    
73.             c (cadr a)
    
74.       )
    
75.       ;;b=5移动，b=3左键,c=0右键,;;c=13回车,c=32空格
    
76.       (cond ((= b 5)
    
77.              (redraw)
    
78.              (setq a (trans (cadr a) 1 0))
    
79.              (setq d (vlax-curve-getclosestpointto EntCicl a))
    
80.              (setq aa (car a)
    
81.                    bb (cadr a)
    
82.                    cc (caddr a)
    
83.              )
    
84.              (setq dd (car d)
    
85.                    ee (cadr d)
    
86.                    ff (caddr d)
    
87.              )
    
88.              (if (<= aa dd)
    
89.                (progn (setq TextLis (subst (cons 72 2) (assoc 72 TextLis) TextLis))
    
90.                       (setq TextLis (subst (cons 11 a) (assoc 11 TextLis) TextLis))
    
91.                )
    
92.                (progn (setq TextLis (subst (cons 72 0) (assoc 72 TextLis) TextLis))
    
93.                       (setq TextLis (subst (cons 10 a) (assoc 10 TextLis) TextLis))
    
94.                )
    
95.              )
    
96.              (entmod TextLis)
    
97.              (grdraw a d 1)
    
98.             )
    
99.             ((= b 3) (setq i nil))
    
100.       )
     
101.     )
     
102. 
     
103.     (redraw)
     
104.     (entdel entText)
     
105.     (if        (VL-CATCH-ALL-ERROR-P
     
106.           (VL-CATCH-ALL-APPLY 'setvar (list "DIMLDRBLK" "DotSmall"))
     
107.         )
     
108.       (VL-CATCH-ALL-APPLY 'setvar (list "DIMLDRBLK" "小点"))
     
109.     )
     
110.     (vl-cmdf "_.layer" "make" "DIM" "Color" 3 "" "")
     
111.     (command "_.leader" d (cadr a) "" BaseSymbol "")
     
112.   )
     
113. 
     
114.   ;;6 返回多义线顶点点列表,有圆弧则用一定角度分割圆弧，闭合多义线点表不含闭合点坐标
     
115.   ;;(setq pl (gxl-pL ent 0.017))
     
116.   (defun gxl-pL        (en        fgx    /      BJ     BUGLE  D           D0          D1         D2
     
117.                  ENT        K      N      OBJ    OBJNAME           PARAM  PLIST         PT
     
118.                  SECDEV        VERTEXSNUM
     
119.                 )
     
120.     ;;gxl-get_poly_ptList 返回多义线顶点点列表不含圆弧段内容，闭合多义线点表不含闭合点坐标
     
121.     ;;(gxl-get_poly_ptList (car (entsel)))
     
122.     (defun gxl-get_poly_ptList (e / _pl n k)
     
123.       (if (= 'ename (type e))
     
124.         (setq e (vlax-ename->vla-object e))
     
125.       )
     
126.       (cond ((= "AcDbCircle" (vla-get-ObjectName e))
     
127.              (list (vlax-curve-getPointAtParam e 0)
     
128.                    (vlax-curve-getPointAtParam e (* pi 0.5))
     
129.                    (vlax-curve-getPointAtParam e pi)
     
130.                    (vlax-curve-getPointAtParam e (* 1.5 pi))
     
131.              )
     
132.             )
     
133.             ((= "AcDbArc" (vla-get-ObjectName e))
     
134.              (list (vlax-curve-getStartPoint e)
     
135.                    (vlax-curve-getendPoint e)
     
136.              )
     
137.             )
     
138.             (t
     
139.              (setq n (1+ (fix (vlax-curve-getEndParam e)))
     
140.                    k -1
     
141.              )
     
142.              (if (vlax-curve-isClosed e)
     
143.                (setq n (1- n))
     
144.              )
     
145.              (repeat n
     
146.                (setq k (1+ k))
     
147.                (if (vlax-curve-getSecondDeriv e k)
     
148.                  (setq
     
149.                    _pl (append _pl (list (vlax-curve-getPointAtParam e k)))
     
150.                  )
     
151.                )
     
152.              )
     
153.             )
     
154.       )
     
155.       _pl
     
156.     )
     
157. 
     
158.     (if        (= 'ENAME (type en))
     
159.       (setq obj        (vlax-ename->vla-object en)
     
160.             ent        en
     
161.       )
     
162.       (setq obj        en
     
163.             ent        (vlax-vla-object->ename en)
     
164.       )
     
165.     )
     
166.     (setq vertexsNum
     
167.            (fix (vlax-curve-getEndParam ent))
     
168.           n 0
     
169.     )
     
170.     (setq objName (vla-get-ObjectName obj))
     
171.     (cond ((= "AcDbCircle" objName)
     
172.            (if (equal fgx 0 1e-6)
     
173.              (setq fgx (* pi 0.5))
     
174.            )
     
175.            (setq vertexsNum
     
176.                   (fix (/ (* pi 2) fgx))
     
177.                  n 0
     
178.            )
     
179.            (repeat vertexsNum
     
180.              (setq pt (vlax-curve-getPointAtParam obj (* n fgx)))
     
181.              (setq plist (cons pt plist)
     
182.                    n         (1+ n)
     
183.              )
     
184.            )
     
185.            (reverse plist)
     
186.           )
     
187.           (t
     
188.            (if (= "AcDb2dPolyline" objName)
     
189.              (progn
     
190.                (repeat vertexsNum
     
191.                  (setq pt (vlax-curve-getPointAtParam ent n))
     
192.                  (setq plist (cons pt plist))
     
193.                  (setq pt (vlax-curve-getPointAtParam ent (+ 0.25 n)))
     
194.                  (setq plist (cons pt plist))
     
195.                  (setq pt (vlax-curve-getPointAtParam ent (+ 0.5 n)))
     
196.                  (setq plist (cons pt plist))
     
197.                  (setq pt (vlax-curve-getPointAtParam ent (+ 0.75 n)))
     
198.                  (setq plist (cons pt plist))
     
199.                  (setq n (1+ n))
     
200.                )
     
201.                (if (not (vlax-curve-isClosed ent))
     
202.                  (setq plist (cons (vlax-curve-getEndPoint ent) plist))
     
203.                )
     
204.                (reverse plist)
     
205.              )
     
206.              (if (equal fgx 0 1e-6)
     
207.                (setq plist (GXL-GET_POLY_PTLIST en))
     
208.                (progn
     
209.                  (repeat vertexsNum
     
210.                    (if (setq secdev (vlax-curve-getSecondDeriv ent n))
     
211.                      (progn
     
212.                        (setq pt           (vlax-curve-getPointAtParam ent n)
     
213.                              bugle (vla-GetBulge obj n)
     
214.                        )
     
215.                        (setq plist (cons pt plist))
     
216.                        (if (/= bugle 0.0)
     
217.                          (progn
     
218.                            (setq bj (* (atan (abs bugle)) 4))
     
219.                            (setq d1    (vlax-curve-getdistAtParam ent n)
     
220.                                  d2    (vlax-curve-getdistAtParam ent (1+ n))
     
221.                                  d     (- d2 d1)
     
222.                                  k     (fix (/ bj fgx))
     
223.                                  d0    (/ 1.0 (1+ k))
     
224.                                  param n
     
225.                            )
     
226.                            (if (equal d0 1.0 0.001)
     
227.                              (setq plist (cons (vlax-curve-getPointAtParam
     
228.                                                  ent
     
229.                                                  (+ 0.5 param)
     
230.                                                )
     
231.                                                plist
     
232.                                          )
     
233.                              )
     
234.                              (repeat k
     
235.                                (setq
     
236.                                  plist (cons (vlax-curve-getPointAtParam
     
237.                                                ent
     
238.                                                (setq param (+ param d0))
     
239.                                              )
     
240.                                              plist
     
241.                                        )
     
242.                                )
     
243.                              )
     
244.                            )
     
245.                          )
     
246.                        )
     
247.                      )
     
248.                    )
     
249.                    (setq n (1+ n))
     
250.                  )
     
251.                  (if (not (vlax-curve-isClosed ent))
     
252.                    (setq plist (cons (vlax-curve-getEndPoint ent) plist))
     
253.                  )
     
254.                  (reverse plist)
     
255.                )
     
256.              )
     
257.            )
     
258.           )
     
259.     )
     
260.     plist
     
261.   )
     
262.   ;;7 对话框上用户选择
     
263.   (defun getdata ()
     
264.     (setq BaseSymbol (get_tile "Fuhao"))
     
265.     (setq JBFD_GetScalStri (get_tile "Scal"))
     
266.     (setq JBFD_ZoomStri (get_tile "Zoom1"))
     
267.   )
     
268.   ;;8 对话框
     
269.   (defun FDdcl ()
     
270.     (setq fname (vl-filename-mktemp nil nil ".dcl"))
     
271.     (setq fn (open fname "w"))
     
272.     (write-line "Fddcl : dialog{" fn)
     
273.     (write-line "label=\"*黄明儒*局部放大 命令:FD\";" fn)
     
274.     (write-line ":column{        " fn)
     
275.     (write-line
     
276.       "        :edit_box{label=\"放大标识(F)\";key=\"Fuhao\";value=\"B\";mnemonic=\"F\";}"
     
277.       fn
     
278.     )
     
279.     (write-line
     
280.       "        :edit_box{label=\"放大倍数(S)\";key=\"Scal\";value=\"2.0\";mnemonic=\"S\";} "
     
281.       fn
     
282.     )
     
283.     (write-line
     
284.       "        :edit_box{label=\"视口选择(Z)\";key=\"Zoom1\";value=\"0\";mnemonic=\"Z\";} "
     
285.       fn
     
286.     )
     
287.     (write-line
     
288.       "        :text{key=\"Scaltext\";value=\"圆0,已知封闭曲线1,椭圆2,其余多边形\";}"
     
289.       fn
     
290.     )
     
291.     (write-line "       }" fn)
     
292.     (write-line "       ok_only;" fn)
     
293.     (write-line "}" fn)
     
294. 
     
295.     (close fn)
     
296.     (setq fn (open fname "r"))
     
297.     (setq dclid (load_dialog fname))
     
298.     (while
     
299.       (or (eq (substr (setq lin        (vl-string-right-trim
     
300.                                   "\" fn)"
     
301.                                   (vl-string-left-trim "(write-line \"" (read-line fn))
     
302.                                 )
     
303.                       )
     
304.                       1
     
305.                       2
     
306.               )
     
307.               "//"
     
308.           )
     
309.           (eq (substr lin 1 (vl-string-search " " lin)) "")
     
310.           (not (eq (substr lin (+ (vl-string-search " " lin) 1) 9)
     
311.                    " : dialog"
     
312.                )
     
313.           )
     
314.       )
     
315.     )
     
316.     (new_dialog (substr lin 1 (vl-string-search " " lin)) dclid)
     
317.     (set_tile "Fuhao" BaseSymbol)
     
318.     (set_tile "Scal" JBFD_GetScalStri)
     
319.     (set_tile "Zoom1" JBFD_ZoomStri)
     
320.     (mode_tile "Scal" 2)
     
321.     (Action_Tile "Fuhao" "(Setq BaseSymbol $Value)")
     
322.     (Action_Tile "Scal" "(Setq JBFD_GetScalStri $Value)")
     
323.     (Action_Tile "Zoom1" "(Setq JBFD_ZoomStri $Value)")
     
324.     (action_tile "accept" "(getdata)(done_dialog)")
     
325.     (setq return# (start_dialog))
     
326.     (unload_dialog dclid)
     
327.     (close fn)
     
328.     (vl-file-delete fname)
     
329.   )
     
330. 
     
331.   ;;9 本程序主程序
     
332.   (VL-LOAD-COM)
     
333.   (setq bli1 (getvar "blipmode"))
     
334.   (setq cmd1 (getvar "cmdecho"))
     
335.   (setq DIM1 (getvar "DIMASSOC"))
     
336.   (setq CLA1 (getvar "CLAYER"))
     
337.   (setq osm1 (getvar "osmode"))
     
338.   (setvar "blipmode" 0)
     
339.   (setvar "cmdecho" 0)
     
340.   (setvar "DIMASSOC" 1)
     
341.   (setvar "osmode" 0)
     
342.   (vl-cmdf "layer" "make" "DIM" "Color" 3 "" "")
     
343.   (if (= JBFD_BaseNumber nil)
     
344.     (setq JBFD_BaseNumber 65)
     
345.     (setq JBFD_BaseNumber (1+ JBFD_BaseNumber))
     
346.   )
     
347.   (SETQ BaseSymbol (chr JBFD_BaseNumber))
     
348.   (if (= JBFD_GetScalStri nil)
     
349.     (setq JBFD_GetScalStri "2.5")
     
350.   )
     
351.   (if (= JBFD_ZoomStri nil)
     
352.     (setq JBFD_ZoomStri "0")
     
353.   )
     
354.   (FDdcl)
     
355.   (setq JBFD_BaseNumber (ascii BaseSymbol))
     
356.   (SETQ Scalreal (atof JBFD_GetScalStri))
     
357.   (SETQ getZoom (abs (atoi JBFD_ZoomStri)))
     
358. 
     
359.   (if (/= 1 getZoom)
     
360.     (SETQ CP (GETPOINT "\n 局部放大中心点: "))
     
361.   )
     
362.   (cond        ((= 0 getZoom) (command "_.CIRCLE" CP pause))
     
363.         ((= 1 getZoom)
     
364.          (while
     
365.            (not
     
366.              (and
     
367.                (setq ent (car (entsel "\n 拾取封闭曲线:")))
     
368.                (setq p1 (cdr (assoc 0 (entget ent))))
     
369.                (member p1
     
370.                        '("SPLINE" "LWPOLYLINE" "POLYLINE" "CIRCLE" "ELLIPSE")
     
371.                )
     
372.                (if (member p1 '("SPLINE" "LWPOLYLINE" "POLYLINE"))
     
373.                  (= (vlax-get-property (vlax-ename->vla-object ent) 'Closed)
     
374.                     :vlax-true
     
375.                  )
     
376.                  T
     
377.                )
     
378.              )
     
379.            )
     
380.          )
     
381.         )
     
382.         ((= 2 getZoom) (command "_.ellipse" CP pause pause))
     
383.         (T (command "_.polygon" getZoom CP "_I" pause))
     
384.   )
     
385.   (SETQ EntCicl (entlast))
     
386.   ;;(ayEntSSHighLight EntCicl)
     
387.   (if (= 1 getZoom)
     
388.     (SETQ EntCicl ent)
     
389.   )
     
390. 
     
391.   (vla-getboundingbox
     
392.     (vlax-ename->vla-object EntCicl)
     
393.     'p1
     
394.     'p2
     
395.   )
     
396.   (setq p1 (vlax-safearray->list p1))
     
397.   (setq p2 (vlax-safearray->list p2))
     
398.   (setq CP (mapcar '(lambda (X) (/ x 2.0)) (mapcar '+ p1 p2))) ;中心点  
     
399.   (setq pl (gxl-pL EntCicl 0.017))                  ;取点
     
400.   (setq ss (ssget "cp" pl))                          ;选择对象
     
401.   (setq newSS (ss=>NewSS SS EntCicl))                  ;原地拷贝
     
402.   (setq Newblock (NONAME_BLK newSS CP))                  ;制作成块  
     
403.   ;;遮盖
     
404.   (command "_.xclip" Newblock "" "n" "p")
     
405.   (foreach a pl (command a))
     
406.   (command "")
     
407.   (while (not (equal (getvar "cmdnames") "")) (command nil))
     
408. 
     
409.   (command "_.copy" EntCicl "" (list 0 0 0) (list 0 0 0))
     
410.   (setq EntCicl (entlast))
     
411. 
     
412.   (SETQ Textheigh (* (GETVAR "DIMTXT") (GETVAR "DIMSCALE"))) ;字度Textheigh
     
413.   (HdrawLeader EntCicl BaseSymbol Textheigh CP)          ;画引线
     
414.   (setq        NewP (mapcar '+
     
415.                      (list 0 (+ (* Scalreal (- (cadr p2) (cadr CP))) Textheigh))
     
416.                      CP
     
417.              )
     
418.   )
     
419.   (command "_.text"
     
420.            "J"
     
421.            "C"
     
422.            NewP
     
423.            Textheigh
     
424.            ""
     
425.            (strcat BaseSymbol " 放大 " JBFD_GetScalStri "X")
     
426.   )
     
427. 
     
428.   (command "_.scale" Newblock EntCicl "" CP Scalreal)
     
429.   (command "_.move" Newblock (entlast) EntCicl "" CP pause)
     
430. 
     
431.   (setvar "blipmode" bli1)
     
432.   (setvar "cmdecho" cmd1)
     
433.   (setvar "DIMASSOC" DIM1)
     
434.   (setvar "osmode" osm1)
     
435.   (gc)
     
436.   (princ)
     
437. )
     
438. ;;*************************************************************************放大主程序
     

;;*************************************************************************放大主程序<br /> ;;全局JBFD_GetScalStri放大倍数（字符），JBFD_BaseNumber标识（数字）,JBFD_ZoomStri视口<br /> (defun C:FD (/              BASESYMBOL        BLI1         CLA1          CMD1           CP<br />              DCLID    DIM1     ENT        ENTCICL         ENTTEXT  FN           FNAME<br />              GETZOOM  LAY      LIN        NEWBLOCK NEWP          NEWSS           OSM1<br />              P1              P2       PL        RETURN#         SCALREAL SS           TEXTHEIGH<br />              X<br />             )<br />   ;;1 错误处理<br />   (defun *error* (s)<br />     (while (not (equal (getvar "cmdnames") "")) (command nil))<br />     (if        entText<br />       (command "_.erase" entText "")<br />     )<br />     (if        lay<br />       (setvar "clayer" lay)<br />     )<br />     (setvar "blipmode" bli1)<br />     (setvar "cmdecho" cmd1)<br />     (setvar "DIMASSOC" DIM1)<br />     (setvar "osmode" osm1)<br />     (princ s)<br />     (princ "出错啦!")<br />     (princ)<br />   )<br />   ;;2 对象是否在锁定层上<br />   (defun onlocked (ename / entlst)<br />     (setq entlst (tblsearch "LAYER" (cdr (assoc 8 (entget ename)))))<br />     (= 4 (logand 4 (cdr (assoc 70 entlst))))<br />   )<br />   ;;3  构成新的选择集,EntCicl不加入<br />   (defun ss=>NewSS (SS EntCicl / E N NEWSS)<br />     (setq NewSS (ssadd))<br />     (repeat (setq n (sslength ss))<br />       (setq e (ssname ss (setq n (1- n))))<br />       (if (or (equal e EntCicl) (onlocked e))<br />         nil<br />         (progn<br />           (command "_.copy" e "" (list 0 0 0) (list 0 0 0))<br />           (setq NewSS (ssadd (entlast) NewSS))<br />         )<br />       )<br />     )<br />     NewSS<br />   )<br />   ;;4 0层上生成块<br />   (defun NONAME_BLK (SS PCircl / A lay)<br />     (setq lay (getvar "clayer"))<br />     (setvar "clayer" "0")<br />     (setq A (rtos (* (getvar "CDATE") 1E8)))<br />     (if        (and SS PCircl)<br />       (progn<br />         (command "_.BLOCK" A PCircl SS "")<br />         (command "_.INSERT" A "@" "" "" "")<br />       )<br />     )<br />     (setvar "clayer" lay)<br />     (entlast)<br />   )<br />   ;;5 画引线<br />   (defun HdrawLeader (EntCicl BaseSymbol      Textheigh              CP      /<br />                       A              AA      B              BB      C              CC      D<br />                       DD      EE      ENTTEXT FF      I              TEXTLIS<br />                      )<br />     (command "_.text" CP Textheigh "" BaseSymbol)<br />     (setq entText (entlast))<br /> <br />     (setq TextLis (entget entText))<br />     (setq i T)<br />     (while i<br />       (setq a (grread T 4 0)<br />             b (car a)<br />             c (cadr a)<br />       )<br />       ;;b=5移动，b=3左键,c=0右键,;;c=13回车,c=32空格<br />       (cond ((= b 5)<br />              (redraw)<br />              (setq a (trans (cadr a) 1 0))<br />              (setq d (vlax-curve-getclosestpointto EntCicl a))<br />              (setq aa (car a)<br />                    bb (cadr a)<br />                    cc (caddr a)<br />              )<br />              (setq dd (car d)<br />                    ee (cadr d)<br />                    ff (caddr d)<br />              )<br />              (if (<= aa dd)<br />                (progn (setq TextLis (subst (cons 72 2) (assoc 72 TextLis) TextLis))<br />                       (setq TextLis (subst (cons 11 a) (assoc 11 TextLis) TextLis))<br />                )<br />                (progn (setq TextLis (subst (cons 72 0) (assoc 72 TextLis) TextLis))<br />                       (setq TextLis (subst (cons 10 a) (assoc 10 TextLis) TextLis))<br />                )<br />              )<br />              (entmod TextLis)<br />              (grdraw a d 1)<br />             )<br />             ((= b 3) (setq i nil))<br />       )<br />     )<br /> <br />     (redraw)<br />     (entdel entText)<br />     (if        (VL-CATCH-ALL-ERROR-P<br />           (VL-CATCH-ALL-APPLY 'setvar (list "DIMLDRBLK" "DotSmall"))<br />         )<br />       (VL-CATCH-ALL-APPLY 'setvar (list "DIMLDRBLK" "小点"))<br />     )<br />     (vl-cmdf "_.layer" "make" "DIM" "Color" 3 "" "")<br />     (command "_.leader" d (cadr a) "" BaseSymbol "")<br />   )<br /> <br />   ;;6 返回多义线顶点点列表,有圆弧则用一定角度分割圆弧，闭合多义线点表不含闭合点坐标<br />   ;;(setq pl (gxl-pL ent 0.017))<br />   (defun gxl-pL        (en        fgx    /      BJ     BUGLE  D           D0          D1         D2<br />                  ENT        K      N      OBJ    OBJNAME           PARAM  PLIST         PT<br />                  SECDEV        VERTEXSNUM<br />                 )<br />     ;;gxl-get_poly_ptList 返回多义线顶点点列表不含圆弧段内容，闭合多义线点表不含闭合点坐标<br />     ;;(gxl-get_poly_ptList (car (entsel)))<br />     (defun gxl-get_poly_ptList (e / _pl n k)<br />       (if (= 'ename (type e))<br />         (setq e (vlax-ename->vla-object e))<br />       )<br />       (cond ((= "AcDbCircle" (vla-get-ObjectName e))<br />              (list (vlax-curve-getPointAtParam e 0)<br />                    (vlax-curve-getPointAtParam e (* pi 0.5))<br />                    (vlax-curve-getPointAtParam e pi)<br />                    (vlax-curve-getPointAtParam e (* 1.5 pi))<br />              )<br />             )<br />             ((= "AcDbArc" (vla-get-ObjectName e))<br />              (list (vlax-curve-getStartPoint e)<br />                    (vlax-curve-getendPoint e)<br />              )<br />             )<br />             (t<br />              (setq n (1+ (fix (vlax-curve-getEndParam e)))<br />                    k -1<br />              )<br />              (if (vlax-curve-isClosed e)<br />                (setq n (1- n))<br />              )<br />              (repeat n<br />                (setq k (1+ k))<br />                (if (vlax-curve-getSecondDeriv e k)<br />                  (setq<br />                    _pl (append _pl (list (vlax-curve-getPointAtParam e k)))<br />                  )<br />                )<br />              )<br />             )<br />       )<br />       _pl<br />     )<br /> <br />     (if        (= 'ENAME (type en))<br />       (setq obj        (vlax-ename->vla-object en)<br />             ent        en<br />       )<br />       (setq obj        en<br />             ent        (vlax-vla-object->ename en)<br />       )<br />     )<br />     (setq vertexsNum<br />            (fix (vlax-curve-getEndParam ent))<br />           n 0<br />     )<br />     (setq objName (vla-get-ObjectName obj))<br />     (cond ((= "AcDbCircle" objName)<br />            (if (equal fgx 0 1e-6)<br />              (setq fgx (* pi 0.5))<br />            )<br />            (setq vertexsNum<br />                   (fix (/ (* pi 2) fgx))<br />                  n 0<br />            )<br />            (repeat vertexsNum<br />              (setq pt (vlax-curve-getPointAtParam obj (* n fgx)))<br />              (setq plist (cons pt plist)<br />                    n         (1+ n)<br />              )<br />            )<br />            (reverse plist)<br />           )<br />           (t<br />            (if (= "AcDb2dPolyline" objName)<br />              (progn<br />                (repeat vertexsNum<br />                  (setq pt (vlax-curve-getPointAtParam ent n))<br />                  (setq plist (cons pt plist))<br />                  (setq pt (vlax-curve-getPointAtParam ent (+ 0.25 n)))<br />                  (setq plist (cons pt plist))<br />                  (setq pt (vlax-curve-getPointAtParam ent (+ 0.5 n)))<br />                  (setq plist (cons pt plist))<br />                  (setq pt (vlax-curve-getPointAtParam ent (+ 0.75 n)))<br />                  (setq plist (cons pt plist))<br />                  (setq n (1+ n))<br />                )<br />                (if (not (vlax-curve-isClosed ent))<br />                  (setq plist (cons (vlax-curve-getEndPoint ent) plist))<br />                )<br />                (reverse plist)<br />              )<br />              (if (equal fgx 0 1e-6)<br />                (setq plist (GXL-GET_POLY_PTLIST en))<br />                (progn<br />                  (repeat vertexsNum<br />                    (if (setq secdev (vlax-curve-getSecondDeriv ent n))<br />                      (progn<br />                        (setq pt           (vlax-curve-getPointAtParam ent n)<br />                              bugle (vla-GetBulge obj n)<br />                        )<br />                        (setq plist (cons pt plist))<br />                        (if (/= bugle 0.0)<br />                          (progn<br />                            (setq bj (* (atan (abs bugle)) 4))<br />                            (setq d1    (vlax-curve-getdistAtParam ent n)<br />                                  d2    (vlax-curve-getdistAtParam ent (1+ n))<br />                                  d     (- d2 d1)<br />                                  k     (fix (/ bj fgx))<br />                                  d0    (/ 1.0 (1+ k))<br />                                  param n<br />                            )<br />                            (if (equal d0 1.0 0.001)<br />                              (setq plist (cons (vlax-curve-getPointAtParam<br />                                                  ent<br />                                                  (+ 0.5 param)<br />                                                )<br />                                                plist<br />                                          )<br />                              )<br />                              (repeat k<br />                                (setq<br />                                  plist (cons (vlax-curve-getPointAtParam<br />                                                ent<br />                                                (setq param (+ param d0))<br />                                              )<br />                                              plist<br />                                        )<br />                                )<br />                              )<br />                            )<br />                          )<br />                        )<br />                      )<br />                    )<br />                    (setq n (1+ n))<br />                  )<br />                  (if (not (vlax-curve-isClosed ent))<br />                    (setq plist (cons (vlax-curve-getEndPoint ent) plist))<br />                  )<br />                  (reverse plist)<br />                )<br />              )<br />            )<br />           )<br />     )<br />     plist<br />   )<br />   ;;7 对话框上用户选择<br />   (defun getdata ()<br />     (setq BaseSymbol (get_tile "Fuhao"))<br />     (setq JBFD_GetScalStri (get_tile "Scal"))<br />     (setq JBFD_ZoomStri (get_tile "Zoom1"))<br />   )<br />   ;;8 对话框<br />   (defun FDdcl ()<br />     (setq fname (vl-filename-mktemp nil nil ".dcl"))<br />     (setq fn (open fname "w"))<br />     (write-line "Fddcl : dialog{" fn)<br />     (write-line "label=\"*黄明儒*局部放大 命令:FD\";" fn)<br />     (write-line ":column{        " fn)<br />     (write-line<br />       "        :edit_box{label=\"放大标识(F)\";key=\"Fuhao\";value=\"B\";mnemonic=\"F\";}"<br />       fn<br />     )<br />     (write-line<br />       "        :edit_box{label=\"放大倍数(S)\";key=\"Scal\";value=\"2.0\";mnemonic=\"S\";} "<br />       fn<br />     )<br />     (write-line<br />       "        :edit_box{label=\"视口选择(Z)\";key=\"Zoom1\";value=\"0\";mnemonic=\"Z\";} "<br />       fn<br />     )<br />     (write-line<br />       "        :text{key=\"Scaltext\";value=\"圆0,已知封闭曲线1,椭圆2,其余多边形\";}"<br />       fn<br />     )<br />     (write-line "       }" fn)<br />     (write-line "       ok_only;" fn)<br />     (write-line "}" fn)<br /> <br />     (close fn)<br />     (setq fn (open fname "r"))<br />     (setq dclid (load_dialog fname))<br />     (while<br />       (or (eq (substr (setq lin        (vl-string-right-trim<br />                                   "\" fn)"<br />                                   (vl-string-left-trim "(write-line \"" (read-line fn))<br />                                 )<br />                       )<br />                       1<br />                       2<br />               )<br />               "//"<br />           )<br />           (eq (substr lin 1 (vl-string-search " " lin)) "")<br />           (not (eq (substr lin (+ (vl-string-search " " lin) 1) 9)<br />                    " : dialog"<br />                )<br />           )<br />       )<br />     )<br />     (new_dialog (substr lin 1 (vl-string-search " " lin)) dclid)<br />     (set_tile "Fuhao" BaseSymbol)<br />     (set_tile "Scal" JBFD_GetScalStri)<br />     (set_tile "Zoom1" JBFD_ZoomStri)<br />     (mode_tile "Scal" 2)<br />     (Action_Tile "Fuhao" "(Setq BaseSymbol $Value)")<br />     (Action_Tile "Scal" "(Setq JBFD_GetScalStri $Value)")<br />     (Action_Tile "Zoom1" "(Setq JBFD_ZoomStri $Value)")<br />     (action_tile "accept" "(getdata)(done_dialog)")<br />     (setq return# (start_dialog))<br />     (unload_dialog dclid)<br />     (close fn)<br />     (vl-file-delete fname)<br />   )<br /> <br />   ;;9 本程序主程序<br />   (VL-LOAD-COM)<br />   (setq bli1 (getvar "blipmode"))<br />   (setq cmd1 (getvar "cmdecho"))<br />   (setq DIM1 (getvar "DIMASSOC"))<br />   (setq CLA1 (getvar "CLAYER"))<br />   (setq osm1 (getvar "osmode"))<br />   (setvar "blipmode" 0)<br />   (setvar "cmdecho" 0)<br />   (setvar "DIMASSOC" 1)<br />   (setvar "osmode" 0)<br />   (vl-cmdf "layer" "make" "DIM" "Color" 3 "" "")<br />   (if (= JBFD_BaseNumber nil)<br />     (setq JBFD_BaseNumber 65)<br />     (setq JBFD_BaseNumber (1+ JBFD_BaseNumber))<br />   )<br />   (SETQ BaseSymbol (chr JBFD_BaseNumber))<br />   (if (= JBFD_GetScalStri nil)<br />     (setq JBFD_GetScalStri "2.5")<br />   )<br />   (if (= JBFD_ZoomStri nil)<br />     (setq JBFD_ZoomStri "0")<br />   )<br />   (FDdcl)<br />   (setq JBFD_BaseNumber (ascii BaseSymbol))<br />   (SETQ Scalreal (atof JBFD_GetScalStri))<br />   (SETQ getZoom (abs (atoi JBFD_ZoomStri)))<br /> <br />   (if (/= 1 getZoom)<br />     (SETQ CP (GETPOINT "\n 局部放大中心点: "))<br />   )<br />   (cond        ((= 0 getZoom) (command "_.CIRCLE" CP pause))<br />         ((= 1 getZoom)<br />          (while<br />            (not<br />              (and<br />                (setq ent (car (entsel "\n 拾取封闭曲线:")))<br />                (setq p1 (cdr (assoc 0 (entget ent))))<br />                (member p1<br />                        '("SPLINE" "LWPOLYLINE" "POLYLINE" "CIRCLE" "ELLIPSE")<br />                )<br />                (if (member p1 '("SPLINE" "LWPOLYLINE" "POLYLINE"))<br />                  (= (vlax-get-property (vlax-ename->vla-object ent) 'Closed)<br />                     :vlax-true<br />                  )<br />                  T<br />                )<br />              )<br />            )<br />          )<br />         )<br />         ((= 2 getZoom) (command "_.ellipse" CP pause pause))<br />         (T (command "_.polygon" getZoom CP "_I" pause))<br />   )<br />   (SETQ EntCicl (entlast))<br />   ;;(ayEntSSHighLight EntCicl)<br />   (if (= 1 getZoom)<br />     (SETQ EntCicl ent)<br />   )<br /> <br />   (vla-getboundingbox<br />     (vlax-ename->vla-object EntCicl)<br />     'p1<br />     'p2<br />   )<br />   (setq p1 (vlax-safearray->list p1))<br />   (setq p2 (vlax-safearray->list p2))<br />   (setq CP (mapcar '(lambda (X) (/ x 2.0)) (mapcar '+ p1 p2))) ;中心点  <br />   (setq pl (gxl-pL EntCicl 0.017))                  ;取点<br />   (setq ss (ssget "cp" pl))                          ;选择对象<br />   (setq newSS (ss=>NewSS SS EntCicl))                  ;原地拷贝<br />   (setq Newblock (NONAME_BLK newSS CP))                  ;制作成块  <br />   ;;遮盖<br />   (command "_.xclip" Newblock "" "n" "p")<br />   (foreach a pl (command a))<br />   (command "")<br />   (while (not (equal (getvar "cmdnames") "")) (command nil))<br /> <br />   (command "_.copy" EntCicl "" (list 0 0 0) (list 0 0 0))<br />   (setq EntCicl (entlast))<br /> <br />   (SETQ Textheigh (* (GETVAR "DIMTXT") (GETVAR "DIMSCALE"))) ;字度Textheigh<br />   (HdrawLeader EntCicl BaseSymbol Textheigh CP)          ;画引线<br />   (setq        NewP (mapcar '+<br />                      (list 0 (+ (* Scalreal (- (cadr p2) (cadr CP))) Textheigh))<br />                      CP<br />              )<br />   )<br />   (command "_.text"<br />            "J"<br />            "C"<br />            NewP<br />            Textheigh<br />            ""<br />            (strcat BaseSymbol " 放大 " JBFD_GetScalStri "X")<br />   )<br /> <br />   (command "_.scale" Newblock EntCicl "" CP Scalreal)<br />   (command "_.move" Newblock (entlast) EntCicl "" CP pause)<br /> <br />   (setvar "blipmode" bli1)<br />   (setvar "cmdecho" cmd1)<br />   (setvar "DIMASSOC" DIM1)<br />   (setvar "osmode" osm1)<br />   (gc)<br />   (princ)<br /> )<br /> ;;*************************************************************************放大主程序<br />

Gu_xl

自贡黄明儒 发表于 2013-7-26 15:06
终于盼来了G版的源码，是各位给图员的福气
响应G版号召，贴出我改编的源码

最好贴出效果图来或动画演示来！

zhouren_cmi

谢谢二位大师分享实用源码。

龙城飞将36

两位高手来个优化版的~~~~~~~~~~~~~~~~~~~·

海盗曹

支持G版的好程序

lingduwx

麻烦请问默认放大倍数为1改哪几个地方啊，实在是不懂LSP啊

tianyi1230

论坛上有个小笨的局部放大，有对话框，如果有对话框窗体会跟好，

CTC

对于标注箭头是块的话，放大后也跟着放大，最好放大后再还原回到原来那样，另外，放大后的块最好是有名块。