“局部放大"终于完成
本帖最后由 自贡黄明儒 于 2011-11-4 23:12 编辑局部放大."终于完成.
可以圆形、方形、或者任意封闭图形
按理说，用布置出图的话这个局部放大没有存在的必要。据我所知，大部人习惯于模型空间出图，我也习惯这样，其中一个重要的原因是，在布局时电脑反应太慢。怎么说呢，存在即合理吧。
常老师发布TD75整机出图以来，深受欢迎，但申明只能用于CAD2004，今整理使其支持2K以上现有任何版本的AutoCAD。其中还包括mccad、highflybird、田华兵、网蜂工具箱、caoyin、align、<风之影>。。。等等高手（在此不一一列举）的程序，在此一并感谢。
1、版本：支持2K以上现有任何AutoCAD版本。
2、安装：放在《支持文件搜索路径》下即可。(详见使用说明)
3、调用：双击图中空白处。
局部放大程序很好用,谢谢楼主分享 太精采了!
謝謝樓主的分享~
學習了! 表示支持 本帖最后由 自贡黄明儒 于 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 "")
)
;;;;画引线
;向局部放大再迈一步
;删除圆外对象
(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 MAXPARAMMINPARAM
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 throughintersect points
'(lambda (pt / cen elst maxparam
minparam p1 p2 p1paramp2param
)
;;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 Burke6/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-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-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块,其成员加入原选择集构成新选择集
高手帮忙编写放大样LISP程序
要求如下：
1.可用圆及带矩形框选择裁剪，放大，放大倍数可为1
2.要可对块进行裁剪，以及填充线的裁剪
3.放大后的标注比例仍为1:1
以上为基本的3点要求，高手还可补充，谢谢！急盼高手出手相助，不胜感激！
错误: no function definition: LT:ERROR-INIT 运行不了啊 支持一下表示