“局部放大"终于完成

自贡黄明儒

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


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

zgssd

局部放大程序很好用,谢谢楼主分享

pedromax

太精采了!
謝謝樓主的分享~
學習了!

forever111

表示  支持

自贡黄明儒

;|(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 "")
)
;;;;画引线

自贡黄明儒

;向局部放大再迈一步
;删除圆外对象
(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 返回曲线长度

自贡黄明儒

;;;;画圆,以显示放大范围
(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
)
;;;;画圆

jfxia

          顶起楼主

自贡黄明儒

;;;爆破 块中块
;;;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块,其成员加入原选择集构成新选择集

zhouwanweihf

高手帮忙编写放大样LISP程序
要求如下：
1.可用圆及带矩形框选择裁剪，放大，放大倍数可为1
2.要可对块进行裁剪，以及填充线的裁剪
3.放大后的标注比例仍为1:1

以上为基本的3点要求，高手还可补充，谢谢！急盼高手出手相助，不胜感激！

cag

错误: no function definition: LT:ERROR-INIT

lrd1861

运行不了啊

display18

支持一下表示