明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 31889|回复: 102

[基础] “局部放大"终于完成

  [复制链接]
发表于 2011-5-2 21:56 | 显示全部楼层 |阅读模式
本帖最后由 自贡黄明儒 于 2011-11-4 23:12 编辑

局部放大."终于完成.
可以圆形、方形、或者任意封闭图形
按理说,用布置出图的话这个局部放大没有存在的必要。据我所知,大部人习惯于模型空间出图,我也习惯这样,其中一个重要的原因是,在布局时电脑反应太慢。怎么说呢,存在即合理吧。


常老师发布TD75整机出图以来,深受欢迎,但申明只能用于CAD2004,今整理使其支持2K以上现有任何版本的AutoCAD。其中还包括mccad、highflybird、田华兵、网蜂工具箱、caoyin、align、<风之影>。。。等等高手(在此不一一列举)的程序,在此一并感谢。
1、版本:支持2K以上现有任何AutoCAD版本。
2、安装:放在《支持文件搜索路径》下即可。(详见使用说明)
3、调用:双击图中空白处。

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x

点评

HH 2012版.rar 里面都不是放大的源码。。。。浪费了一个币呀。。。老大。。。  发表于 2011-10-10 18:59
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=89384#lastpost 去看下我的程序,谢谢支持  发表于 2011-9-17 20:48
FD运行时出错  发表于 2011-9-17 18:47
"觉得好,就打赏"
还没有人打赏,支持一下

本帖被以下淘专辑推荐:

发表于 2019-7-23 17:19 | 显示全部楼层
局部放大程序很好用,谢谢楼主分享
发表于 2018-2-26 18:11 | 显示全部楼层
太精采了!
謝謝樓主的分享~
學習了!
发表于 2019-4-6 23:46 | 显示全部楼层
表示  支持
 楼主| 发表于 2011-5-3 15:32 | 显示全部楼层
本帖最后由 自贡黄明儒 于 2011-5-8 15:46 编辑

;|(setq EntCicl (car (entsel)))
(setq GetBaseSybl "A")
(setq entText (car (entsel)))|;
;;;;画引线,作放大标示符
(defun HdrawLeader (EntCicl GetBaseSybl entText / A AA B BB C CC D DD EE FF I TEXTLIS)
  (vl-load-com)
  (setq TextLis (entget entText))
  (setq i T)
  (while i
    (setq a (grread T 4 0)
   b (car a)
   c (cadr a)
    )
    ;;b=5移动,b=3左键,c=0右键,;;c=13回车,c=32空格
    (cond ((= b 5)   ;当鼠标移动时
    (redraw)
    (setq a (trans (cadr a) 1 0))
    ;;鼠标移动点
    (setq d (vlax-curve-getclosestpointto EntCicl a))
    ;;a到对象ent的最近点
    (setq aa (car a)
   bb (cadr a)
   cc (caddr a)
    )
    ;;提取 a 的x,y,z
    (setq dd (car d)
   ee (cadr d)
   ff (caddr d))
    (if (<= aa dd)
      (progn (setq TextLis (subst (cons 72 2) (assoc 72 TextLis) TextLis))
        (setq TextLis (subst (cons 11 a) (assoc 11 TextLis) TextLis))
      )
     (progn (setq TextLis (subst (cons 72 0) (assoc 72 TextLis) TextLis))
       (setq TextLis (subst (cons 10 a) (assoc 10 TextLis) TextLis))
      )
    )
    (entmod TextLis)
    (grdraw a d 1)
   )
   ;;end_cond第一个括号
   ((= b 3) (setq i nil))
   ;;左键结束while(cond第二个括号)
    )
    ;;end_cond
  )
  ;;end_while
  (command "leader" d (cadr a) "" GetBaseSybl "")
)
;;;;画引线
 楼主| 发表于 2011-5-5 20:54 | 显示全部楼层
;向局部放大再迈一步
;删除圆外对象
(defun C:ssCircle (/ ALLOBJECTS CMD ENT SS)
  (setq cmd (getvar "CMDECHO"))
  (setvar "CMDECHO" 0)
  (command ".undo" "begin")

  (setvar "CMDECHO" cmd)
  (not (command ".undo" "end"))
  (princ)
)


(defun onlockedlayer (ename / entlst)
  (setq entlst (tblsearch "LAYER" (cdr (assoc 8 (entget ename)))))
  (= 4 (logand 4 (cdr (assoc 70 entlst))))
)

;;;下面函数返回所有对象,包括打断后的对象
(defun ssCircle1 (ss            ent              /                BRKOBJLST BRK_OBJ
                  EN            IPLIST    LASTENT        MAXPARAM  MINPARAM
                  OBJ            OBJ2BREAK OBJ_ERASE        P1PARAM          P2
                  P2PARAM   PT              SSOBJS        SSOBJSALL
                 )
  (vl-load-com)
  (defun ssget->vla-list (ss ent / i ename lst)
    (setq i -1)
    (while (setq ename (ssname ss (setq i (1+ i))))
      (if (equal ename ent)
        (setq ss (ssdel ent ss))
      )
      ;; check for locked layer, do not use if on locked layer  
      (if (and (not (onlockedlayer ename))
               (not (equal ename ent))
          )                                ; exclude break object  
        (setq lst (cons (vlax-ename->vla-object ename) lst))
      )
    )
    lst
  )

  (defun list->3pair (old / new)
    (while (setq new (cons (list (car old) (cadr old) (caddr old)) new)
                 old (cdddr old)
           )
    )
    (reverse new)
  )



  (if (and ss
           ent
           (setq ssobjs (ssget->vla-list ss ent))
      )
    (progn
;;;用ssobjsAll来收集包括打断后的对象
      (setq ssobjsAll ss)
      (setq brk_obj (vlax-ename->vla-object ent))
      (mapcar
        '(lambda (obj2Break / iplist brkobjlst lastent)
                                        ; loop through list of objects to be broken  
                                        ; get list of intersect points  
           (setq iplist        (vl-catch-all-apply
                          'vlax-safearray->list
                          (list        (vlax-variant-value
                                  (vla-intersectwith
                                    brk_obj
                                    obj2Break
                                    acextendnone
                                  )
                                )
                          )
                        )
           )
           (setq brkobjlst (cons obj2Break brkobjlst))
                                        ; collect the original object to be broken  
           (if (not (vl-catch-all-error-p iplist))
                                        ;  error if no intersection  
             (mapcar                        ; loop through  intersect points  
               '(lambda        (pt          /           cen            elst     maxparam
                         minparam p1           p2            p1param  p2param
                        )
                  ;;  get last entity created via break in case multiple breaks  
                  (if
                    (and
                      lastent
                      (not
                        (equal lastent (vlax-vla-object->ename brk_obj))
                      )
                    )                        ; ignore the break object  
                     (progn                ; new object created via break, put in list  
                       (setq
                         brkobjlst (cons
                                     (vlax-ename->vla-object (entlast))
                                     brkobjlst
                                   )
                       )
                       (setq ssobjsAll (ssadd (entlast) ssobjsAll))
                       ;;  if pt not on object x, switch objects  
                       (if
                         (not (vlax-curve-getdistatpoint obj2Break pt))
                          (foreach obj brkobjlst
                                        ; find the one that pt is on  
                            (if        (vlax-curve-getdistatpoint obj pt)
                              (setq obj2Break obj) ; switch objects  
                            )
                          )
                       )
                     )
                  )

                  ;;  Handle any objects that can not be use with the Break Command  
                  ;;  using one point  
                  (cond
                    ((and (= "AcDbSpline" (vla-get-objectname obj2Break))
                                        ; only closed splines  
                          (vlax-curve-isClosed obj2Break)
                     )
                     (setq p1param (vlax-curve-getparamatpoint obj2Break pt)
                           p2param (+ p1param 0.000001)
                           p2           (vlax-curve-getPointAtParam obj2Break p2param)
                     )
                     (command "._break"
                              (vlax-vla-object->ename obj2Break)
                              "non"
                              (trans pt 0 1)
                              "non"
                              (trans p2 0 1)
                     )
                    )
                    ((= "AcDbCircle" (vla-get-objectname obj2Break))
                                        ; break the circle  
                     (setq p1param (vlax-curve-getparamatpoint obj2Break pt)
                           p2param (+ p1param 0.000001)
                           p2           (vlax-curve-getPointAtParam obj2Break p2param)
                     )
                     (command "._break"
                              (vlax-vla-object->ename obj2Break)
                              "non"
                              (trans pt 0 1)
                              "non"
                              (trans p2 0 1)
                     )
                     (setq en (entlast))
                     (setq ssobjsAll (ssadd en ssobjsAll))
                    )
                    ((and
                       (= "AcDbEllipse" (vla-get-objectname obj2Break))
                                        ; only closed ellipse  
                       (vlax-curve-isClosed obj2Break)
                     )
                     ;;  Break the ellipse, code borrowed from Joe Burke  6/6/2005  
                     (setq p1param  (vlax-curve-getparamatpoint obj2Break pt)
                           p2param  (+ p1param 0.000001)
                                        ;(vlax-curve-getparamatpoint obj p2)  
                           minparam (min p1param p2param)
                           maxparam (max p1param p2param)
                     )
                     (vlax-put obj2Break 'startparameter maxparam)
                     (vlax-put obj2Break
                               'endparameter
                               (+ minparam (* pi 2))
                     )
                    )
                    ;;==================================  
                    ;;   Objects that can be broken      
                    ;;==================================  
                    (t
                     (command "._break"
                              (vlax-vla-object->ename obj2Break)
                              "non"
                              (trans pt 0 1)
                              "non"
                              (trans pt 0 1)
                     )
                     ;;  could not get vl-cmdf "._break" to behave  
                     (setq lastent (entlast))
                     (setq ssobjsAll (ssadd lastent ssobjsAll))
                    )
                  )

                )
               (list->3pair iplist)
             )
           )
         )
        ssobjs
      )
      ;; remove the break line, if current layer is not locked  
      (if obj_erase
        (vl-catch-all-apply 'vla-delete (list brk_obj))
      )
    )
  )

  ssobjsAll
)


;;;------------------------------------------
;;;本函数得到圆内实体选择集
;;;曲线两端点均在圆外,则在圆外
;;;allObjects选择集,ent圆
(defun GetInCircleObjects
       (allObjects ent / CIRLCENTER DIST2 E E1 ENTLIS N R SSNEW)
  (setq ssNew (ssadd))
  (setq entlis (entget ent))
  (setq R (Li_item 40 entlis))
  (setq CirlCenter (Li_item 10 entlis))
  (setq n 0)
  (repeat (sslength allObjects)
    (setq e (ssname allObjects n))
    (if        (= (type e) 'ename)
      (setq e1 (vlax-ename->vla-object e))
    )

    (setq dist2 (distance (gxl-Ax:GetMidpointCurve e1) CirlCenter))
    (if        (= (vlax-curve-getStartPoint e1)
           (vlax-curve-getEndPoint e1)
        )
      (setq dist2 (distance (li_item 10 entlis) CirlCenter))
    )

    (if        (<= dist2 R)
      (setq ssNew (ssadd e ssNew))
      (entdel e)
    )
    (setq n (1+ n))
  )
  ssNew
)

;;; (gxl-Ax:GetMidpointCurve curve) 计算曲线中点
(defun gxl-Ax:GetMidpointCurve (curve / d)
  (setq d (/ (gxl-ax:GetCurveLength curve) 2))
  (vlax-curve-getPointAtDist curve d)
)

;;;ax:GetCurveLength 返回曲线长度
(defun gxl-ax:GetCurveLength (curve /)
  (if (= 'ENAME (type curve))
    (setq curve (vlax-ename->vla-object curve))
  )
  (vlax-curve-getDistAtParam
    curve
    (vlax-curve-getEndParam curve)
  )
)
;;;ax:GetCurveLength 返回曲线长度
 楼主| 发表于 2011-5-5 21:02 | 显示全部楼层
本帖最后由 自贡黄明儒 于 2011-5-8 15:40 编辑

;;;;画圆,以显示放大范围
(defun HdrawCicl (EntCicl / A B C CICLLIS I PONI R)
  (vl-load-com)
  (setq CiclLis (entget EntCicl))
  (setq poni (LI_item 10 CiclLis))
  (setq i T)
  (while i
    (setq a (grread T 4 0)
   b (car a)
   c (cadr a)
    )
    ;;b=5移动,b=3左键,c=0右键,;;c=13回车,c=32空格
    (cond ((= b 5)   ;当鼠标移动时
    (redraw)
    (setq a (trans (cadr a) 1 0))
    ;;鼠标移动点   
    (setq R (distance a poni))
    (setq CiclLis (subst (cons 40 R) (assoc 40 CiclLis) CiclLis))
    (entmod CiclLis)
   )
   ;;end_cond第一个括号
   ((= b 3) (setq i nil))
   ;;左键结束while(cond第二个括号)
    )
    ;;end_cond
  )
  ;;end_while
)
;;;;画圆
发表于 2011-5-7 12:27 | 显示全部楼层
          顶起楼主
 楼主| 发表于 2011-5-8 20:30 | 显示全部楼层
本帖最后由 自贡黄明儒 于 2011-5-8 20:31 编辑

;;;爆破 块中块
;;;Copy块,其成员加入原选择集构成新选择集
;;;(setq ss (ssget))
;;;(setq block (car (entsel)))
;;;(Block=>NewSS ss block)
(defun Block=>NewSS (SS Block / E ENT N SS1 BlockN)
  (command "copy" Block "" (list 0 0 0) (list 0 0 0))
  (setq BlockN (entlast))
  (command "explode" BlockN)
  (setq ss1 (ssget "_P"))
  (setq n 0)
  (repeat (sslength ss1)
    (setq e (ssname ss1 n))
    (setq ent (entget e))
    (if        (wcmatch (LI_item 0 ent)
                 "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"
        )
      (setq SS (ssadd e SS))
      (progn (if (wcmatch (LI_item 0 ent) "INSERT")
               (progn
               (setq SS (Block=>NewSS SS e)) (entdel e))
               (entdel e)
             )
      )
    )
    (setq n (1+ n))
  )
  ss
)
;;;Copy块,其成员加入原选择集构成新选择集
发表于 2011-5-8 21:08 | 显示全部楼层
高手帮忙编写放大样LISP程序
要求如下:
1.可用圆及带矩形框选择裁剪,放大,放大倍数可为1
2.要可对块进行裁剪,以及填充线的裁剪
3.放大后的标注比例仍为1:1

以上为基本的3点要求,高手还可补充,谢谢!急盼高手出手相助,不胜感激!
发表于 2011-5-11 16:15 | 显示全部楼层
错误: no function definition: LT:ERROR-INIT
发表于 2011-5-11 16:55 | 显示全部楼层
运行不了啊
发表于 2011-5-11 17:28 | 显示全部楼层
支持一下表示
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-3-29 17:33 , Processed in 0.695721 second(s), 32 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表