[原创]：一个局部放大程序

li809 · 发表于 2005-2-19 01:48:29

作何用之有呢，我是用不到的

1448 · 发表于 2005-2-21 20:15:04

可用多视口，为什么还要用放大程序。

andyding · 发表于 2005-2-22 00:18:01

楼主,程序只把放大部分COPY出来,没有放大?

lijiao · 发表于 2005-2-22 08:53:22

正如1448所说，最好的方法是用视口，而不是COPY。
还有就是MECHANICAL是用图块和反应器，也挺好的。

ss1025 · 发表于 2005-2-22 10:10:58

我觉得以前用天正的时候，有个图形裁剪的命令，可以在大图中截出一部分来。
那个命令挺好啊。这个局部放大好像没什么用啊。

xotoo · 发表于 2008-8-9 03:20:27

同楼上，我也喜欢天正的那个功能，可是又不能为了这个小功能就安装一个天正，真郁闷……

timnis · 发表于 2008-8-11 12:27:51

这个功能是用来画大样的吗？好像太麻烦了吧？

feige12 · 发表于 2008-9-9 14:35:29

好像看不懂啊

yxianfo · 发表于 2008-9-10 17:17:22

4楼的程序对画机械图的来说还是较实用。
发现一个不足之处是，当放大图的区域圆与圆弧线相交时，弧线未被修剪掉，不过并不影响本程序的使用。

davide888 · 发表于 2013-5-22 09:07:56

感觉好复杂

2012淡然之马 · 发表于 2013-5-22 14:41:35

写的好复杂，
貌似还用不了勒

/db_自贡黄明儒_ · 发表于 2013-5-23 13:24:11

aeo 发表于 2004-11-10 23:41
过点时间，我来写一个放大的（建筑,根据理正里的层和实体)
要处理的东西:
1.文字原来大小

既然aeo版主有兴趣,我贴出我写的代码,当时有感于小金鱼的要注册,所以自己写了一个,一直希望哪位高手完善一下,但没有人响应,悲哀呀!

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;放大主程序黄明儒
;;全局JBFD_GetScalStri放大倍数（字符），JBFD_BaseNumber标识（数字）,JBFD_ZoomStri视口
(defun C:FD (/ BASESYMBOL BRKOBJLST BRK_OBJ CP DCLID
DIMASSOC1 EN ENT ENTCICL FDLAYER FN
FNAME GETZOOM HOLDBLIPMO HOLDCMDECH IPLIST LASTENT
LIN LST1 LST2 MAXPARAM MINPARAM NEWBLOCK
NEWP OBJ OBJ2BREAK P1 P1PARAM P2
P2PARAM PT RETURN# SCALREAL SSBLOCKS SSINCIRCLE
SSOBJ SSOBJSALL SS_BOLCK TEXTHEIGH X
)
;;下面函数返回所有对象,包括打断后的对象
(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
)
;;------------------------------------------
;;本函数得到圆内实体选择集(3dm_pl_region_GE_PtInPoly (gxl-Ax:GetMidpointCurve e) (Object-Plst ent) T)
;;曲线中点在圆外，则在圆外
;;allObjects选择集，ent圆
(defun GetInCircleObjects
(allObjects ent / E N SSNEW)
(setq ssNew (ssadd))
(setq n 0)
(repeat (sslength allObjects)
(setq e (ssname allObjects n))
(if (3dm_pl_region_GE_PtInPoly (gxl-Ax:GetMidpointCurve e)
(Object-Plst ent)
T
)
(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 CURVE SSInCircle / E ENT N SS1 BlockN LIS)
(command "copy" Block "" (list 0 0 0) (list 0 0 0))
(setq BlockN (entlast))
(command "explode" BlockN)
(setq ss1 (ssget "_P"))
(setq n 0)
(if (equal SSInCircle nil)
(setq SSInCircle (ssadd))
)
(repeat (sslength ss1)
(setq e (ssname ss1 n))
(setq ent (LI_item 0 (entget e)))
(cond
((eInClosedCurve e CURVE)
(setq SSInCircle (ssadd e SSInCircle))
)
((wcmatch ent "*LINE,ARC,CIRCLE,ELLIPSE")
(setq SS (ssadd e SS))
)
((wcmatch ent "INSERT,HATCH,DIMENSION")
(progn (setq lis (Block=>NewSS SS e CURVE SSInCircle))
(setq SSInCircle (cadr lis))
(setq ss (car lis))
(entdel e)
)
)
((AND (wcmatch ent "TEXT") (textInClosedCurve e CURVE))
(setq SSInCircle (ssadd e SSInCircle))
)
(T (entdel e))
)
(setq n (1+ n))
)
(LIST ss SSInCircle)
)
;;Copy块,其成员加入原选择集构成新选择集
;;块集各成员加入SS选择集
(defun BlockS=>NewSS (SS BlockS CURVE / BLOCK N LIS SSInCircle)
(setq n 0)
(setq SSInCircle (ssadd))
(repeat (sslength BlockS)
(setq Block (ssname BlockS n))
(setq LIS (Block=>NewSS SS Block CURVE SSInCircle))
(setq SS (car LIS)
SSInCircle (cadr LIS)
)
(setq n (1+ n))
)
LIS
)
;;块集各成员加入SS选择集
;;生成无名块
(defun NONAME_BLK (SS PointCircl / A BLKREF)
(setq A (rtos (* (getvar "CDATE") 1E8)))
(if (/= SS NIL)
(progn
(command "_.BLOCK" A PointCircl SS "")
(command "_.INSERT" A "@" "" "" "")
;|(setq BLKREF (vlax-ename->vla-object (entlast)))
(vla-put-name
(vla-item (vla-get-blocks
(vla-get-activedocument (vlax-get-acad-object))
)
(vla-get-name BLKREF)
)
"*U"
)
(vlax-release-object BLKREF)|;
)
)
)
;;生成无名块
;;选择集合并
(defun SS_SSjoinENT (ss1 ss2 EntCicl / BOOL EN EN1 N)
;;如果ss1中没有圆EntCicl,则加入之
(setq n 0)
(repeat (sslength ss1)
(setq en (ssname ss1 n))
(if (= en EntCicl)
(setq bool T)
)
)
(if bool
nil
(progn (command "copy" EntCicl "" (list 0 0 0) (list 0 0 0))
(setq en1 (entlast))
(setq ss1 (ssadd en1 ss1))
)
)
(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 Object-Plst (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)
)
)
plst
)
;;选择对象
;|(setq EntCicl (car (entsel)))
(setq BaseSymbol "A")
(setq entText (car (entsel)))|;
;;画引线
(defun HdrawLeader (EntCicl BaseSymbol Textheigh CP /
A AA B BB C CC D
DD EE FF I TEXTLIS ENTTEXT ola
)
(vl-load-com)
(command "text" CP Textheigh "" BaseSymbol)
(setq entText (entlast))
(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)
(entdel entText)
;(setvar "DIMLDRBLK" "DotSmall")
(setq ola (getvar "clayer"))
(vl-cmdf "layer" "make" "DIM" "Color" 3 "" "")
(command "leader" d (cadr a) "" BaseSymbol "")
(setvar "clayer" ola)
;(setvar "DIMLDRBLK" ".")
;(vl-cmdf "leader" d (cadr a) "f" "st" "f" "a" "" BaseSymbol "")
;(setq leaderobj (vlax-ename->vla-object (entlast)))
;(vla-put-ArrowheadType leaderobj acArrowDotSmall)
;(vla-Update leaderobj)
)
;;画引线
(defun onlockedlayer (ename / entlst)
(setq entlst (tblsearch "LAYER" (cdr (assoc 8 (entget ename)))))
(= 4 (logand 4 (cdr (assoc 70 entlst))))
)
;;点在曲线内外,caoyin
;; T------->在曲线内
(defun LT:PT-INCURVE (PT CURVE / GetInters OBJ MINPT MAXPT E PS LST X Y)
(defun GetInters (OBJ1 OBJ2 / PS LST)
(setq PS (vla-intersectwith OBJ1 OBJ2 0)
PS (vl-catch-all-apply 'vlax-safearray->list
(list (vlax-variant-value PS))
)
)
(if (and PS (not (vl-catch-all-error-p PS)))
(while (setq LST (cons (list (car PS) (cadr PS)) LST)
PS (cdddr PS)
)
)
)
LST
)
(if (equal (vlax-curve-getClosestPointTo CURVE PT) PT 1E-6)
0
(progn
(setq OBJ (vlax-ename->vla-object CURVE))
(vla-getboundingbox OBJ 'MINPT 'MAXPT)
(mapcar '(lambda (X) (set X (vlax-safearray->list (eval X))))
'(MINPT MAXPT)
)
(entmake (list '(0 . "LINE")
(list 10 (car MINPT) (cadr PT))
(list 11 (car MAXPT) (cadr PT))
'(60 . 1)
)
)
(setq E (entlast)
LST1 (GetInters OBJ (vlax-ename->vla-object E))
)
(entdel E)
(if LST1
(setq LST1 (vl-remove-if
'(lambda (X / PP A)
(setq PP (vlax-curve-getParamAtPoint CURVE X)
A (angle '(0 0)
(vlax-curve-getFirstDeriv CURVE PP)
)
)
(or (equal A 0 1E-6)
(equal A PI 1E-6)
(equal A (* PI 2) 1E-6)
(equal (fix PP) PP 1E-6)
)
)
LST1
)
)
)
(entmake (list '(0 . "LINE")
(list 10 (car PT) (cadr MAXPT))
(list 11 (car PT) (cadr MINPT))
'(60 . 0)
)
)
(setq E (entlast)
LST2 (GetInters OBJ (vlax-ename->vla-object E))
)
(entdel E)
(if LST2
(setq LST2 (vl-remove-if
'(lambda (X / PP A)
(setq X (vlax-curve-getClosestPointTo CURVE X)
PP (vlax-curve-getParamAtPoint CURVE X)
A (angle (vlax-curve-getFirstDeriv CURVE PP)
'(0 0)
)
)
(or (equal A (/ PI 2) 1E-6)
(equal A (* PI 1.5) 1E-6)
(equal (fix PP) PP 1E-6)
)
)
LST2
)
)
)
(and LST1
LST2
(progn
(setq X (vl-sort-i (mapcar 'car (cons PT LST1)) '<)
Y (length (member 0 X))
)
(and (zerop (rem Y 2)) (= (rem (- (length X) Y) 2) 1))
)
(progn
(setq X (vl-sort-i (mapcar 'cadr (cons PT LST2)) '<)
Y (length (member 0 X))
)
(and (zerop (rem Y 2)) (= (rem (- (length X) Y) 2) 1))
)
)
)
)
)
;;点在曲线内外,caoyin
;;*************************************************************************************
;; ! Argument : 'pt' - point ot be tested
;; ! 'vlist' - List of points forming the polgon
;; ! 'flag' - If 'T', point on the line is inside else outside
(defun 3dm_pl_region_GE_PtInPoly (pt vlist flag / NumInts diff
cnt online p1 p1code p1x p1y p2
p2code p2x p2y ttl x xdiff xx
y ydiff Idx len
)
(if (not (equal (car vlist) (last vlist)))
(setq vlist (append
vlist
(list (car vlist))
)
)
)
(setq X (car pt)
Y (cadr pt)
len (length vlist)
cnt 0
Idx 0
NumInts 0
OnLine nil
)
(while (and
(not OnLine)
(< cnt len)
)
(setq p2 (nth cnt vlist)
p2x (car p2)
p2y (cadr p2)
p2code (if (>= p2y y)
2
0
)
p2code (if (>= p2x x)
(1+ p2code)
p2code
)
)
(if p1
(setq diff (boole 6 p1code p2code)
ydiff (boole 1 diff 2)
xdiff (boole 1 diff 1)
p1x (car p1)
p1y (cadr p1)
)
)
(if (= ydiff 2)
(progn
(setq xx (+ p1x (* (/ (- p2x p1x) 1. (- p2y p1y)) (- y p1y))))
(cond
((equal xx x 0.0001)
(setq online T)
)
((> xx x)
(setq NumInts (1+ NumInts))
)
)
)
)
(if (and
(= xdiff 1)
(= y p1y p2y)
)
(setq OnLine T)
)
(setq p1code p2code
p1 p2
cnt (1+ cnt)
)
)
(if Online
flag
(= (boole 1 NumInts 1) 0001)
)
)
;;**************************************************************
;; | ----------------------------------------------------------------------------
;; | SS_SSjoin
;; | ----------------------------------------------------------------------------
;; | Function : Joins two selections set and returns their sum
;; | Arguments:
;; | 'ss1' - First Selection set (overloaded - can be entity
;; | name as well)
;; | 'ss2' - Second Selection set (overloaded - can be entity
;; | name as well)
;; | Return : The difference selection set
;; | Updated : April 24, 1998
;; | e-mail : rakesh.rao@4d-technologies.com
;; | Web : www.4d-technologies.com
;; | ----------------------------------------------------------------------------
(defun SS_SSjoin (ss1 ss2 / ename ss cnt)
(if ss1
(progn
(if (= (type ss1) 'ENAME)
(progn
(setq
ename ss1
ss1 (ssadd)
)
(ssadd ename ss1)
)
)
)
)
(if ss2
(progn
(if (= (type ss2) 'ENAME)
(progn
(setq
ename ss2
ss2 (ssadd)
)
(ssadd ename ss2)
)
)
)
)
(setq ss (ssadd))
(if (and ss1 ss2)
(progn
(setq ss ss2
cnt 0
)
(repeat (sslength ss1)
(ssadd (ssname ss1 cnt) ss)
(setq cnt (1+ cnt))
)
)
)
(if (and ss1 (not ss2))
(setq ss ss1)
)
(if (and ss2 (not ss1))
(setq ss ss2)
)
(if (> (sslength ss) 0)
(eval ss)
nil
)
)
;;选择集合并
;;判断一个对象是否在封闭曲线内,返回T
;;(eInClosedCurve (car (entsel)) (car (entsel)))
;;(textInClosedCurve (car (entsel)) (car (entsel)))
(defun eInClosedCurve (e Curve / AREACURVE AREAE
BOOL BOOL1 CURVE1 E0 E1 E2
EN P1 P2 P3 P4 REGIONINTERSECT
)
;(setq e (car (entsel)) Curve (car (entsel)))
(vl-load-com)
;;先判断4个顶点是否在封闭曲线内
(setq en (vlax-ename->vla-object e))
(vla-getboundingbox en 'p1 'p3)
(setq p1 (vlax-safearray->list p1))
(setq p3 (vlax-safearray->list p3))
(setq p2 (list (car p3) (cadr p1)))
(setq p4 (list (car p1) (cadr p3)))
(if (and (LT:PT-INCURVE p1 CURVE)
(LT:PT-INCURVE p2 CURVE)
(LT:PT-INCURVE p3 CURVE)
(LT:PT-INCURVE p4 CURVE)
)
(progn
(command "_rectang" p1 p3)
(setq e0 (entlast))
(command "_region" e0 "")
(setq e1 (entlast))
(command "area" "o" e1)
(setq areae (getvar "area"))
(command "erase" e0 "")
;;面域
(command "copy" Curve "" (list 0 0 0) (list 0 0 0))
(setq Curve1 (entlast))
(command "_region" Curve1 "")
(setq e2 (entlast))
;;面域
(command "intersect" e1 e2 "")
;;如果没有交集,原Curve会被删除???
(setq RegionIntersect (entlast))
(if (/= RegionIntersect e2)
(progn
(setq RegionIntersect (entlast))
(command "area" "o" RegionIntersect)
(setq areaCurve (getvar "area"))
(entdel RegionIntersect)
(setq bool1 T)
)
)
;;面域交集
(if bool1
(setq bool (equal areaCurve areae))
)
)
)
bool
)
;;判断一个对象是否在封闭曲线内,返回T
;;Text在封闭曲线内，返回T
(defun textInClosedCurve (e CURVE / ANG ANG1 AREACURVE
AREAE BOOL BOOL1 CURVE1 E0 E1
E2 ENLIST P1 P2 P3 P4
POINT1 POINT2 PT REGIONINTERSECT TL
)
;;(setq en (car (entsel)))
(setq enlist (entget e))
(setq ang (LI_item 50 enlist))
(setq pt (LI_item 10 enlist))
(setq tl (textbox enlist))
(setq point1 (car tl))
(setq point2 (cadr tl))
(setq p1 (mapcar '+ pt point1))
(setq p2 (polar p1 ang (car point2)))
(setq ang1 (angle p1 (mapcar '+ p1 point2)))
(setq p3 (polar p1
(+ ang ang1)
(sqrt (+ (* (car point2) (car point2))
(* (cadr point2) (cadr point2))
)
)
)
)
(setq p4 (polar p1 (+ ang (/ pi 2.0)) (cadr point2)))
(if (and (LT:PT-INCURVE p1 CURVE)
(LT:PT-INCURVE p2 CURVE)
(LT:PT-INCURVE p3 CURVE)
(LT:PT-INCURVE p4 CURVE)
)
(progn
(command "_pline" p1 p2 p3 p4 "C")
(setq e0 (entlast))
(command "_region" e0 "")
(setq e1 (entlast))
(command "area" "o" e1)
(setq areae (getvar "area"))
(command "erase" e0 "")
;;面域
;;(setq CURVE (car (entsel)))
(command "copy" CURVE "" (list 0 0 0) (list 0 0 0))
(princ "\n面域")
(setq Curve1 (entlast))
(command "_region" Curve1 "")
(setq e2 (entlast))
;;面域
(command "intersect" e1 e2 "")
;;如果没有交集,原Curve会被删除???
(setq RegionIntersect (entlast))
(if (/= RegionIntersect e2)
(progn
(setq RegionIntersect (entlast))
(command "area" "o" RegionIntersect)
(setq areaCurve (getvar "area"))
(entdel RegionIntersect)
(setq bool1 T)
)
)
;;面域交集
(if bool1
(setq bool (equal areaCurve areae))
)
)
)
bool
)
;;Text在封闭曲线内，返回T
(VL-LOAD-COM)
(setq HOLDblipmo (getvar "blipmode"))
(setq HOLDcmdech (getvar "cmdecho"))
(setq DIMASSOC1 (getvar "DIMASSOC"))
(setvar "cmdecho" 0)
(setvar "blipmode" 0)
(setvar "DIMASSOC" 1)
(setq fdlayer (getvar "CLAYER"))
(vl-cmdf "layer" "make" "DIM" "Color" 3 "" "")
(defun getdata ()
(setq BaseSymbol (get_tile "Fuhao"))
(setq JBFD_GetScalStri (get_tile "Scal"))
(setq JBFD_ZoomStri (get_tile "Zoom1"))
)
(if (= JBFD_BaseNumber nil)
(setq JBFD_BaseNumber 65)
(setq JBFD_BaseNumber (1+ JBFD_BaseNumber))
)
(SETQ BaseSymbol (chr JBFD_BaseNumber))
(if (= JBFD_GetScalStri nil)
(setq JBFD_GetScalStri "2.5")
)
(if (= JBFD_ZoomStri nil)
(setq JBFD_ZoomStri "0")
)
(setq fname (vl-filename-mktemp nil nil ".dcl"))
(setq fn (open fname "w"))
(write-line "Fddcl : dialog{" fn)
(write-line "label="*黄明儒*局部放大命令:FD";" fn)
(write-line ":column{ " fn)
(write-line
" :edit_box{label="放大标识(F)";key="Fuhao";value="B";mnemonic="F";}"
fn
)
(write-line
" :edit_box{label="放大倍数(S)";key="Scal";value="2.0";mnemonic="S";} "
fn
)
(write-line
" :edit_box{label="视口选择(Z)";key="Zoom1";value="0";mnemonic="Z";} "
fn
)
(write-line
" :text{key="Scaltext";value="圆0,已知封闭曲线1,椭圆2,其余多边形";}"
fn
)
(write-line " }" fn)
(write-line " ok_only;" fn)
(write-line "}" fn)
(close fn)
(setq fn (open fname "r"))
(setq dclid (load_dialog fname))
(while
(or (eq (substr (setq lin (vl-string-right-trim
"" fn)"
(vl-string-left-trim "(write-line "" (read-line fn))
)
)
1
2
)
"//"
)
(eq (substr lin 1 (vl-string-search " " lin)) "")
(not (eq (substr lin (+ (vl-string-search " " lin) 1) 9)
" : dialog"
)
)
)
)
(new_dialog (substr lin 1 (vl-string-search " " lin)) dclid)
(set_tile "Fuhao" BaseSymbol)
(set_tile "Scal" JBFD_GetScalStri)
(set_tile "Zoom1" JBFD_ZoomStri)
(mode_tile "Scal" 2)
(Action_Tile "Fuhao" "(Setq BaseSymbol $$Value)")
(Action_Tile "Scal" "(Setq JBFD_GetScalStri $$Value)")
(Action_Tile "Zoom1" "(Setq JBFD_ZoomStri $$Value)")
(action_tile "accept" "(getdata)(done_dialog)")
(setq return# (start_dialog))
(unload_dialog dclid)
(close fn)
(vl-file-delete fname)
(setq JBFD_BaseNumber (ascii BaseSymbol))
(SETQ Scalreal (atof JBFD_GetScalStri))
(SETQ getZoom (abs (atoi JBFD_ZoomStri)))
(if (/= 1 getZoom)
(SETQ CP (GETPOINT "\n局部放大中心点: "))
)
(cond ((= 0 getZoom) (command "CIRCLE" CP pause))
((= 1 getZoom)
(while
(progn
(setq ent (car (entsel "\n拾取封闭曲线:")))
(cond
((null ent) nil)
((member (cdr (assoc 0 (entget ent)))
'("LINE" "ARC" "SPLINE" "LWPOLYLINE" "POLYLINE" "CIRCLE"
"ELLIPSE")
)
nil
)
(t
(prompt "\n*** 错误对象类型, 重试.")
t
)
)
)
)
)
((= 2 getZoom) (command "_ellipse" CP pause pause))
(T (command "_polygon" getZoom CP "I" pause))
)
(if (/= 1 getZoom)
(SETQ EntCicl (ENTLAST))
(SETQ EntCicl ent)
)
(setq En (vlax-ename->vla-object EntCicl))
(vla-getboundingbox En 'p1 'p2)
(setq p1 (vlax-safearray->list p1))
(setq p2 (vlax-safearray->list p2))
(setq CP (mapcar '(lambda (X) (/ x 2.0)) (mapcar '+ p1 p2)))
(command "Clayer" fdlayer)
;;取与圆相交的实体，块除外(选择集)
(setq ssObj (ssget "C"
p2
p1
'((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))
)
)
;;与圆相交的块(选择集)
(setq ssblocks (ssget "F" (Object-Plst EntCicl) '((0 . "INSERT,HATCH"))))
;;圆内物体(选择集)
(setq SSInCircle (ssget "WP"
(Object-Plst EntCicl)
'((0 . "*TEXT,DIMENSION,INSERT,HATCH"))
)
)
;;与圆相交实体拷贝集,有EntCicl则去除之
(setq ssObj (ss=>NewSS ssObj EntCicl))
;;与圆相交块拷贝集
(if ssblocks
(progn
(if (equal SSInCircle nil)
(setq SSInCircle (ssadd))
)
(setq ssObj (BlockS=>NewSS ssObj ssblocks EntCicl))
(setq SS_Bolck (cadr ssObj)) ;块集爆破后的产物，选择集
(setq ssObj (car ssObj))
)
)
;;与圆相交拷贝集打断后的新选择集
(setq ssObj (ssCircle1 ssObj EntCicl))
;;新选择集圆外对象删除
(setq ssObj (GetInCircleObjects ssObj EntCicl))
;;加入圆内对象,当EntCicl不在选择集中时加入
(if SSInCircle
(setq ssObj (SS_SSjoinENT ssObj SSInCircle EntCicl))
)
(setq ssObj (SS_SSjoin ssObj SS_Bolck))
;;加入块爆破后的产物
;;生成无名块
(setq Newblock (NONAME_BLK ssObj CP))
(setq Newblock (entlast))
;;字体高度Textheigh
(SETQ Textheigh (* (GETVAR "DIMTXT") (GETVAR "DIMSCALE")))
;;画引线
(HdrawLeader EntCicl BaseSymbol Textheigh CP)
(setq NewP (mapcar '+
(list 0 (+ (* Scalreal (- (cadr p2) (cadr CP))) Textheigh))
CP
)
)
(command "text"
"J"
"C"
NewP
Textheigh
""
(strcat BaseSymbol " 放大 " JBFD_GetScalStri "X")
)
(setq ent (entlast))
(command "_scale" Newblock "" CP Scalreal)
(command "move" Newblock ent "" CP pause)
(setvar "cmdecho" HOLDcmdech)
(setvar "blipmode" HOLDblipmo)
(setvar "DIMASSOC" DIMASSOC1)
(gc)
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;放大主程序

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;放大主程序 黄明儒 
;;全局JBFD_GetScalStri放大倍数（字符），JBFD_BaseNumber标识（数字）,JBFD_ZoomStri视口 
(defun C:FD (/                 BASESYMBOL BRKOBJLST  BRK_OBJ          CP             DCLID 
              DIMASSOC1         EN            ENT               ENTCICL          FDLAYER    FN 
              FNAME         GETZOOM    HOLDBLIPMO HOLDCMDECH IPLIST     LASTENT 
              LIN         LST1            LST2       MAXPARAM          MINPARAM   NEWBLOCK 
              NEWP         OBJ            OBJ2BREAK  P1          P1PARAM    P2 
              P2PARAM         PT            RETURN#    SCALREAL          SSBLOCKS   SSINCIRCLE 
              SSOBJ         SSOBJSALL  SS_BOLCK   TEXTHEIGH  X 
             ) 
 
  ;;下面函数返回所有对象,包括打断后的对象 
  (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 
  ) 
 
 
  ;;------------------------------------------ 
  ;;本函数得到圆内实体选择集(3dm_pl_region_GE_PtInPoly (gxl-Ax:GetMidpointCurve e) (Object-Plst ent) T) 
  ;;曲线中点在圆外，则在圆外 
  ;;allObjects选择集，ent圆 
  (defun GetInCircleObjects 
                            (allObjects ent / E N SSNEW) 
    (setq ssNew (ssadd)) 
    (setq n 0) 
    (repeat (sslength allObjects) 
      (setq e (ssname allObjects n)) 
      (if (3dm_pl_region_GE_PtInPoly (gxl-Ax:GetMidpointCurve e) 
                                     (Object-Plst ent) 
                                     T 
          ) 
        (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 CURVE SSInCircle / E ENT N SS1 BlockN LIS) 
    (command "copy" Block "" (list 0 0 0) (list 0 0 0)) 
    (setq BlockN (entlast)) 
    (command "explode" BlockN) 
    (setq ss1 (ssget "_P")) 
    (setq n 0) 
    (if        (equal SSInCircle nil) 
      (setq SSInCircle (ssadd)) 
    ) 
    (repeat (sslength ss1) 
      (setq e (ssname ss1 n)) 
      (setq ent (LI_item 0 (entget e))) 
      (cond 
        ((eInClosedCurve e CURVE) 
         (setq SSInCircle (ssadd e SSInCircle)) 
        ) 
        ((wcmatch ent "*LINE,ARC,CIRCLE,ELLIPSE") 
         (setq SS (ssadd e SS)) 
        ) 
        ((wcmatch ent "INSERT,HATCH,DIMENSION") 
         (progn        (setq lis (Block=>NewSS SS e CURVE SSInCircle)) 
                (setq SSInCircle (cadr lis)) 
                (setq ss (car lis)) 
                (entdel e) 
         ) 
        ) 
        ((AND (wcmatch ent "TEXT") (textInClosedCurve e CURVE)) 
         (setq SSInCircle (ssadd e SSInCircle)) 
        ) 
        (T (entdel e)) 
      ) 
      (setq n (1+ n)) 
    ) 
    (LIST ss SSInCircle) 
  ) 
  ;;Copy块,其成员加入原选择集构成新选择集 
 
 
  ;;块集各成员加入SS选择集 
  (defun BlockS=>NewSS (SS BlockS CURVE / BLOCK N LIS SSInCircle) 
    (setq n 0) 
    (setq SSInCircle (ssadd)) 
    (repeat (sslength BlockS) 
      (setq Block (ssname BlockS n)) 
      (setq LIS (Block=>NewSS SS Block CURVE SSInCircle)) 
      (setq SS               (car LIS) 
            SSInCircle (cadr LIS) 
      ) 
      (setq n (1+ n)) 
    ) 
    LIS 
  ) 
  ;;块集各成员加入SS选择集 
 
 
  ;;生成无名块 
  (defun NONAME_BLK (SS PointCircl / A BLKREF) 
    (setq A (rtos (* (getvar "CDATE") 1E8))) 
    (if        (/= SS NIL) 
      (progn 
        (command "_.BLOCK" A PointCircl SS "") 
        (command "_.INSERT" A "@" "" "" "") 
        ;|(setq BLKREF (vlax-ename->vla-object (entlast))) 
        (vla-put-name 
          (vla-item (vla-get-blocks 
                      (vla-get-activedocument (vlax-get-acad-object)) 
                    ) 
                    (vla-get-name BLKREF) 
          ) 
          "*U" 
        ) 
        (vlax-release-object BLKREF)|; 
      ) 
    ) 
  ) 
  ;;生成无名块 
 
  ;;选择集合并 
  (defun SS_SSjoinENT (ss1 ss2 EntCicl / BOOL EN EN1 N) 
    ;;如果ss1中没有圆EntCicl,则加入之 
    (setq n 0) 
    (repeat (sslength ss1) 
      (setq en (ssname ss1 n)) 
      (if (= en EntCicl) 
        (setq bool T) 
      ) 
    ) 
    (if        bool 
      nil 
      (progn (command "copy" EntCicl "" (list 0 0 0) (list 0 0 0)) 
             (setq en1 (entlast)) 
             (setq ss1 (ssadd en1 ss1)) 
      ) 
    ) 
    (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 Object-Plst (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 (
      (setq plst (append 
                   plst 
                   (list (vlax-curve-getPointAtParam lineObj 
                                                     (*        i 
                                                        (/ 
                                                          (- end start) 
                                                          num 
                                                        ) 
                                                     ) 
                         ) 
 
                   ) 
                 ) 
            i         (1+ i) 
      ) 
    ) 
    plst 
  ) 
  ;;选择对象 
 
 
  ;|(setq EntCicl (car (entsel))) 
(setq BaseSymbol "A") 
(setq entText (car (entsel)))|; 
  ;;画引线 
  (defun HdrawLeader (EntCicl BaseSymbol      Textheigh              CP      / 
                      A              AA      B              BB      C              CC      D 
                      DD      EE      FF      I              TEXTLIS ENTTEXT ola 
                     ) 
    (vl-load-com) 
    (command "text" CP Textheigh "" BaseSymbol) 
    (setq entText (entlast)) 
 
    (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) 
    (entdel entText) 
                                                            ;(setvar "DIMLDRBLK" "DotSmall") 
    (setq ola (getvar "clayer")) 
    (vl-cmdf "layer" "make" "DIM" "Color" 3 "" "") 
    (command "leader" d (cadr a) "" BaseSymbol "") 
    (setvar "clayer" ola) 
                                                            ;(setvar "DIMLDRBLK" ".") 
                                                            ;(vl-cmdf "leader" d (cadr a) "f" "st" "f" "a" "" BaseSymbol "") 
                                                            ;(setq leaderobj (vlax-ename->vla-object (entlast))) 
                                                            ;(vla-put-ArrowheadType leaderobj acArrowDotSmall) 
                                                            ;(vla-Update leaderobj) 
  ) 
  ;;画引线 
 
  (defun onlockedlayer (ename / entlst) 
    (setq entlst (tblsearch "LAYER" (cdr (assoc 8 (entget ename))))) 
    (= 4 (logand 4 (cdr (assoc 70 entlst)))) 
  ) 
 
  ;;点在曲线内外,caoyin 
  ;;  T------->在曲线内 
  (defun LT:PT-INCURVE (PT CURVE / GetInters OBJ MINPT MAXPT E PS LST X Y) 
    (defun GetInters (OBJ1 OBJ2 / PS LST) 
      (setq PS (vla-intersectwith OBJ1 OBJ2 0) 
            PS (vl-catch-all-apply 'vlax-safearray->list 
                                   (list (vlax-variant-value PS)) 
               ) 
      ) 
      (if (and PS (not (vl-catch-all-error-p PS))) 
        (while (setq LST (cons (list (car PS) (cadr PS)) LST) 
                     PS         (cdddr PS) 
               ) 
        ) 
      ) 
      LST 
    ) 
    (if        (equal (vlax-curve-getClosestPointTo CURVE PT) PT 1E-6) 
      0 
      (progn 
        (setq OBJ (vlax-ename->vla-object CURVE)) 
        (vla-getboundingbox OBJ 'MINPT 'MAXPT) 
        (mapcar        '(lambda (X) (set X (vlax-safearray->list (eval X)))) 
                '(MINPT MAXPT) 
        ) 
        (entmake (list '(0 . "LINE") 
                       (list 10 (car MINPT) (cadr PT)) 
                       (list 11 (car MAXPT) (cadr PT)) 
                       '(60 . 1) 
                 ) 
        ) 
        (setq E           (entlast) 
              LST1 (GetInters OBJ (vlax-ename->vla-object E)) 
        ) 
        (entdel E) 
        (if LST1 
          (setq        LST1 (vl-remove-if 
                       '(lambda        (X / PP A) 
                          (setq        PP (vlax-curve-getParamAtPoint CURVE X) 
                                A  (angle '(0 0) 
                                          (vlax-curve-getFirstDeriv CURVE PP) 
                                   ) 
                          ) 
                          (or (equal A 0 1E-6) 
                              (equal A PI 1E-6) 
                              (equal A (* PI 2) 1E-6) 
                              (equal (fix PP) PP 1E-6) 
                          ) 
                        ) 
                       LST1 
                     ) 
          ) 
        ) 
        (entmake (list '(0 . "LINE") 
                       (list 10 (car PT) (cadr MAXPT)) 
                       (list 11 (car PT) (cadr MINPT)) 
                       '(60 . 0) 
                 ) 
        ) 
        (setq E           (entlast) 
              LST2 (GetInters OBJ (vlax-ename->vla-object E)) 
        ) 
        (entdel E) 
        (if LST2 
          (setq        LST2 (vl-remove-if 
                       '(lambda        (X / PP A) 
                          (setq        X  (vlax-curve-getClosestPointTo CURVE X) 
                                PP (vlax-curve-getParamAtPoint CURVE X) 
                                A  (angle (vlax-curve-getFirstDeriv CURVE PP) 
                                          '(0 0) 
                                   ) 
                          ) 
                          (or (equal A (/ PI 2) 1E-6) 
                              (equal A (* PI 1.5) 1E-6) 
                              (equal (fix PP) PP 1E-6) 
                          ) 
                        ) 
                       LST2 
                     ) 
          ) 
        ) 
        (and LST1 
             LST2 
             (progn 
               (setq X (vl-sort-i (mapcar 'car (cons PT LST1)) '<) 
                     Y (length (member 0 X)) 
               ) 
               (and (zerop (rem Y 2)) (= (rem (- (length X) Y) 2) 1)) 
             ) 
             (progn 
               (setq X (vl-sort-i (mapcar 'cadr (cons PT LST2)) '<) 
                     Y (length (member 0 X)) 
               ) 
               (and (zerop (rem Y 2)) (= (rem (- (length X) Y) 2) 1)) 
             ) 
        ) 
      ) 
    ) 
  ) 
  ;;点在曲线内外,caoyin 
 
  ;;************************************************************************************* 
  ;; ! Argument : 'pt'    - point ot be tested 
  ;; !            'vlist' - List of points forming the polgon 
  ;; !            'flag'  - If 'T', point on the line is inside else outside 
  (defun 3dm_pl_region_GE_PtInPoly (pt           vlist  flag         /        NumInts              diff 
                                    cnt           online p1         p1code        p1x    p1y    p2 
                                    p2code p2x          p2y         ttl        x      xdiff  xx 
                                    y           ydiff  Idx         len 
                                   ) 
    (if        (not (equal (car vlist) (last vlist))) 
      (setq vlist (append 
                    vlist 
                    (list (car vlist)) 
                  ) 
      ) 
    ) 
    (setq X          (car pt) 
          Y          (cadr pt) 
          len          (length vlist) 
          cnt          0 
          Idx          0 
          NumInts 0 
          OnLine  nil 
    ) 
    (while (and 
             (not OnLine) 
             (< cnt len) 
           ) 
      (setq p2           (nth cnt vlist) 
            p2x           (car p2) 
            p2y           (cadr p2) 
            p2code (if (>= p2y y) 
                     2 
                     0 
                   ) 
            p2code (if (>= p2x x) 
                     (1+ p2code) 
                     p2code 
                   ) 
      ) 
      (if p1 
        (setq diff  (boole 6 p1code p2code) 
              ydiff (boole 1 diff 2) 
              xdiff (boole 1 diff 1) 
              p1x   (car p1) 
              p1y   (cadr p1) 
        ) 
      ) 
      (if (= ydiff 2) 
        (progn 
          (setq xx (+ p1x (* (/ (- p2x p1x) 1. (- p2y p1y)) (- y p1y)))) 
          (cond 
            ((equal xx x 0.0001) 
             (setq online T) 
            ) 
            ((> xx x) 
             (setq NumInts (1+ NumInts)) 
            ) 
          ) 
        ) 
      ) 
      (if (and 
            (= xdiff 1) 
            (= y p1y p2y) 
          ) 
        (setq OnLine T) 
      ) 
      (setq p1code p2code 
            p1           p2 
            cnt           (1+ cnt) 
      ) 
    ) 
    (if        Online 
      flag 
      (= (boole 1 NumInts 1) 0001) 
    ) 
  ) 
  ;;************************************************************** 
 
 
  ;; | ---------------------------------------------------------------------------- 
  ;; | SS_SSjoin 
  ;; | ---------------------------------------------------------------------------- 
  ;; | Function : Joins two selections set and returns their sum 
  ;; | Arguments: 
  ;; |            'ss1'    - First Selection set (overloaded - can be entity 
  ;; |                       name as well) 
  ;; |            'ss2'    - Second Selection set (overloaded - can be entity 
  ;; |                       name as well) 
  ;; | Return   : The difference selection set 
  ;; | Updated  : April 24, 1998 
  ;; | e-mail   : rakesh.rao@4d-technologies.com 
  ;; | Web      : www.4d-technologies.com 
  ;; | ---------------------------------------------------------------------------- 
  (defun SS_SSjoin (ss1 ss2 / ename ss cnt) 
    (if        ss1 
      (progn 
        (if (= (type ss1) 'ENAME) 
          (progn 
            (setq 
              ename ss1 
              ss1   (ssadd) 
            ) 
            (ssadd ename ss1) 
          ) 
        ) 
      ) 
    ) 
 
    (if        ss2 
      (progn 
        (if (= (type ss2) 'ENAME) 
          (progn 
            (setq 
              ename ss2 
              ss2   (ssadd) 
            ) 
            (ssadd ename ss2) 
          ) 
        ) 
      ) 
    ) 
 
    (setq ss (ssadd)) 
 
    (if        (and ss1 ss2) 
      (progn 
        (setq ss  ss2 
              cnt 0 
        ) 
        (repeat        (sslength ss1) 
          (ssadd (ssname ss1 cnt) ss) 
          (setq cnt (1+ cnt)) 
        ) 
      ) 
    ) 
 
    (if        (and ss1 (not ss2)) 
      (setq ss ss1) 
    ) 
 
    (if        (and ss2 (not ss1)) 
      (setq ss ss2) 
    ) 
 
    (if        (> (sslength ss) 0) 
      (eval ss) 
      nil 
    ) 
  ) 
  ;;选择集合并 
 
  ;;判断一个对象是否在封闭曲线内,返回T 
  ;;(eInClosedCurve (car (entsel)) (car (entsel))) 
  ;;(textInClosedCurve (car (entsel)) (car (entsel))) 
  (defun eInClosedCurve        (e          Curve           /            AREACURVE              AREAE 
                         BOOL          BOOL1           CURVE1   E0             E1              E2 
                         EN          P1           P2            P3             P4              REGIONINTERSECT 
                        ) 
                                                            ;(setq e (car (entsel)) Curve (car (entsel))) 
    (vl-load-com) 
    ;;先判断4个顶点是否在封闭曲线内 
    (setq en (vlax-ename->vla-object e)) 
    (vla-getboundingbox en 'p1 'p3) 
    (setq p1 (vlax-safearray->list p1)) 
    (setq p3 (vlax-safearray->list p3)) 
    (setq p2 (list (car p3) (cadr p1))) 
    (setq p4 (list (car p1) (cadr p3))) 
    (if        (and (LT:PT-INCURVE p1 CURVE) 
             (LT:PT-INCURVE p2 CURVE) 
             (LT:PT-INCURVE p3 CURVE) 
             (LT:PT-INCURVE p4 CURVE) 
        ) 
      (progn 
        (command "_rectang" p1 p3) 
        (setq e0 (entlast)) 
        (command "_region" e0 "") 
        (setq e1 (entlast)) 
        (command "area" "o" e1) 
        (setq areae (getvar "area")) 
        (command "erase" e0 "") 
        ;;面域 
        (command "copy" Curve "" (list 0 0 0) (list 0 0 0)) 
        (setq Curve1 (entlast)) 
        (command "_region" Curve1 "") 
        (setq e2 (entlast)) 
        ;;面域 
        (command "intersect" e1 e2 "") 
        ;;如果没有交集,原Curve会被删除??? 
        (setq RegionIntersect (entlast)) 
        (if (/= RegionIntersect e2) 
          (progn 
            (setq RegionIntersect (entlast)) 
            (command "area" "o" RegionIntersect) 
            (setq areaCurve (getvar "area")) 
            (entdel RegionIntersect) 
            (setq bool1 T) 
          ) 
        ) 
        ;;面域交集 
        (if bool1 
          (setq bool (equal areaCurve areae)) 
        ) 
 
      ) 
    ) 
    bool 
  ) 
  ;;判断一个对象是否在封闭曲线内,返回T 
 
  ;;Text在封闭曲线内，返回T 
  (defun textInClosedCurve (e             CURVE    /               ANG        ANG1         AREACURVE 
                            AREAE    BOOL     BOOL1    CURVE1        E0         E1 
                            E2             ENLIST   P1       P2        P3         P4 
                            POINT1   POINT2   PT       REGIONINTERSECT         TL 
                           ) 
    ;;(setq en (car (entsel))) 
    (setq enlist (entget e)) 
    (setq ang (LI_item 50 enlist)) 
    (setq pt (LI_item 10 enlist)) 
    (setq tl (textbox enlist)) 
    (setq point1 (car tl)) 
    (setq point2 (cadr tl)) 
    (setq p1 (mapcar '+ pt point1)) 
    (setq p2 (polar p1 ang (car point2))) 
    (setq ang1 (angle p1 (mapcar '+ p1 point2))) 
    (setq p3 (polar p1 
                    (+ ang ang1) 
                    (sqrt (+ (* (car point2) (car point2)) 
                             (* (cadr point2) (cadr point2)) 
                          ) 
                    ) 
             ) 
    ) 
    (setq p4 (polar p1 (+ ang (/ pi 2.0)) (cadr point2))) 
    (if        (and (LT:PT-INCURVE p1 CURVE) 
             (LT:PT-INCURVE p2 CURVE) 
             (LT:PT-INCURVE p3 CURVE) 
             (LT:PT-INCURVE p4 CURVE) 
        ) 
      (progn 
        (command "_pline" p1 p2 p3 p4 "C") 
        (setq e0 (entlast)) 
        (command "_region" e0 "") 
        (setq e1 (entlast)) 
        (command "area" "o" e1) 
        (setq areae (getvar "area")) 
        (command "erase" e0 "") 
        ;;面域 
        ;;(setq CURVE (car (entsel))) 
        (command "copy" CURVE "" (list 0 0 0) (list 0 0 0)) 
        (princ "\n面域") 
        (setq Curve1 (entlast)) 
        (command "_region" Curve1 "") 
        (setq e2 (entlast)) 
        ;;面域 
        (command "intersect" e1 e2 "") 
        ;;如果没有交集,原Curve会被删除??? 
        (setq RegionIntersect (entlast)) 
        (if (/= RegionIntersect e2) 
          (progn 
            (setq RegionIntersect (entlast)) 
            (command "area" "o" RegionIntersect) 
            (setq areaCurve (getvar "area")) 
            (entdel RegionIntersect) 
            (setq bool1 T) 
          ) 
        ) 
        ;;面域交集 
        (if bool1 
          (setq bool (equal areaCurve areae)) 
        ) 
 
      ) 
    ) 
    bool 
  ) 
  ;;Text在封闭曲线内，返回T 
 
 
  (VL-LOAD-COM) 
  (setq HOLDblipmo (getvar "blipmode")) 
  (setq HOLDcmdech (getvar "cmdecho")) 
  (setq DIMASSOC1 (getvar "DIMASSOC")) 
 
  (setvar "cmdecho" 0) 
  (setvar "blipmode" 0) 
  (setvar "DIMASSOC" 1) 
  (setq fdlayer (getvar "CLAYER")) 
  (vl-cmdf "layer" "make" "DIM" "Color" 3 "" "") 
 
  (defun getdata () 
    (setq BaseSymbol (get_tile "Fuhao")) 
    (setq JBFD_GetScalStri (get_tile "Scal")) 
    (setq JBFD_ZoomStri (get_tile "Zoom1")) 
  ) 
 
  (if (= JBFD_BaseNumber nil) 
    (setq JBFD_BaseNumber 65) 
    (setq JBFD_BaseNumber (1+ JBFD_BaseNumber)) 
  ) 
  (SETQ BaseSymbol (chr JBFD_BaseNumber)) 
 
  (if (= JBFD_GetScalStri nil) 
    (setq JBFD_GetScalStri "2.5") 
  ) 
  (if (= JBFD_ZoomStri nil) 
    (setq JBFD_ZoomStri "0") 
  ) 
 
 
  (setq fname (vl-filename-mktemp nil nil ".dcl")) 
  (setq fn (open fname "w")) 
  (write-line "Fddcl : dialog{" fn) 
  (write-line "label="*黄明儒*局部放大 命令:FD";" fn) 
  (write-line ":column{        " fn) 
  (write-line 
    "        :edit_box{label="放大标识(F)";key="Fuhao";value="B";mnemonic="F";}" 
    fn 
  ) 
  (write-line 
    "        :edit_box{label="放大倍数(S)";key="Scal";value="2.0";mnemonic="S";} " 
    fn 
  ) 
  (write-line 
    "        :edit_box{label="视口选择(Z)";key="Zoom1";value="0";mnemonic="Z";} " 
    fn 
  ) 
  (write-line 
    "        :text{key="Scaltext";value="圆0,已知封闭曲线1,椭圆2,其余多边形";}" 
    fn 
  ) 
  (write-line "       }" fn) 
  (write-line "       ok_only;" fn) 
  (write-line "}" fn) 
 
  (close fn) 
  (setq fn (open fname "r")) 
  (setq dclid (load_dialog fname)) 
  (while 
    (or        (eq (substr (setq lin (vl-string-right-trim 
                                "" fn)" 
                                (vl-string-left-trim "(write-line "" (read-line fn)) 
                              ) 
                    ) 
                    1 
                    2 
            ) 
            "//" 
        ) 
        (eq (substr lin 1 (vl-string-search " " lin)) "") 
        (not (eq (substr lin (+ (vl-string-search " " lin) 1) 9) 
                 " : dialog" 
             ) 
        ) 
    ) 
  ) 
  (new_dialog (substr lin 1 (vl-string-search " " lin)) dclid) 
  (set_tile "Fuhao" BaseSymbol) 
  (set_tile "Scal" JBFD_GetScalStri) 
  (set_tile "Zoom1" JBFD_ZoomStri) 
  (mode_tile "Scal" 2) 
  (Action_Tile "Fuhao" "(Setq BaseSymbol $$Value)") 
  (Action_Tile "Scal" "(Setq JBFD_GetScalStri $$Value)") 
  (Action_Tile "Zoom1" "(Setq JBFD_ZoomStri $$Value)") 
  (action_tile "accept" "(getdata)(done_dialog)") 
  (setq return# (start_dialog)) 
  (unload_dialog dclid) 
  (close fn) 
  (vl-file-delete fname) 
 
  (setq JBFD_BaseNumber (ascii BaseSymbol)) 
  (SETQ Scalreal (atof JBFD_GetScalStri)) 
  (SETQ getZoom (abs (atoi JBFD_ZoomStri))) 
 
 
  (if (/= 1 getZoom) 
    (SETQ CP (GETPOINT "\n局部放大中心点: ")) 
  ) 
  (cond        ((= 0 getZoom) (command "CIRCLE" CP pause)) 
        ((= 1 getZoom) 
         (while 
           (progn 
             (setq ent (car (entsel "\n拾取封闭曲线:"))) 
             (cond 
               ((null ent) nil) 
               ((member        (cdr (assoc 0 (entget ent))) 
                        '("LINE" "ARC" "SPLINE"        "LWPOLYLINE" "POLYLINE"        "CIRCLE" 
                          "ELLIPSE") 
                ) 
                nil 
               ) 
               (t 
                (prompt "\n*** 错误对象类型, 重试.") 
                t 
               ) 
             ) 
           ) 
         ) 
        ) 
        ((= 2 getZoom) (command "_ellipse" CP pause pause)) 
        (T (command "_polygon" getZoom CP "I" pause)) 
  ) 
  (if (/= 1 getZoom) 
    (SETQ EntCicl (ENTLAST)) 
    (SETQ EntCicl ent) 
  ) 
  (setq En (vlax-ename->vla-object EntCicl)) 
  (vla-getboundingbox En 'p1 'p2) 
  (setq p1 (vlax-safearray->list p1)) 
  (setq p2 (vlax-safearray->list p2)) 
  (setq CP (mapcar '(lambda (X) (/ x 2.0)) (mapcar '+ p1 p2))) 
  (command "Clayer" fdlayer) 
 
 
  ;;取与圆相交的实体，块除外(选择集) 
  (setq        ssObj (ssget "C" 
                     p2 
                     p1 
                     '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")) 
              ) 
  ) 
  ;;与圆相交的块(选择集) 
  (setq ssblocks (ssget "F" (Object-Plst EntCicl) '((0 . "INSERT,HATCH")))) 
  ;;圆内物体(选择集) 
  (setq        SSInCircle (ssget "WP" 
                          (Object-Plst EntCicl) 
                          '((0 . "*TEXT,DIMENSION,INSERT,HATCH")) 
                   ) 
  ) 
 
  ;;与圆相交实体拷贝集,有EntCicl则去除之 
  (setq ssObj (ss=>NewSS ssObj EntCicl)) 
  ;;与圆相交块拷贝集 
  (if ssblocks 
    (progn 
      (if (equal SSInCircle nil) 
        (setq SSInCircle (ssadd)) 
      ) 
      (setq ssObj (BlockS=>NewSS ssObj ssblocks EntCicl)) 
      (setq SS_Bolck (cadr ssObj))                            ;块集爆破后的产物，选择集 
      (setq ssObj (car ssObj)) 
    ) 
  ) 
  ;;与圆相交拷贝集打断后的新选择集   
  (setq ssObj (ssCircle1 ssObj EntCicl)) 
 
  ;;新选择集圆外对象删除 
  (setq ssObj (GetInCircleObjects ssObj EntCicl)) 
  ;;加入圆内对象,当EntCicl不在选择集中时加入 
  (if SSInCircle 
    (setq ssObj (SS_SSjoinENT ssObj SSInCircle EntCicl)) 
  ) 
  (setq ssObj (SS_SSjoin ssObj SS_Bolck)) 
  ;;加入块爆破后的产物 
  ;;生成无名块 
  (setq Newblock (NONAME_BLK ssObj CP)) 
  (setq Newblock (entlast)) 
 
  ;;字体高度Textheigh 
  (SETQ Textheigh (* (GETVAR "DIMTXT") (GETVAR "DIMSCALE"))) 
 
  ;;画引线 
  (HdrawLeader EntCicl BaseSymbol Textheigh CP) 
  (setq        NewP (mapcar '+ 
                     (list 0 (+ (* Scalreal (- (cadr p2) (cadr CP))) Textheigh)) 
                     CP 
             ) 
  ) 
  (command "text" 
           "J" 
           "C" 
           NewP 
           Textheigh 
           "" 
           (strcat BaseSymbol " 放大 " JBFD_GetScalStri "X") 
  ) 
  (setq ent (entlast)) 
 
  (command "_scale" Newblock "" CP Scalreal) 
  (command "move" Newblock ent "" CP pause) 
 
 
  (setvar "cmdecho" HOLDcmdech) 
  (setvar "blipmode" HOLDblipmo) 
  (setvar "DIMASSOC" DIMASSOC1) 
  (gc) 
  (princ) 
) 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;放大主程序

ycao · 发表于 2013-6-2 20:09:23

/db_自贡黄明儒_ 发表于 2013-5-23 13:24
既然aeo版主有兴趣,我贴出我写的代码,当时有感于小金鱼的要注册,所以自己写了一个,一直希望哪位高手完善 ...

缺少LI_ITEM函数。

/db_自贡黄明儒_ · 发表于 2013-6-3 08:14:01

ycao 发表于 2013-6-2 20:09
缺少LI_ITEM函数。

(Defun LI_item (N E) (CDR (Assoc N E)))

金鹅起飞 · 发表于 2013-9-20 08:41:37

/db_自贡黄明儒_
您好！您的放大程序源码很好，很厉害。向您致敬！我试用后觉得如果此程序能够具有如下功能就更好了：
1、标注比例保持不变，而且标注也要存在于放大的图中；
2、字体太少，输入放大比例后出现乱码。

账号		自动登录	找回密码
密码			立即注册

[原创]：一个局部放大程序

点评

点评

点评

点评

评分

点评