;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;放大主程序
;;全局GetScalStri放大倍数（字符），BaseNumber标识（数字）
(defun c:t1 ()
  (if (numberp BaseNumber)
    (setq BaseNumber (1+ BaseNumber))
    (setq BaseNumber 65)
  )
  (SETQ BaseSymbol (chr BaseNumber))

  (if (= GetScalStri nil)
    (setq GetScalStri "2.5")
  )

  (setq strin (findfile "FdDcl.DCL"))
  (setq dcl_d1 (load_dialog strin)) ; Load the DCL file. 
  (if (not (new_dialog "Fddcl" dcl_d1))
    (exit)
  )     ;endif
  (set_tile "Fuhao" BaseSymbol)
  (set_tile "Scal" GetScalStri)
  (mode_tile "Scal" 2)
  (action_tile "accept" "(getdata)(done_dialog)") ;
  (start_dialog)
  (unload_dialog dcl_d1);卸载对话框
 
  (defun getdata ()
    (setq GetBaseSybl (get_tile "Fuhao"))
    (setq BaseNumber (ascii GetBaseSybl))  
    (setq GetScalStri (get_tile "Scal"))
    (SETQ Scalreal (atof GetScalStri))
  )
   

  ;;创建圆
  (INITGET 4)
  (SETQ CP (GETPOINT "\n局部放大中心点: "))
  (PROMPT "\n放大范围: ")
  (command "CIRCLE" CP 10)
  (SETQ EntCicl (ENTLAST))  ;圆
  (HdrawCicl EntCicl)
  (setq entCircl   (entget EntCicl)
 PointCircl (LI_item 10 entCircl)
  )

  ;;字体高度Textheigh
  (SETQ Textheigh (* (GETVAR "DIMTXT") (GETVAR "DIMSCALE")))
  (command "text" CP Textheigh "" (chr BaseNumber))
  (setq entText (entlast))

  (SETQ CIR_R (CDR (ASSOC 40 (ENTGET EntCicl))))
  ;;5度时的弧度值DATA_G,取两个圆以确保
  (SETQ DATA_G '(0.0     0.0872665  0.174533   0.261799   0.349066
   0.436332   0.523599   0.610865   0.698132   0.785398
   0.872665   0.959931   1.0472   1.13446    1.22173
   1.309     1.39626    1.48353   1.5708     1.65806
   1.74533    1.8326     1.91986   2.00713    2.0944
   2.18166    2.26893    2.35619   2.44346    2.53073
   2.61799    2.70526    2.79253   2.87979    2.96706
   3.05433    3.14159    3.22886   3.31613    3.40339
   3.49066    3.57792    3.66519   3.75246    3.83972
   3.92699    4.01426    4.10152   4.18879    4.27606
   4.36332    4.45059    4.53786   4.62512    4.71239
   4.79966    4.88692    4.97419   5.06145    5.14872
   5.23599    5.32325    5.41052   5.49779    5.58505
   5.67232    5.75959    5.84685   5.93412    6.02139
   6.10865    6.19592    0.0   0.0436332  0.1309
   0.218166   0.305433   0.392699   0.479966   0.567232
   0.654498   0.741765   0.829031   0.916298   1.00356
   1.09083    1.1781     1.26536   1.35263    1.4399
   1.52716    1.61443    1.7017   1.78896    1.87623
   1.9635     2.05076    2.13803   2.22529    2.31256
   2.39983    2.48709    2.57436   2.66163    2.74889
   2.83616    2.92343    3.01069   3.09796    3.18523
   3.27249    3.35976    3.44703   3.53429    3.62156
   3.70882    3.79609    3.88336   3.97062    4.05789
   4.14516    4.23242    4.31969   4.40696    4.49422
   4.58149    4.66876    4.75602   4.84329    4.93056
   5.01782    5.10509    5.19235   5.27962    5.36689
   5.45415    5.54142    5.62869   5.71595    5.80322
   5.89049    5.97775    6.06502   6.15229    6.23955
   0.0436332
  )
  )
  ;;圆上取点DATA_A

  (setq p1 (mapcar '+ PointCircl (list CIR_R CIR_R 0))
 p2 (mapcar '- PointCircl (list CIR_R CIR_R 0))
  )
  (SETQ DATA_A (MAPCAR '(LAMBDA (X) (POLAR CP X CIR_R)) DATA_G))

  ;;取与圆相交的实体，块除外(选择集)
  (setq ssObj
  (ssget
    "C"
    p1
    p2
    '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))
  )
  )
  ;;与圆相交的块(选择集)
  (setq ssblocks (ssget "F" DATA_A '((0 . "INSERT"))))
  ;;圆内物体(选择集)
  (setq SSInCircle (SelectObjectS EntCicl))

  ;;与圆相交的新的选择集
  (setq ssObj (ss=>NewSS ssObj EntCicl))
  (if ssblocks
    (setq ssObj (BlockS=>NewSS ssObj ssblocks))
  )
  ;;与圆相交打断 
  (setq ssObj (ssCircle1 ssObj EntCicl))
  ;;圆外对象删除
  (setq ssObj (GetInCircleObjects ssObj EntCicl))

  ;;加入圆内对象
  ;;(if SSInCircle (setq ssObj (SS_SSjoin ssObj SSInCircle)))

  ;;生成块
  (setq newblock (mc-make-unname-block ssObj))

  ;;画引线
  (HdrawLeader EntCicl GetBaseSybl entText)

  (command "_scale" newblock "" PointCircl Scalreal)
  ;|(setq TextLis (entget entText))
   (setq TextLis (subst (cons 72 1) (assoc 72 TextLis) TextLis))
  (setq pText (mapcar '+
        PointCircl
        (list 0 (+ Textheigh (* CIR_R Scalreal)))
       )
  )
  (setq TextLis (subst (cons 10 pText) (assoc 10 TextLis) TextLis))
  (command "move" TextLis newblock "" CP PAUSE)
 
  (gc)|;
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;放大主程序

;;;下面函数返回所有对象,包括打断后的对象
(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 返回曲线长度

;;;;;;;;;Copy原选择集,构成新的选择集
;;;SS选择集,EntCicl不加入选择集对象
(defun ss=>NewSS (SS EntCicl / E N NEWSS)
(setq NewSS (ssadd))
(setq n 0)
(repeat (sslength ss)
  (setq e (ssname ss n))
  (command "copy" e "" (list 0 0 0) (list 0 0 0))
  (setq e (entlast))
  (setq NewSS (ssadd e NewSS))
  (setq n (1+ n))
)
  NewSS
)
;;;;;;;;;Copy原选择集,构成新的选择集

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

;;;块集各成员加入SS选择集
(defun BlockS=>NewSS (SS BlockS / BLOCK N)
  (setq n 0)
  (repeat (sslength BlockS)
    (setq Block (ssname BlockS n))
    (setq SS (Block=>NewSS SS Block))
    (setq n (1+ n))
  )
  SS
)
;;;块集各成员加入SS选择集

;;;;;;;;;;;;;;;;;;;;;生成无名块
;;;;;;;;;上传者 mccad
;;;; defination of anonymous block
(defun mc-make-unname-block (ss / count entlist ent blk)
  (entmake '((0 . "BLOCK")
      (2 . "*U")
      (70 . 1)
      (10 0 0 0)
     )
  )
  (setq count 0)
  (repeat (sslength ss)
    (setq entlist (entget (setq ent (ssname ss count))))
    (setq count (1+ count))
    (entmake entlist)
  )
  (setq count 0)
  (repeat (sslength ss)
    (setq ent (ssname ss count))
    (setq count (1+ count))
    (entdel ent)
  )
  (setq blk (entmake '((0 . "ENDBLK"))))
  (if (princ blk)
    (entmake (list (cons 0 "INSERT")
     (cons 2 blk)
     (cons 10 '(0 0 0))
      )
    )
  )
  blk
)
;;;;;;;;;;;;;;;;;;;;;生成无名块

;;;选择集合并
(defun SS_SSjoin (ss1 ss2 / EN N en1)
  (setq n 0)
  (repeat (sslength ss2)
    (setq en (ssname ss2 n))
    (command "copy" en "" (list 0 0 0) (list 0 0 0))
    (setq en1 (entlast))
    (setq ss1 (ssadd en1 ss1))
    (setq n (1+ n))
  )
  ss1
)
;;;选择集合并

;;;;;;;;;;;;;;;;;;;;;;;;;选择对象
(defun SelectObjectS (EntCicl / end i lineobj num plst start)
  (vl-load-com)
  (setq lineObj (vlax-ename->vla-object EntCicl)
 start (vlax-curve-getStartParam lineObj)
 end (vlax-curve-getEndParam lineObj)
 i 0
  )
  (while (< i (setq num 100))
    (setq plst (append
   plst
   (list (vlax-curve-getPointAtParam lineObj
              (* i
          (/
             (- end start)
             num
          )
              )
       )
        
   )
        )
   i (1+ i)
    )
  )
  (ssget "WP" plst)
  ;(command "select" "p")
)
;;;;;;;;;;;;;;;;;;;;;;;;;选择对象

;|(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
  (redraw)
 
  (command "leader" d (cadr a) "" GetBaseSybl "")

)
;;;;画引线

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

;;;;画圆
(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
)
;;;;画圆