TA的每日心情 | 开心
4 天前 |
|---|
签到天数: 49 天 [LV.5]常住居民I
管理员
- 积分
- 1695
|
(defun c:gb ;局部放大v1.3.7
(/ dcl_id Action_Keys fy_fangda get_entcen sel_gbbak keylst col err R_ini)
(vl-load-com)
(defun fy_fangda ;主程序
(/ ent ent2 ent3 pt0 pt1 ss ss1 dis lst1 lst2 p1 obj i a b c txt1 line1 txt2 fontH DtL qm sc blk vla_lst sslst sc2 Arr doc mspace style layer col dim
sslst ss1 ss2 ss3 remss pt2 rec)
(setq doc (vla-get-activedocument (vlax-get-acad-object)))
(if (and (= (getvar "tilemode") 0) (= (getvar "cvport") 1))
(setq mspace (vla-get-paperspace doc))
(setq mspace (vla-get-modelspace doc))
)
(if (not (tblobjname "ltype" "HIDDEN")) ;先加载线型
(vlax-invoke-method (vla-get-Linetypes (vla-get-activedocument (vlax-get-acad-object))) 'Load "HIDDEN" "acadiso.lin")
)
(setq layer (nth (atoi lay_gbbak) (fy_tbl "LAYER"))) ;图层
(if (not layer) (setq layer (getvar "CLAYER")))
(fy_ErrorInit (list "cmdecho" 0 "CELTYPE" "HIDDEN" "dimzin" 8 "qaflags" 0 "pickfirst" 1 "CLAYER" layer "CELTSCALE" (/ 5 (getvar "LTSCALE"))) 1 '(redraw))
((if command-s command-s vl-cmdf) "._ucs" "")
(fy_layerSave "#fyLayerSave" nil) ;保存图层状态
(fy_UnLockLayer) ;解锁所有图层
(if sel_gbbak
(progn
(setq ent (fy_entsel "\n请选择一个封闭区域(圆/椭圆/封闭多段线):" nil '((0 . "CIRCLE,LWPOLYLINE,ELLIPSE")) "\n所选对象不符合要求！请重新选择:"))
(if ent (setq ent (car ent)))
)
(cond ;画放大区域
((= b1_gbbak "1") ;圆形
(setq p1 (fy_GetPt "\n->请指定放大中心点:"))
(or p1 (exit))
(setq ent (fy_makecircle p1 0.1) i T)
(or ent (exit))
(while i
(setq a (grread T 12 12) b (car a) a (trans (cadr a) 1 0))
(cond
((= b 5)
(fy_PutDxf ent 40 (distance p1 a))
(redraw)
(grdraw p1 a 7 1)
)
((= b 3) (setq i nil)) ;左键结束while
)
)
(redraw)
)
((= b2_gbbak "1") ;椭圆
(princ "\n->请画椭圆放大区域:")
(setq ent (entlast))
(vl-cmdf "_ELLIPSE")
(while (= (getvar "cmdactive") 1) (vl-cmdf pause))
(setq ent (car (fy_EntNextAll ent)))
(cond
((not ent)
(princ "\n椭圆没绘制完成！")
(exit)
)
)
)
((= b3_gbbak "1") ;矩形
(cond ((= t9_gbbak "1") ;改矩形圆角
(vl-catch-all-apply (function (lambda (/ ent0)
(setq ent0 (entlast))
(vl-cmdf "_RECTANG" "_F" ed3_gbbak "_non" "0,0" "_non" "0,0")
(setq ent0 (fy_sslast ent0))
(if ent0 (entdel (ssname ent0 0)))
)))
))
(princ "\n->请画矩形放大区域:")
(setq ent (entlast))
(vl-cmdf "_RECTANG" "_non" pause "_non" pause)
(setq ent (car (fy_EntNextAll ent)))
(cond
((not ent)
(princ "\n矩形没绘制完成！")
(exit)
)
)
(vl-catch-all-apply (function (lambda() (vl-cmdf "_RECTANG" "_F" 0 "_non" "0,0" "_non" "0,0"))))
(entdel (entlast))
)
((= b4_gbbak "1") ;多边形
(setq ent (entlast))
(vl-cmdf "_polygon" ed4_gbbak)
(princ "\n->请画多边形放大区域:")
(vl-cmdf "_non" pause "_C" "_non" pause)
(setq ent (car (fy_EntNextAll ent)))
(cond
((not ent)
(princ "\n多边形没绘制完成！")
(exit)
)
)
)
((= b5_gbbak "1") ;云线还没绘制成封闭时按右键有问题
(setq ent (entlast))
(vl-cmdf "_revcloud" "A" ed5_gbbak "")
(princ "\n->画云线,指定起点(画云线过程中不要按右键，不要画成自交曲线):")
(vl-cmdf pause)
(princ "\n->沿云线路径引导十字光标(别按右键、空格、回车):")
(while (= (getvar "cmdactive") 1) (vl-cmdf pause)) ;云线每画一段就会结束,所以要用while
(setq ent (car (fy_EntNextAll ent)))
(cond
((and ent (= (vla-get-closed (fy_envla ent)) :vlax-false))
(princ "\n云线没封闭！")
(exit)
)
((not ent)
(princ "\n云线没绘制完成！")
(exit)
)
)
)
)
)
(or ent (exit))
(if (= ed1_gbbak "") (setq ed1_gbbak "A")) ;视图名称
(if (= ed2_gbbak "") (setq ed2_gbbak "2")) ;放大倍数
(if (= ed3_gbbak "") (setq ed3_gbbak "0")) ;矩形圆角
(if (= ed4_gbbak "") (setq ed4_gbbak "8")) ;多边形边数
(if (= ed5_gbbak "") (setq ed5_gbbak "10")) ;云线弧长
(if (= ed7_gbbak "") (setq ed7_gbbak "100")) ;裁剪精度(段数)
(if (= ed9_gbbak "") (setq ed9_gbbak (vl-princ-to-string (fy_NumStr (getvar "TEXTSIZE"))))) ;视图文本高度
(if (= ed6_gbbak "") (setq ed6_gbbak (vl-princ-to-string (fy_NumStr (getvar "DIMTXT"))))) ;引线文字高度
(if (= ed8_gbbak "") (setq ed8_gbbak (vl-princ-to-string (fy_NumStr (getvar "DIMASZ"))))) ;引线箭头大小
(if (= ed10_gbbak "") (setq ed10_gbbak (vl-princ-to-string (fy_NumStr (getvar "DIMSCALE"))))) ;引线全局比例
(setq Arr (atoi arr_gbbak)) ;箭头类型
(setq style (nth (atoi Tstyle_gbbak) (vl-remove "" (fy_tbl "STYLE")))) ;文字样式
(setq col coltxt_gbbak) ;颜色
(setq dim (nth (atoi Dstyle_gbbak) (fy_tbl "DIMSTYLE"))) ;标注样式
(cond
((and(= t1_gbbak "1")(= t2_gbbak "1")(= t3_gbbak "1"))
(setq lst1 '((0 . "~HATCH")(0 . "~*DIMENSION")(0 . "~*TEXT")(0 . "~LEADER")(0 . "~ATTDEF")(0 . "~VIEWPORT")))
(setq lst2 '("INSERT" "WIPEOUT" "REGION" "MLINE"))
)
((and(= t1_gbbak "0")(= t2_gbbak "0")(= t3_gbbak "0"))
(setq lst1 '((0 . "~ATTDEF")(0 . "~VIEWPORT")))
(cond
((and(= t4_gbbak "1")(= t5_gbbak "1"))
(setq lst2 '("HATCH" "INSERT" "WIPEOUT" "REGION" "DIMENSION" "LEADER" "ARC_DIMENSION" "LARGE_RADIAL_DIMENSION" "MLINE"))
)
((and(= t4_gbbak "0")(= t5_gbbak "1"))
(setq lst2 '("HATCH" "INSERT" "WIPEOUT" "REGION" "MLINE"))
)
((and(= t4_gbbak "1")(= t5_gbbak "0"))
(setq lst2 '("INSERT" "WIPEOUT" "REGION" "DIMENSION" "LEADER" "ARC_DIMENSION" "LARGE_RADIAL_DIMENSION" "MLINE"))
)
((and(= t4_gbbak "0")(= t5_gbbak "0"))
(setq lst2 '("INSERT" "WIPEOUT" "REGION" "MLINE"))
)
)
)
((and(= t1_gbbak "0")(= t2_gbbak "1")(= t3_gbbak "1"))
(setq lst1 '((0 . "~HATCH")(0 . "~*DIMENSION")(0 . "~LEADER")(0 . "~ATTDEF")(0 . "~VIEWPORT")))
(setq lst2 '("INSERT" "WIPEOUT" "REGION" "MLINE"))
)
((and(= t1_gbbak "1")(= t2_gbbak "0")(= t3_gbbak "0"))
(setq lst1 '((0 . "~*TEXT")(0 . "~ATTDEF")(0 . "~VIEWPORT")))
(cond
((and(= t4_gbbak "1")(= t5_gbbak "1"))
(setq lst2 '("HATCH" "INSERT" "WIPEOUT" "REGION" "DIMENSION" "LEADER" "ARC_DIMENSION" "LARGE_RADIAL_DIMENSION" "MLINE"))
)
((and(= t4_gbbak "0")(= t5_gbbak "1"))
(setq lst2 '("HATCH" "INSERT" "WIPEOUT" "REGION" "MLINE"))
)
((and(= t4_gbbak "1")(= t5_gbbak "0"))
(setq lst2 '("INSERT" "WIPEOUT" "REGION" "DIMENSION" "LEADER" "ARC_DIMENSION" "LARGE_RADIAL_DIMENSION" "MLINE"))
)
((and(= t4_gbbak "0")(= t5_gbbak "0"))
(setq lst2 '("INSERT" "WIPEOUT" "REGION" "MLINE"))
)
)
)
((and(= t1_gbbak "0")(= t2_gbbak "1")(= t3_gbbak "0"))
(setq lst1 '((0 . "~*DIMENSION")(0 . "~LEADER")(0 . "~ATTDEF")(0 . "~VIEWPORT")))
(setq lst2 '("HATCH" "INSERT" "WIPEOUT" "REGION" "MLINE"))
(cond
((= t5_gbbak "1")
(setq lst2 '("HATCH" "INSERT" "WIPEOUT" "REGION" "MLINE"))
)
((= t5_gbbak "0")
(setq lst2 '("INSERT" "WIPEOUT" "REGION" "MLINE"))
)
)
)
((and(= t1_gbbak "1")(= t2_gbbak "0")(= t3_gbbak "1"))
(setq lst1 '((0 . "~HATCH")(0 . "~*TEXT")(0 . "~ATTDEF")(0 . "~VIEWPORT")))
(cond
((= t4_gbbak "1")
(setq lst2 '("INSERT" "WIPEOUT" "REGION" "DIMENSION" "LEADER" "ARC_DIMENSION" "LARGE_RADIAL_DIMENSION" "MLINE"))
)
((= t4_gbbak "0")
(setq lst2 '("INSERT" "WIPEOUT" "REGION" "MLINE"))
)
)
)
((and(= t1_gbbak "1")(= t2_gbbak "1")(= t3_gbbak "0"))
(setq lst1 '((0 . "~*DIMENSION")(0 . "~*TEXT")(0 . "~LEADER")(0 . "~ATTDEF")(0 . "~VIEWPORT")))
(cond
((= t5_gbbak "1")
(setq lst2 '("HATCH" "INSERT" "WIPEOUT" "REGION" "MLINE"))
)
((= t5_gbbak "0")
(setq lst2 '("INSERT" "WIPEOUT" "REGION" "MLINE"))
)
)
)
((and(= t1_gbbak "0")(= t2_gbbak "0")(= t3_gbbak "1"))
(setq lst1 '((0 . "~HATCH")(0 . "~ATTDEF")(0 . "~VIEWPORT")))
(cond
((= t4_gbbak "1")
(setq lst2 '("INSERT" "WIPEOUT" "REGION" "DIMENSION" "LEADER" "ARC_DIMENSION" "LARGE_RADIAL_DIMENSION" "MLINE"))
)
((= t4_gbbak "0")
(setq lst2 '("INSERT" "WIPEOUT" "REGION" "MLINE"))
)
)
)
)
(princ "\n->指定视图名称放置点:")
(cond ((and (fy_Etype ent "LWPOLYLINE") (fy_PolySelFinters_P ent)) (alert "\n提示：多段线自交无法选取区域内图元!") (exit)))
(cond ;修改ent颜色、图层
((not sel_gbbak)
(vla-put-color (vlax-ename->vla-object ent) col)
(vla-put-layer (vlax-ename->vla-object ent) layer)
)
)
;(fy_DtLeader 对象/点 文字 颜色 图层 文字样式 标注样式 字高 箭头类型 箭头大小 全局比例 线型)
(setq DtL (fy_DtLeader ent ed1_gbbak col layer style dim (atof ed6_gbbak) Arr (atof ed8_gbbak) (atof ed10_gbbak) "BYLAYER")) ;画引线
(setq ss (fy_ssgetByEnt ent (atof ed7_gbbak) lst1)) ;选择放大区域内的图元(会选到动态引线)
(if ss (ssdel (fy_envla (car DtL)) ss)) ;从ss集删除动态引线
(cond ((or (not ss) (and ss (< (sslength ss) 1))) (alert "\n提示：区域内没有要放大的图元!") (exit)))
(setq pt0 (get_entcen ent)) ;中心1
;;=====以下处理开始======
(if (and (= t8_gbbak "1") (= t2_gbbak "0")) ;是否解除尺寸关联(慢)
((if command-s command-s vl-cmdf) "DIMDISASSOCIATE" (ssget "_X" '((0 . "DIMENSION,ARC_DIMENSION,LARGE_RADIAL_DIMENSION"))) "")
)
(setq sslst (fy_enlst ss))
(setq sslst (mapcar (function (lambda(x) (vlax-vla-object->ename (vla-copy (vlax-ename->vla-object x))))) sslst)) ;复制一份，用于放大
;;;;;分两类;;;;;;;
(setq ss1 (ssadd)) ;与ent可能相交(要炸的集)
(setq remss (ssadd)) ;不用炸的集
(foreach e sslst ;分类
(cond
((member (cdr (assoc 0 (entget e))) lst2)
(setq pt2 (fy_getbox e))
(setq rec (fy_makerec (car pt2) (cadr pt2)))
(if (fy_GetCurveint rec ent)
(ssadd e ss1)
(ssadd e remss)
)
(entdel rec)
)
(t (ssadd e remss))
)
)
;(mapcar (function (lambda(x) (vla-put-Visible (vlax-ename->vla-object x) :VLAX-FALSE))) sslst) ;隐藏原ss，不要影响后面重选
(setq ss1 (fy_ssExplode ss1 lst2)) ;分解不能打断的对象,返回全部集
(setq ss1 (fy_ssJoin ss1 remss)) ;合并两集
((if command-s command-s vl-cmdf) "._convertpoly" "L" ss1 "") ;转为轻多段线lwpolyline
(fy_Z0 ss1) ;z轴归0,避免不能打断的情况
(setq ss2 (ssget " " '((0 . "LINE,*POLYLINE,ARC,CIRCLE,ELLIPSE,RAY,XLINE,SPLINE")))) ;过滤能打断的图元
(setq ss1 (fy_sssu ss1 ss2)) ;没过滤的集
(if (and ss2 ent (ssmemb ent ss2)) (ssdel ent ss2)) ;不要ent
(setq ss2 (fy_BreakByEnt ss2 ent)) ;打断与ent相交的对象(不支持重多段线polyline)
(setq ent2 (vla-copy (fy_envla ent))) ;复制一个
(vla-scaleentity ent2 (vlax-3d-point pt0) 0.99) ;缩小0.99(缩小的好处是不用管外围图元,允许误差吧)
(setq ent2 (fy_envla ent2)) ;转回ent
(setq ss3 (fy_ssgetByEnt ent2 (atof ed7_gbbak) lst1)) ;重选打断后的区域内图元(会选到ent2自己)
(if (ssmemb ent2 ss) (ssdel ent2 ss)) ;不要ent2
(setq ss3 (fy_sssu ss3 ss)) ;会选到原ss，减掉ss
(ssdel (fy_envla (car DtL)) ss3) ;有些箭头会在区域内(例如实心圆点)，引线又会被选中
(cond ((or (not ss) (and ss (< (sslength ss) 1))) (alert "\n提示：区域内没有要放大的图元!") (exit)))
(setq ent3 (vla-copy (fy_envla ent))) ;再复制一个
(vla-scaleentity ent3 (vlax-3d-point pt0) 1.01) ;放大1.01
(foreach e (fy_enlst ss3) ;删除区域外面ssget误差选中的线
(if (and (member (fy_GetDxf e 0) '("LINE" "LWPOLYLINE" "OLYLINE" "ARC" "CIRCLE" "ELLIPSE" "RAY" "XLINE" "SPLINE")) (fy_GetCurveint ent3 e))
(ssdel e ss3)
)
)
(vl-catch-all-apply (function (lambda ()
(foreach e (fy_enlst (fy_sssu ss2 ss3))
(entdel e)
)
(foreach e (fy_enlst (fy_sssu ss1 ss3))
(entdel e)
)
)))
(entdel ent2)
(vla-delete ent3)
;(mapcar (function (lambda(x) (vla-put-Visible (vlax-ename->vla-object x) :VLAX-TRUE))) sslst) ;显示原ss出来
(setq ss ss3)
(vla-Copy (vlax-ename->vla-object ent)) ;复制一个留在原地
(ssadd ent ss) ;另一个加入ss
;;;======以上处理结束=========
(setq vla_lst (mapcar 'vlax-ename->vla-object (fy_enlst ss))) ;转vla对象表
(setq sc (atof ed2_gbbak)) ;放大比例
(setq sc2 (/ 1 sc)) ;对应的缩小比例
(cond ((= t11_gbbak "0") ;文字比例不随倍数
(foreach obj vla_lst
(cond ((fy_Etype obj "*TEXT")
(setq pt2 (fy_getbox obj))
(vla-scaleentity obj (vlax-3d-point (fy_m2p (car pt2) (cadr pt2))) sc2)
))
)
)
)
(if (= t10_gbbak "1") ;创建视图名称
(progn
(setq fontH (atof ed9_gbbak)) ;字高(getvar "TEXTSIZE")
(setq pt2 (fy_GetBox ent)) ;获得最大对角两点
(setq pt1 (get_entcen ent)) ;获得中心2
(setq dis (distance pt1 (fy_m2p (car pt2) (list (caadr pt2) (cadar pt2))))) ;中心到下限的距离
;(fy_maketext 文字 三维点 字高 旋转角度 宽高比 倾斜 对齐样式 字型)
(cond
((= rad1_gbbak "1") ;位置：上
(setq txt1 (fy_maketext ed1_gbbak (polar pt1 (* 0.5 PI) (+ dis (* fontH 3))) fontH 0 1 0 22 style))
(setq line1 (fy_makeline (list (- (car pt1) fontH) (+ (cadr pt1) dis (* fontH 2))) (list (+ (car pt1) fontH) (+ (cadr pt1) dis (* fontH 2)))))
(setq txt2 (fy_maketext (strcat ed2_gbbak ":1") (polar pt1 (* 0.5 PI) (+ dis fontH)) fontH 0 1 0 22 style))
)
((= rad2_gbbak "1") ;位置：下
(setq txt1 (fy_maketext ed1_gbbak (polar pt1 (* 1.5 PI) (+ dis fontH)) fontH 0 1 0 22 style))
(setq line1 (fy_makeline (list (- (car pt1) fontH) (- (cadr pt1) dis (* fontH 2))) (list (+ (car pt1) fontH) (- (cadr pt1) dis (* fontH 2)))))
(setq txt2 (fy_maketext (strcat ed2_gbbak ":1") (polar pt1 (* 1.5 PI) (+ dis (* fontH 3))) fontH 0 1 0 22 style))
)
)
(foreach e (list txt1 line1 txt2)
(vla-put-color (vlax-ename->vla-object e) col) ;颜色
(vla-put-layer (vlax-ename->vla-object e) layer) ;图层
(Vlax-Put-Property (Vlax-Ename->Vla-Object e) 'Linetype "ByLayer") ;线型随层
(Vlax-Put-Property (Vlax-Ename->Vla-Object e) 'Lineweight -1) ;线宽随层
(cond
((= rad1_gbbak "1") ;位置：上
(vla-ScaleEntity (Vlax-Ename->Vla-Object e) (vlax-3d-point (polar pt1 (* pi 0.5) dis)) sc2) ;先缩小，后面再放大，为了参与动态
)
((= rad2_gbbak "1") ;位置：下
(vla-ScaleEntity (Vlax-Ename->Vla-Object e) (vlax-3d-point (polar pt1 (* pi 1.5) dis)) sc2) ;先缩小，后面再放大，为了参与动态
)
)
(setq vla_lst (cons (vlax-ename->vla-object e) vla_lst))
(ssadd e ss)
)
)
)
(foreach obj vla_lst ;修改尺寸比例
(if (= t6_gbbak "1") (vl-catch-all-apply 'Vlax-Put-Property (list obj 'LinetypeScale (* sc (Vlax-Get obj 'LinetypeScale))))) ;线形比例随倍数
(cond
((fy_Etype obj "DIMENSION")
(setq qm (cdr (assoc 100 (reverse (entget (vlax-vla-object->ename obj))))))
(if (or (= qm "AcDbAlignedDimension") (= qm "AcDbRotatedDimension") (= qm "AcDbDiametricDimension") (= qm "AcDbRadialDimension") (= qm "AcDbOrdinateDimension") (fy_Etype obj "ARC_DIMENSION") (fy_Etype obj "LARGE_RADIAL_DIMENSION")) ;线性标注，直径标注/半径，坐标标注，弧长/折弯
(Vlax-Put-Property obj 'LinearScaleFactor (* (Vlax-Get obj 'LinearScaleFactor) sc2)) ;尺寸比例
)
)
)
)
(cond ((= t7_gbbak "1") ;尺寸比例随倍数
(foreach obj vla_lst
(cond
((fy_Etype obj "DIMENSION")
(setq qm (cdr (assoc 100 (reverse (entget (vlax-vla-object->ename obj))))))
(cond
((or(= qm "AcDbAlignedDimension") (= qm "AcDbRotatedDimension")) ;线性标注
(Vlax-Put-Property obj 'TextHeight (* sc (Vlax-Get obj 'TextHeight))) ;文字高度
(Vlax-Put-Property obj 'TextGap (* sc (Vlax-Get obj 'TextGap))) ;文字偏移
(Vlax-Put-Property obj 'ArrowheadSize (* sc (Vlax-Get obj 'ArrowheadSize))) ;前头大小
(Vlax-Put-Property obj 'DimensionLineExtend (* sc (Vlax-Get obj 'DimensionLineExtend))) ;尺寸范围
(Vlax-Put-Property obj 'ExtensionLineExtend (* sc (Vlax-Get obj 'ExtensionLineExtend))) ;尺寸界线范围
(Vlax-Put-Property obj 'ExtensionLineOffset (* sc (Vlax-Get obj 'ExtensionLineOffset))) ;尺寸界线偏移
)
)
(cond
((or(= qm "AcDbDiametricDimension") (= qm "AcDbRadialDimension")) ;直径标注/半径
(Vlax-Put-Property obj 'TextHeight (* sc (Vlax-Get obj 'TextHeight))) ;文字高度
(Vlax-Put-Property obj 'TextGap (* sc (Vlax-Get obj 'TextGap))) ;文字偏移
(Vlax-Put-Property obj 'ArrowheadSize (* sc (Vlax-Get obj 'ArrowheadSize))) ;前头大小
)
)
(cond
((and (or (= qm "AcDb2LineAngularDimension") (= qm "AcDb3PointAngularDimension"))) ;线性角度标注/3点角度标注
(Vlax-Put-Property obj 'TextHeight (* sc (Vlax-Get obj 'TextHeight))) ;文字高度
(Vlax-Put-Property obj 'TextGap (* sc (Vlax-Get obj 'TextGap))) ;文字偏移
(Vlax-Put-Property obj 'ArrowheadSize (* sc (Vlax-Get obj 'ArrowheadSize))) ;前头大小
(Vlax-Put-Property obj 'ExtensionLineExtend (* sc (Vlax-Get obj 'ExtensionLineExtend))) ;尺寸界线范围
(Vlax-Put-Property obj 'ExtensionLineOffset (* sc (Vlax-Get obj 'ExtensionLineOffset))) ;尺寸界线偏移
)
)
(cond
((= qm "AcDbOrdinateDimension") ;坐标标注
(Vlax-Put-Property obj 'TextHeight (* sc (Vlax-Get obj 'TextHeight))) ;文字高度
(Vlax-Put-Property obj 'TextGap (* sc (Vlax-Get obj 'TextGap))) ;文字偏移
(Vlax-Put-Property obj 'ArrowheadSize (* sc (Vlax-Get obj 'ArrowheadSize))) ;前头大小
(Vlax-Put-Property obj 'ExtensionLineOffset (* sc (Vlax-Get obj 'ExtensionLineOffset))) ;尺寸界线偏移
)
)
)
((fy_Etype obj "LEADER")
(Vlax-Put-Property obj 'ArrowheadSize (* sc (Vlax-Get obj 'ArrowheadSize))) ;前头大小
)
((or (fy_Etype obj "ARC_DIMENSION") (fy_Etype obj "LARGE_RADIAL_DIMENSION")) ;弧长/折弯
(Vlax-Put-Property obj 'TextHeight (* sc (Vlax-Get obj 'TextHeight))) ;文字高度
(Vlax-Put-Property obj 'TextGap (* sc (Vlax-Get obj 'TextGap))) ;文字偏移
(Vlax-Put-Property obj 'ArrowheadSize (* sc (Vlax-Get obj 'ArrowheadSize))) ;前头大小
)
)
)
)
)
(foreach e (fy_enlst ss) (vla-scaleentity (vlax-ename->vla-object e) (vlax-3d-point pt0) sc)) ;放大
(if (member "0" (fy_tbl "LAYER")) (fy_VarSet '("CLAYER" "0"))) ;在0层做块(避免在0层上的图元在动态时颜色变白)
(setq blk (fy_AddBlock ss "*U" pt0 T)) ;创建块
(setq blk (vla-InsertBlock mspace (vlax-3d-point pt0) (vla-get-name blk) 1.0 1.0 1.0 0.0)) ;插入块
(princ "\n->指定视图放置点:")
(fy_Dynamic '("DYNAMIC" "Right") ;动态更新块点，属性块有多个插入点，不能动态移动，所以上面过滤了
'((progn
(vla-put-insertionpoint blk (vlax-3d-point  tPt )
(redraw)
(grdraw pt0 tPt: 7 1)
)
(exit)
) 4)
(redraw)
(setq vla_lst (fy_LispVar (vla-explode blk))) ;分解块(如果不分解,下一个放大图会修改这个块)
(vla-delete blk) ;删除块
(princ (strcat "\n->已局部放大" ed2_gbbak "倍，注意尺寸比例!"))
(vl-cmdf "_ucs" "_p")
(fy_laye_Restore "#fyLayerSave" t) ;恢复图层状态
(fy_ErrorEnd)
)
(defun get_entcen (en / pt qm0) ;取得中心
(setq qm0 (cdr (assoc 0 (entget en))))
(cond
((or (= qm0 "LWPOLYLINE") (= qm0 "INSERT"))
(setq pt (fy_m2p (car (fy_GetBox en)) (cadr (fy_GetBox en))))
)
((or (= qm0 "CIRCLE") (= qm0 "ELLIPSE"))
(setq pt (cdr (assoc 10 (entget en))))
)
)
pt
)
(defun Action_Keys (key value / col) ;全部控件的点击动作触发
(cond
((= key "sel") ;选择区域
(fy_DclGetkeys keylst "_gbbak")
(setq sel_gbbak T)
(cond
((<= (atof ed2_gbbak) 0) (alert "放大倍数不能小于0"))
((and (< (atoi ed3_gbbak) 0) (= b3_gbbak "1")) (alert "矩形圆角不能小于0"))
((and (< (atoi ed4_gbbak) 3) (= b4_gbbak "1")) (alert "多边形边数不能小于3"))
((and (<= (atoi ed5_gbbak) 0) (= b5_gbbak "1")) (alert "弧长不能小于0"))
((<= (atoi ed6_gbbak) 0) (alert "文字高度不能小于0"))
((<= (atoi ed9_gbbak) 0) (alert "视图文本高度不能小于0"))
((<= (atoi ed10_gbbak) 0) (alert "标注全局比例不能小于0"))
((< (atoi ed7_gbbak) 4) (alert "裁剪精度不能小于4"))
(t (done_dialog 1))
)
)
((= key "help") ;帮助
(fy_DclHelp "说明"
'(""
"① 裁剪精度越大，程序越慢，比如：一个圆细分成100份或1000份的区别。"
""
"② 云线弧长不要太短，绘制时不要按右键、空格、回车，绘制成封闭且不自交的图形才行。"
""
"③ 完成放大图后有多余的尺寸，可能是关联尺寸，可自行删除或勾选【解除尺寸关联】选项。"
""
"④ 勾选【分解尺寸】，默认是尺寸随比例放大。因为尺寸已分解了，不能对其修改样式。"
""
"⑤ 有些尺寸/块/填充等图元最终没分解，是因为程序能确定它在区域内。"
""
"⑥ 矩形圆角不稳定，如果使用不正常，不要勾选【矩形圆角】选项。"
""
"⑦ 不勾选【文字随比例放大】，文字可能会跑位，与原位置会有偏差。"
""
"——小笨"
)
)
)
((= key "accept") ;绘制区域
(fy_DclGetkeys keylst "_gbbak")
(cond
((<= (atof ed2_gbbak) 0) (alert "放大倍数不能小于0"))
((and (< (atoi ed3_gbbak) 0) (= b3_gbbak "1")) (alert "矩形圆角不能小于0"))
((and (< (atoi ed4_gbbak) 3) (= b4_gbbak "1")) (alert "多边形边数不能小于3"))
((and (<= (atoi ed5_gbbak) 0) (= b5_gbbak "1")) (alert "弧长不能小于0"))
((<= (atoi ed6_gbbak) 0) (alert "文字高度不能小于0"))
((< (atoi ed7_gbbak) 4) (alert "裁剪精度不能小于4"))
((<= (atoi ed8_gbbak) 0) (alert "引线箭头大小不能小于0"))
((<= (atoi ed9_gbbak) 0) (alert "视图文本高度不能小于0"))
((<= (atoi ed10_gbbak) 0) (alert "标注全局比例不能小于0"))
(t (done_dialog 1))
)
)
((= key "cancel") ;取消
(done_dialog 0)
)
((or (= key "b1") (= key "b2")) ;圆，椭圆
(fy_DclNoEnabled '("ed3" "ed4" "ed5" "t9")) ;矩形圆角，多边形边数,云线弧长，矩形圆角开关
)
((= key "b3") ;矩形
(fy_DclEnabled '("ed3" "t9")) ;矩形圆角
(fy_DclNoEnabled '("ed4" "ed5")) ;多边形边数,云线弧长
)
((= key "b4") ;多边形
(fy_DclEnabled '("ed4"))
(fy_DclNoEnabled '("ed3" "ed5" "t9"))
)
((= key "b5") ;云线
(fy_DclEnabled '("ed5"))
(fy_DclNoEnabled '("ed3" "ed4" "t9"))
)
((= key "t1") ;过滤文字
(if (= (get_tile "t1") "1")
(fy_DclNoEnabled '("t11"))
(progn (fy_DclEnabled '("t11")) (set_tile "t11" "1"))
)
)
((= key "t2") ;过滤尺寸
(if (= (get_tile "t2") "1")
(progn (fy_DclNoEnabled '("t4" "t7" "t8")) (set_tile "t8" "0"))
(fy_DclEnabled '("t4" "t7" "t8"))
)
)
((= key "t3") ;过滤填充
(if (= (get_tile "t3") "1")
(fy_DclNoEnabled '("t5"))
(fy_DclEnabled '("t5"))
)
)
((= key "t9") ;矩形圆角
(if (= (get_tile "t9") "1")
(fy_DclEnabled '("ed3"))
(fy_DclNoEnabled '("ed3"))
)
)
((= key "t10") ;是否创建视图名称
(if (= (get_tile "t10") "1")
(fy_DclEnabled '("ed1" "ed9"))
(fy_DclNoEnabled '("ed1" "ed9"))
)
)
((= key "Tstyle") ;文字样式下拉表
(set_tile "ed9" (vl-princ-to-string (fy_NumStr (cdr (assoc 42 (tblsearch "STYLE" (nth (atoi (get_tile "Tstyle")) (vl-remove "" (fy_tbl "STYLE")))))))))
)
((= key "Dstyle") ;标注样式下拉表
(set_tile "ed6" (vl-princ-to-string (fy_NumStr (cdr (assoc 140 (tblsearch "DIMSTYLE" (nth (atoi (get_tile "Dstyle")) (vl-remove "" (fy_tbl "DIMSTYLE")))))))))
(set_tile "ed8" (vl-princ-to-string (fy_NumStr (cdr (assoc 41 (tblsearch "DIMSTYLE" (nth (atoi (get_tile "Dstyle")) (vl-remove "" (fy_tbl "DIMSTYLE")))))))))
(set_tile "ed10" (vl-princ-to-string (fy_NumStr (cdr (assoc 40 (tblsearch "DIMSTYLE" (nth (atoi (get_tile "Dstyle")) (vl-remove "" (fy_tbl "DIMSTYLE")))))))))
)
((= key "col") ;颜色
(setq col (acad_colordlg (atoi (get_tile "coltxt"))))
(cond (col
(set_tile "coltxt" (itoa col))
(start_image "col")
(fill_image 0 0 (dimx_tile "col") (dimy_tile "col") col)
(end_image)
))
)
((= key "rad3") ;罗马
(if gb_Roman_bak
(set_tile "ed1" gb_Roman_bak) ;设为最近使用的罗马值
(set_tile "ed1" "I")
)
)
((= key "rad4") ;字母
(if gb_letter_bak
(set_tile "ed1" gb_letter_bak) ;设为最近使用的字母值
(set_tile "ed1" "A")
)
)
)
)
(setq dcl_id (fy_DclWrite
'(
"gbfd:dialog {"
" label = \"局部放大 v1.3.7\" ;"
" spacer;"
" :boxed_radio_row {"
" label = \"方式:\" ;"
" :radio_button {"
" label = \"矩形\" ;"
" key = \"b3\" ;"
" value = 1 ;"
" }"
" :radio_button {"
" label = \"圆形\" ;"
" key = \"b1\" ;"
" }"
" :radio_button {"
" label = \"椭圆\" ;"
" key = \"b2\" ;"
" }"
" :radio_button {"
" label = \"多边形\" ;"
" key = \"b4\" ;"
" }"
" :radio_button {"
" label = \"云线\" ;"
" key = \"b5\" ;"
" }"
" }"
" :spacer {}"
" :spacer {}"
" :row {"
" :column {"
" :boxed_column {"
" label = \"过滤:\" ;"
" :toggle {"
" label = \"过滤文字\" ;"
" key = \"t1\" ;"
" value = 1 ;"
" }"
" :toggle {"
" label = \"过滤尺寸\" ;"
" key = \"t2\" ;"
" value = 1 ;"
" }"
" :toggle {"
" label = \"过滤填充\" ;"
" key = \"t3\" ;"
" value = 1 ;"
" }"
" }"
" :boxed_column {"
" label = \"其它：\" ;"
" :spacer {}"
" :toggle {"
" key = \"t6\" ;"
" label = \"线型比例随比例放大\" ;"
" value = 1 ;"
" }"
" :spacer {}"
" :toggle {"
" key = \"t7\" ;"
" label = \"尺寸样式随比例放大\" ;"
" value = 0 ;"
" }"
" :spacer {}"
" :toggle {"
" key = \"t11\" ;"
" label = \"文字随比例放大(不选有偏差)\" ;"
" value = \"1\" ;"
" }"
" :spacer {}"
" :image {"
" color = 254 ;"
" fixed_height = true ;"
" height = 0.05 ;"
" }"
" :spacer {}"
" :toggle {"
" key = \"t8\" ;"
" label = \"解除全图尺寸关联(慢)\" ;"
" value = 0 ;"
" }"
" :spacer {}"
" :toggle {"
" key = \"t4\" ;"
" label = \"分解与区域可能相交的尺寸\" ;"
" value = 0 ;"
" }"
" :spacer {}"
" :toggle {"
" key = \"t5\" ;"
" label = \"分解与区域可能相交的填充\" ;"
" value = 1 ;"
" }"
" :spacer {}"
" :image {"
" color = 254 ;"
" fixed_height = true ;"
" height = 0.05 ;"
" }"
" :spacer {}"
" :toggle {"
" key = \"t10\" ;"
" label = \"视图名称\" ;"
" value = \"1\" ;"
" }"
" :spacer {}"
" :toggle {"
" key = \"t9\" ;"
" label = \"矩形圆角\" ;"
" value = \"0\" ;"
" }"
" }"
" }"
" :boxed_column {"
" label = \"参数：\" ;"
" :edit_box {"
" edit_width = 6 ;"
" key = \"ed2\" ;"
" label = \"放大倍数:\" ;"
" value = 2 ;"
" }"
" :edit_box {"
" edit_width = 6 ;"
" key = \"ed1\" ;"
" label = \"视图名称:\" ;"
" value = \"A\" ;"
" }"
" :edit_box {"
" edit_width = 6 ;"
" key = \"ed9\" ;"
" label = \"视图文本高度:\" ;"
" value = 3 ;"
" }"
" :spacer {}"
" :row {"
" :boxed_radio_column {"
" label = \"位置\" ;"
" :radio_button {"
" key = \"rad1\" ;"
" label = \"上\" ;"
" }"
" :radio_button {"
" key = \"rad2\" ;"
" label = \"下\" ;"
" value = 1 ;"
" }"
" }"
" :boxed_radio_column {"
" label = \"类型\" ;"
" :radio_button {"
" key = \"rad3\" ;"
" label = \"罗马\" ;"
" }"
" :radio_button {"
" key = \"rad4\" ;"
" label = \"字母\" ;"
" value = \"1\" ;"
" }"
" }"
" }"
" :edit_box {"
" edit_width = 6 ;"
" key = \"ed6\" ;"
" label = \"引线文字高度:\" ;"
" value = 3 ;"
" }"
" :edit_box {"
" edit_width = 6 ;"
" key = \"ed8\" ;"
" label = \"引线箭头大小:\" ;"
" value = 3 ;"
" }"
" :edit_box {"
" edit_width = 6 ;"
" key = \"ed10\" ;"
" label = \"引线全局比例:\" ;"
" value = 1 ;"
" }"
" :spacer {}"
" :image {"
" color = 254 ;"
" fixed_height = true ;"
" height = 0.05 ;"
" }"
" :edit_box {"
" edit_width = 6 ;"
" key = \"ed7\" ;"
" label = \"裁剪精度(段数):\" ;"
" value = 100 ;"
" }"
" :edit_box {"
" edit_width = 6 ;"
" key = \"ed4\" ;"
" label = \"多边形边数:\" ;"
" value = 8 ;"
" }"
" :edit_box {"
" edit_width = 6 ;"
" key = \"ed5\" ;"
" label = \"云线弧长:\" ;"
" value = 10 ;"
" }"
" :edit_box {"
" edit_width = 6 ;"
" key = \"ed3\" ;"
" label = \"矩形圆角:\" ;"
" value = 0 ;"
" }"
" :spacer {}"
" }"
" }"
" spacer;"
" :row {"
" :popup_list {"
" key = \"lay\" ;"
" label = \"所在图层\" ;"
" }"
" :popup_list {"
" key = \"arr\" ;"
" label = \"箭头类型\" ;"
" }"
" }"
" :row {"
" :popup_list {"
" key = \"Tstyle\" ;"
" label = \"文字样式\" ;"
" }"
" :popup_list {"
" key = \"Dstyle\" ;"
" label = \"标注样式\" ;"
" }"
" }"
" spacer;"
" :row {"
" :boxed_row {"
" label = \"颜色\" ;"
" :image_button {"
" fixed_height = true ;"
" fixed_width = true ;"
" height = 2 ;"
" key = \"col\" ;"
" width = 4 ;"
" horizontal_margin = none ;"
" vertical_margin = none ;"
" }"
" :edit_box {"
" edit_width = 2 ;"
" fixed_height = true ;"
" height = 1.3 ;"
" is_enabled = false ;"
" key = \"coltxt\" ;"
" horizontal_margin = none ;"
" vertical_margin = none ;"
" }"
" }"
" :button {"
" height = 2.5 ;"
" key = \"help\" ;"
" label = \"说明\" ;"
" }"
" :button {"
" label = \"退出\" ;"
" key = \"cancel\" ;"
" height = 2.5 ;"
" is_cancel = true ;"
" }"
" :button {"
" label = \"选择区域\" ;"
" key = \"sel\" ;"
" height = 2.5 ;"
" }"
" :button {"
" height = 2.5 ;"
" is_default = true ;"
" key = \"accept\" ;"
" label = \"绘制区域\" ;"
" }"
" }"
"}"
))
)
(new_dialog "gbfd" dcl_id)
(fy_DclList "lay" (fy_tbl "LAYER")) ;图层
(fy_DclList "Tstyle" (vl-remove "" (fy_tbl "STYLE"))) ;文字样式
(fy_DclList "Dstyle" (fy_tbl "DIMSTYLE")) ;标注样式
(fy_DclList "arr" '("实心闭合" "空心闭合" "闭合" "点" "建筑标记" "倾斜" "打开" "指示原点" "指标原点 2" "直角" "30 度角" "小点" "空心点" "空心小点" "方框" "实心方框" "基准三角形" "实心基准三角形" "积分" "无"))
(setq keylst '("b1" "b2" "b3" "b4" "b5" "rad1" "rad2" "rad3" "rad4" "ed1" "ed2" "ed3" "ed4" "ed5" "ed6" "ed7" "ed8" "ed9" "ed10" "t1" "t2" "t3" "t4" "t5" "t6" "t7" "t8" "t9" "t10" "t11" "arr" "lay" "Dstyle" "Tstyle" "col" "coltxt"))
(fy_DclAction (append '("sel" "help" "accept" "cancel") keylst) "_gbbak")
;控件灰显状态
(if (= (get_tile "b3") "1")
(fy_DclEnabled '("ed3" "t9")) ;矩形圆角
(fy_DclNoEnabled '("ed3"))
)
(if (= (get_tile "b4") "1")
(fy_DclEnabled '("ed4"))
(fy_DclNoEnabled '("ed4"))
)
(if (= (get_tile "b5") "1")
(fy_DclEnabled '("ed5"))
(fy_DclNoEnabled '("ed5"))
)
(if (= (get_tile "t1") "1")
(fy_DclNoEnabled '("t11"))
(progn (fy_DclEnabled '("t11")) (set_tile "t11" "1"))
)
(if (= (get_tile "t2") "1")
(progn (fy_DclNoEnabled '("t4" "t7" "t8")) (set_tile "t8" "0"))
(fy_DclEnabled '("t4" "t7" "t8"))
)
(if (= (get_tile "t3") "1")
(fy_DclNoEnabled '("t5"))
(fy_DclEnabled '("t5"))
)
(if (= (get_tile "t9") "1")
(fy_DclEnabled '("ed3"))
(fy_DclNoEnabled '("ed3"))
)
(if (= (get_tile "t10") "1")
(fy_DclEnabled '("ed1" "ed9"))
(fy_DclNoEnabled '("ed1" "ed9"))
)
;第一次打开按用户当前的图层、文字样式、标注样式、颜色作为默认选项，下次打开会按对话框当前界面还原
(if (not lay_gbbak) ;首次图层
(set_tile "lay" (itoa (vl-position (getvar "clayer") (fy_tbl "LAYER"))))
)
(if (not Tstyle_gbbak) ;首次文字样式
(set_tile "Tstyle" (itoa (vl-position (getvar "textstyle") (vl-remove "" (fy_tbl "STYLE")))))
)
(if (not ed9_gbbak) ;首次视图文本高度
(set_tile "ed9" (vl-princ-to-string (fy_NumStr (cdr (assoc 42 (tblsearch "STYLE" (nth (atoi (get_tile "Tstyle")) (vl-remove "" (fy_tbl "STYLE")))))))))
)
(if (not Dstyle_gbbak) ;首次标注样式
(set_tile "Dstyle" (itoa (vl-position (getvar "dimstyle") (fy_tbl "DIMSTYLE"))))
)
(if (not ed6_gbbak) ;首次引线文字高度
(set_tile "ed6" (vl-princ-to-string (fy_NumStr (cdr (assoc 140 (tblsearch "DIMSTYLE" (nth (atoi (get_tile "Dstyle")) (vl-remove "" (fy_tbl "DIMSTYLE")))))))))
)
(if (not ed8_gbbak) ;首次引线箭头大小
(set_tile "ed8" (vl-princ-to-string (fy_NumStr (cdr (assoc 41 (tblsearch "DIMSTYLE" (nth (atoi (get_tile "Dstyle")) (vl-remove "" (fy_tbl "DIMSTYLE")))))))))
)
(if (not ed10_gbbak) ;首次引线全局比例
(set_tile "ed10" (vl-princ-to-string (fy_NumStr (cdr (assoc 40 (tblsearch "DIMSTYLE" (nth (atoi (get_tile "Dstyle")) (vl-remove "" (fy_tbl "DIMSTYLE")))))))))
)
(setq col (getvar "cecolor")) ;当前颜色
(cond ;颜色txt值
(coltxt_gbbak (setq col coltxt_gbbak)) ;第一次打开是没有col_gbbak值的
((= col "BYLAYER") (setq col "256"))
((= col "BYBLOCK") (setq col "0"))
)
(set_tile "coltxt" col) ;设置颜色编辑框
(start_image "col") ;设置颜色图像按钮
(fill_image 0 0 (dimx_tile "col") (dimy_tile "col") (atoi col))
(end_image)
(cond ((= (start_dialog) 1)
(fy_fangda)
(if (= (type (read ed1_gbbak)) 'INT)
(setq ed1_gbbak (itoa (1+ (atoi ed1_gbbak)))) ;下一个数字
(cond
((= rad3_gbbak "1") ;罗马
(setq err1 (vl-catch-all-apply (function (lambda() (setq R_ini (fy_Roman2ini ed1_gbbak)))))) ;转为整数
(if (not (vl-catch-all-error-p err1)) ;如果能转换，证明是罗马
(setq err2 (vl-catch-all-apply (function (lambda() (setq ed1_gbbak (fy_ini2Roman (1+ R_ini))))))) ;下一个罗马
)
(if (not (vl-catch-all-error-p err2))
(setq gb_Roman_bak ed1_gbbak) ;记下当前罗马
)
)
((= rad4_gbbak "1") ;字母
(cond
((= "Z" ed1_gbbak)
(setq ed1_gbbak "A")
(setq gb_letter_bak ed1_gbbak) ;记下当前字母
)
((= "z" ed1_gbbak)
(setq ed1_gbbak "a")
(setq gb_letter_bak ed1_gbbak) ;记下当前字母
)
((vl-string-search (strcase ed1_gbbak) "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
(setq ed1_gbbak (chr (1+ (ascii ed1_gbbak)))) ;下一个字母
(setq gb_letter_bak ed1_gbbak) ;记下当前字母
)
)
)
)
)
)
)
(unload_dialog dcl_id)
(princ)
)
;;;;;;;;所用到的通用函数;;;;;;;;;;;;;;;
(defun fy_DtLeader ;动态引线
;(fy_DtLeader 对象/点 文字 颜色 图层 文字样式 标注样式 字高 箭头类型 箭头大小 线型)
;字高不能为0
(ent str col lay sty dim txtH arr arrH sc lt / mspace i wenzi a b c d aa bb cc dd ee ff gg Leader m)
(if (and (= (getvar "tilemode") 0) (= (getvar "cvport") 1))
(setq mspace (vla-get-paperspace (vla-get-activedocument (vlax-get-acad-object))))
(setq mspace (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
)
(setq i T)
(while i
;(grread T 12 1)会闪/卡， 0十字光标 1不显示光标 2对象选择光标
(setq a (grread T 12 0) b (car a) c (cadr a)) ;b=5移动，b=3左键，c=0右键，c=13回车，c=32空格
(cond
((= b 5) ;当鼠标移动时
(setq a (trans (cadr a) 1 0)) ;鼠标移动点
(cond
((= (type ent) 'LIST) (setq d ent)) ;固定点
((= (type ent) 'ENAME) (setq d (vlax-curve-getclosestpointto ent 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)) ;提取 d 的x,y,z
;★创建引线★
(setq gg (vlax-make-safearray vlax-vbDouble '(0 . 5))) ;建立数字表
(vlax-safearray-fill gg (list dd ee ff aa (- (cadr a) 2) cc)) ;填满gg
(if (not Leader)
(progn
(setq m (vla-AddMText mspace (vlax-3d-point (list aa bb)) 0 str)) ;创建文字
(if col (vla-put-color m col)) ;颜色
(if lay (vla-put-layer m lay)) ;图层
(if sty (vla-put-StyleName m sty)) ;文字样式
(if txtH ;引线文字高度
(if sc
(vla-put-height m (* sc txtH))
(vla-put-height m txtH)
)
(if sc
(vla-put-height m (* sc (getvar "DIMTXT")))
(vla-put-height m (getvar "DIMTXT"))
)
)
(setq wenzi (vlax-make-safearray vlax-vbString '(1 . 9))) ;建立字符表
(vlax-safearray-fill wenzi '("TopLeft" "TopCenter" "TopRight" "MiddleLeft" "MiddleCenter" "MiddleRight" "BottomLeft" "BottomCenter" "BottomRight")) ;填满wenzi
(vla-put-attachmentpoint m 7) ;更新文字的贴附点为7
(setq Leader (vla-AddLeader mspace gg m acLineWithArrow)) ;有箭头的线
(if col (vla-put-color Leader col)) ;颜色
(if lay (vla-put-layer Leader lay)) ;图层
(if dim (vla-put-StyleName Leader dim)) ;标注样式
(if arrH
(vla-put-arrowheadsize Leader arrH) ;箭头大小
(vla-put-arrowheadsize Leader (getvar "DIMASZ"))
)
(if sc
(Vlax-Put-Property Leader 'ScaleFactor sc)
(Vlax-Put-Property Leader 'ScaleFactor (getvar "DIMSCALE"))
)
(if lt (Vlax-Put-Property Leader 'Linetype lt))
(if arr (Vlax-Put Leader 'ArrowheadType arr)) ;箭头类型
)
)
(vla-put-insertionpoint m (vlax-3d-point (list aa (- (cadr a) 1.5)))) ;更新文字插入点
(vla-put-coordinates Leader gg) ;更新引线插入点
(vla-put-verticaltextposition Leader 1) ;引线自动判断方向
)
((= b 3) (setq i nil)) ;左键结束while
)
)
(list Leader m)
)
(defun fy_BreakByEnt ;根据对象来打断集,返回打断后的对象
(ss ent / brkobjlst brk_obj en iplist lastent maxparam minparam
obj obj2break obj_erase p1param p2 p2param pt ssobjs ssobjsall
onlockedlayer ssget->vla-list list->3pair)
(vl-load-com)
(defun onlockedlayer (ename / entlst)
(setq entlst (tblsearch "LAYER" (cdr (assoc 8 (entget ename)))))
(= 4 (logand 4 (cdr (assoc 70 entlst))))
)
(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 vl-cmdf
;;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)
)
((if command-s command-s vl-cmdf)
"._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)
)
((if command-s command-s vl-cmdf)
"._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
((if command-s command-s vl-cmdf)
"._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
)
(defun fy_VarSet ;设置并备份系统变量
(syslst / sysname sysvar)
;例子：
;(fy_ErrorInit '("cmdecho" 0) 0 nil)
;(setq pt1 (getpoint "\n指定第一点："))
;(fy_VarSet '("osmode" 128)) ;捕捉垂足
;(setq pt2 (getpoint "\n指定第二点："))
;(fy_VarRes) ;还原变量
;(fy_VarSet '("cmdecho" 0)) ;重设变量
;(fy_ErrorEnd)
(if syslst
(while (and (setq sysname (car syslst)) (setq sysvar (cadr syslst)))
(setq *sysvarInit* (append *sysvarInit* (list sysname (getvar sysname))))
(setq syslst (cddr syslst))
(setvar sysname sysvar)
)
)
(princ)
)
(defun fy_VarRes ;恢复备份的系统变量
(/ sysname sysvar)
(if *sysvarInit* ;;恢复储存的系统变量
(while (and (setq sysname (car *sysvarInit*)) (setq sysvar (cadr *sysvarInit*)))
(setq *sysvarInit* (cddr *sysvarInit*))
(setvar sysname sysvar)
)
)
(princ)
)
(defun fy_ErrorInit ;错误处理函数 by Gu_xl
(syslst UndoMode fun / sysname sysvar adoc)
;; 例: (fy_ErrorInit '("cmdecho" 0) 0 nil)
;; syslst: 包含系统变量及其值的列表
;; UndoMode: nil = 不编组 0 = 仅仅编组 1 = 回到出错前
;; fun: 要执行的函数 ,无动作则为nil
(vl-load-com)
(setq *olderror* *error*
*Function* fun
*UndoMode* UndoMode
)
(defun *error* (msg / sysname sysvar adoc)
(setq adoc (vla-get-activedocument (vlax-get-acad-object)))
(if *Function*
(cond
((= (type *Function*) 'SYM) (vl-catch-all-apply *Function*)) ;执行函数
((= (type *Function*) 'LIST) (eval *Function*)) ;执行语句
)
)
(if (= 1 *UndoMode*)
(progn
(setq *sysvarInit* nil)
(if (= 8 (logand (getvar "undoctl") 8))
(vla-endundomark adoc)
)
((if command-s command-s vl-cmdf) "_U")
)
(progn
(if *sysvarInit*
(while (and (setq sysname (car *sysvarInit*)) (setq sysvar (cadr *sysvarInit*)))
(setq *sysvarInit* (cddr *sysvarInit*))
(setvar sysname sysvar)
)
)
(if (= *UndoMode* 0)
(if(= 8 (logand (getvar "undoctl") 8))
(vla-endundomark adoc)
)
)
)
)
(setq *error* *olderror*
*olderror* nil
*Function* nil
*UndoMode* nil
)
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
(princ (strcat "\n** " msg " **"))
)
)
(setq adoc (vla-get-activedocument (vlax-get-acad-object)))
(if (or (= *UndoMode* 0) (= *UndoMode* 1))
(progn
(if (= 8 (logand (getvar "undoctl") 8)) ;;如果有活动编组，先结束编组
(vla-endundomark adoc) ;编组结束
)
(vla-startundomark adoc) ;编组开始
)
)
(if syslst
(while (and (setq sysname (car syslst)) (setq sysvar (cadr syslst)))
(setq *sysvarInit* (append *sysvarInit* (list sysname (getvar sysname))))
(setq syslst (cddr syslst))
(setvar sysname sysvar)
)
)
(princ)
)
(defun fy_ErrorEnd ;错误恢复函数 by Gu_xl
(/ sysname sysvar)
(vl-load-com)
(if (= 8 (logand (getvar "undoctl") 8))
(vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
)
(if *olderror* ;;恢复*error*函数
(setq *error* *olderror* *olderror* nil)
)
(if *sysvarInit* ;;恢复储存的系统变量
(while (and (setq sysname (car *sysvarInit*)) (setq sysvar (cadr *sysvarInit*)))
(setq *sysvarInit* (cddr *sysvarInit*))
(setvar sysname sysvar)
)
)
(setq *Function* nil *UndoMode* nil)
(princ)
)
(defun fy_layerSave ;保存图层状态 by Gu_xl
(name Mask / lm)
;(fy_layerSave name Mask) 保存图层状态,成功返回T，否则返回nil
;(fy_layerSave "#fyLayerSave" nil) ;保存图层状态
;(fy_laye_Restore "#fyLayerSave" t) ;恢复图层状态
;;;;;;;;;
;acLsAll All layer properties
;acLsColor Color
;acLsFrozen Frozen or thawed
;acLsLineType Linetype
;acLsLineWeight Lineweight
;acLsLocked Locked or unlocked
;acLsNewViewport New viewport layers frozen or thawed
;acLsNone None
;acLsOn On or off
;acLsPlot Plotting on or off
;acLsPlotStyle Plot style
(if (null Mask)
(setq Mask aclsall))
(setq lm
(vla-GetInterfaceObject (vlax-get-acad-object)
(strcat "AutoCAD.AcadLayerStateManager." (substr (getvar 'acadver) 1 2))
)
)
(vla-setdatabase lm (vla-get-Database (vla-get-activedocument (vlax-get-acad-object))))
(if (vl-catch-all-error-p
(vl-catch-all-apply 'vla-save (list lm name mask))
)
(progn
(vl-catch-all-apply 'vla-delete (list lm name))
(not
(vl-catch-all-error-p
(vl-catch-all-apply 'vla-save (list lm name mask))
)
)
)
t
)
)
(defun fy_laye_Restore ;恢复图层状态 by Gu_xl
(name delflag / lm rtn)
;(fy_laye_Restore name delflag) 恢复图层状态,成功返回T，否则返回nil
;(fy_layerSave "#fyLayerSave" nil) ;保存图层状态
;(fy_laye_Restore "#fyLayerSave" t) ;恢复图层状态
(setq lm (vla-GetInterfaceObject (vlax-get-acad-object)
(strcat "AutoCAD.AcadLayerStateManager."
(substr (getvar 'acadver) 1 2)
)
)
)
(vla-setdatabase lm (vla-get-Database (vla-get-activedocument (vlax-get-acad-object))))
(setq rtn
(not
(vl-catch-all-error-p
(vl-catch-all-apply 'vla-Restore (list lm name))
)
)
)
(if delflag (vl-catch-all-apply 'vla-delete (list lm name)))
rtn
)
(defun fy_UnLockLayer ;解锁所有图层 by Gu_xl
(/ n)
(vlax-map-collection (vla-get-layers (vla-get-ActiveDocument (vlax-get-acad-object)))
'(lambda (n)
(vla-put-lock n :vlax-false)
)
)
)
(defun fy_entsel ;带提示、关键字、过滤表、选择错误时的提示 ;by CLH521
(msg key fil ermsg / el ss)
;;用法：(fy_entsel 提示信息 关键字 过滤表 选择错误时提示)
;;举例：(fy_entsel "\n请选择一个圆：" "A B C" '((0 . "circle")) "\n所选对象不符合要求！请重新选择：")
;;举例：(fy_entsel "\n请选择一个圆：" nil '((0 . "circle")) "\n所选对象不符合要求！请重新选择：")
;;说明：过滤表与ssget的过滤表相同
(while (and (setvar "errno" 0)
(not (and (setq el (apply '(lambda (msg key) (if key (initget key)) (if msg (entsel msg) (entsel))) (list msg key)))
(if (= (type el) 'str)
el
(if (setq ss (ssget (cadr el) fil))
ss
(progn (if ermsg (princ ermsg)) (setq ss nil))
)
)
)
)
(/= (getvar "errno") 52)
)
)
;(if (= (type el) 'list) (redraw (car el) 3));亮显选中的对像
el
)
(defun fy_GetPt ;带提示,无捕捉,获得点
(msg / a b c i)
(if msg (princ msg))
(setq i T c T)
(while i
(setq a (grread T 12 0) b (car a))
(if (null c)
(cond
((= b 3) (setq a (cadr a) i nil)) ;左键
((= b 12) (setq i nil a nil)) ;右键
)
(setq c nil)
)
)
a
)
(defun fy_PutDxf ;更改图元、图元表、选择集DXF组码以修改实体属性 by xyp
(ename code val / ent x y i s1)
;方式 : (fy_PutDxf 实体名 DXF码 新值)
;改圆半径为50 (fy_PutDxf (car(entsel "\n选择圆:")) 40 50)
;选择集变红色 (fy_PutDxf (ssget) 62 1)
(cond
((= (type ename) 'ENAME)
(setq ent (entget ename))
(if (and (= (type code) 'LIST) (= (type val) 'LIST))
(mapcar '(lambda (x y) (fy_PutDxf ename x y)) code val)
(progn
(if (= (fy_GetDxf ename code) nil)
(entmod (append ent (list (cons code val))))
(entmod (subst (cons code val) (assoc code ent) ent))
)
(entupd ename)
)
)
)
((= (type ename) 'VLA-OBJECT)
(fy_PutDxf (setq ename (vlax-vla-object->ename ename)) code val)
)
((= (type ename) 'PICKSET)
(setq i -1)
(while (setq s1 (ssname ename (setq i (1+ i))))
(fy_PutDxf s1 code val)
)
)
((= (type ename) 'LIST)
(foreach s1 ename (fy_PutDxf s1 code val))
)
)
ename
)
(defun fy_GetDxf ;获得图元DXF组码 by xyp
(ename code / ent lst a)
(if (= (type ename) 'VLA-OBJECT) (setq ename (vlax-vla-object->ename ename)))
(if (= (type code) 'LIST)
(progn
(setq ent (entget ename) lst '())
(foreach a code
(setq lst (cons (list a (cdr (assoc a ent))) lst))
)
(reverse lst)
)
(if (= code -3)
(cdr (assoc code (entget ename '("*"))))
(cdr (assoc code (entget ename)))
)
)
)
(defun fy_EntNextAll ;获取在图元en之后产生的图元列表 ;by caoyin
(en / lst ss)
;; [参数] en----图元名
;; [返回] 选择集表
;; [测试]1.(setq en (entlast))
;; 执行创建图元的命令，如 LINE,BOUNDARY
;; (fy_EntNextAll en)
;; 2.(fy_EntNextAll (car(entsel)))
(if en
(while (setq en (entnext en))
(if (not (member (cdr (assoc 0 (entget en))) '("ATTRIB" "VERTEX" "SEQEND")))
(setq lst (cons en lst))
)
)
(progn
(setq ss (ssget "_x"))
(if ss (setq lst (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex ss)))))
)
)
(reverse lst)
)
(defun fy_sslast ;获取在图元en之后产生的选择集 ;by caoyin
(en / ss)
(if en ;如果en存在
(progn
(setq ss (ssadd)) ;建立空集
(while (setq en (entnext en)) ;当en后有对象时
(if (not (member (cdr (assoc 0 (entget en))) '("ATTRIB" "VERTEX" "SEQEND")))
(ssadd en ss) ;把en后的对象加入到空集
)
)
(if (zerop (sslength ss)) (setq ss nil)) ;如果SS为0，设置SS为nil
ss
)
(ssget "_x")
)
)
(defun fy_envla ;图元名与vla对象互转
(ent)
(cond
((= (type ent) 'ENAME) (vlax-ename->vla-object ent))
((= (type ent) 'VLA-OBJECT) (vlax-vla-object->ename ent))
)
)
(defun fy_NumStr(num) ;实数保留精度输出为字符 by fsxm
(vlax-variant-value (vlax-variant-change-type (vlax-make-variant num) 8))
)
(defun fy_PolySelFinters_P ;判断多段线是否自交 By Lee Mac
(obj / _gbn n v)
(if (= 'ename (type obj)) (setq obj (vlax-ename->vla-object obj)))
(defun _gbn ( l n / r s )
(repeat (/ (length l) n)
(repeat n
(setq s (cons (car l) s)
l (cdr l)
)
)
(setq r (cons (reverse s) r)
s nil
)
)
(reverse r)
)
(setq v (_gbn (vlax-get obj 'coordinates) 2)
n (vlax-get obj 'normal)
)
(vl-some
(function
(lambda ( i )
(null
(vl-some
(function
(lambda ( v )
(equal i (trans v n 0) 1e-8)
)
)
v
)
)
)
)
(_gbn (vlax-invoke obj 'intersectwith obj acextendnone) 3)
)
)
(defun fy_Etype ;检查实体类型
(ename etype)
(if (= (type ename) 'VLA-OBJECT) (setq ename (vlax-vla-object->ename ename)))
(wcmatch (cdr (assoc 0 (entget ename))) (strcase etype))
)
(defun fy_ssgetByEnt ;选择对象内图元
(ent n fil / ss ptlsts)
;ent对象 n段数 fil过滤表
(setvar "cmdecho" 0)
(fy_zoom ent 0.8)
(setq ptlsts (fy_Curdiv ent (* -1 n))) ;分段曲线点表
(if ptlsts (setq ss (ssget "CP" ptlsts fil)))
(vl-cmdf "zoom" "p")
(vl-cmdf "zoom" "p")
(if (and ent ss (ssmemb ent ss)) (ssdel ent ss))
ss
)
(defun fy_zoom ;缩放对象,要返回上一个的视图,需两次(vl-cmdf "zoom" "p")
(ss sc / two_pt p1 p2 app)
(if ss
(progn
(vl-load-com)
(setq two_pt (fy_Getbox ss))
(setq p1 (car two_pt))
(setq p2 (cadr two_pt))
(setq app (vla-get-Application (vla-get-activedocument (vlax-get-acad-object))))
(vla-ZoomWindow app (vlax-3d-point p1) (vlax-3d-point p2))
(vla-ZoomScaled app sc acZoomScaledRelative)
)
)
(princ)
)
(defun fy_Curdiv ;曲线等分距离或者分段数 by llsheng_73
(obj d / d0 d n d1 p)
;d:等分距离或者分段数(用负整数表示)
(if (and obj d)
(progn
(setq obj (vlax-ename->vla-object obj))
(setq d0 (vlax-curve-getDistAtParam obj (vlax-curve-getEndParam obj)))
(if (< d 0)
(progn
(setq d (abs d) n 0 d0 (/ d0 d))
(while (< n (1- d))
(setq n (1+ n) p (append p (list (vlax-curve-getpointatdist obj (* d0 n)))))
)
)
(progn
(setq d1 0)
(while (< d1 d0)
(setq d1 (+ d1 d) p (append p (list (vlax-curve-getpointatdist obj d1))))
)
)
)
(setq p (append (list (vlax-curve-getstartpoint obj)) p (list (vlax-curve-getendpoint obj))))
)
)
(vl-remove nil p)
)
(defun fy_ssExplode ;分解选择集,带过滤表,返回最后处理的集
(ss fil / lst1 lst2 ent)
;ss选择集 能分解的类型lst表
;(fy_PutDxf (fy_ssExplode (ssget) '("INSERT" "WIPEOUT" "REGION" "HATCH" "DIMENSION")) 62 1)
(setq lst1 (fy_enlst ss)) ;获得图元名表
(while (fy_2List_Inter (mapcar '(lambda(x) (fy_GetDxf x 0)) lst1) fil 0.01) ;两个表的共有元素
(foreach e lst1
(cond
((and (member (fy_GetDxf e 0) fil) (= (fy_GetDxf e 0) "HATCH") (= (fy_GetDxf e 2) "SOLID"))
(setq lst2 (append lst2 (list e)))
(setq lst1 (vl-remove e lst1))
)
((member (fy_GetDxf e 0) fil)
(setq ent (entlast))
((if command-s command-s vl-cmdf) "._explode" e)
(setq lst1 (append lst1 (fy_EntNextAll ent)))
(setq lst1 (vl-remove e lst1))
)
(t
(setq lst1 (append lst1 (list e)))
)
)
)
)
(fy_enlst (append lst1 lst2))
)
(defun fy_enlst ;选择集与图元名表互转
(ss / enlst)
(cond
((= (type ss) 'PICKSET)
(vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex ss)))
)
((= (type ss) 'LIST)
(setq enlst (ssadd))
(last (mapcar '(lambda (x) (ssadd x enlst)) ss))
)
)
)
(defun fy_2List_Inter ;返回两个表的共有元素(交集、带容差) by marting
(l1 l2 fuzz)
;参数说明: l1 ---- 表
;l2 ---- 表
;fuzz --- 实数
;返回值: 表 或 nil
(vl-remove-if-not
'(lambda (x)
(setq aa (fy_member_if '(lambda(y) (equal x y fuzz)) l2))
)
l1
)
)
(defun fy_member_if ;支持函数的member by marting
(f l / ff r i $zz)
;参数说明:
;f ---- 原子或函数
;l ---- 表
;备注: 如果参数是原子，如整数、实数，字符串等，同member
;(fy_member_if '(lambda(x)(equal x 4 1e-1)) '(1 2 4.01 5 2 3))
;(4.01 5 2 3)
(if (= (atom f) (setq r (member f l)))
(progn (setq i -1)
(setq ff '(lambda ($zz)
(setq i (1+ i))
(if (apply f (list $zz))
(setq r $zz)
)
)
)
(if (vl-some ff l)
(setq r (fy_List_nB l i))
)
)
)
r
)
(defun fy_List_nB ;返回第N个元素之后的所有元素(包括N) by Lispboy
(lst n / lst1 i L)
;;测试: (fy_List_nB '(2334 556 33 33 44 44 66 77 22) 3) ==> (33 44 44 66 77 22)
(setq L (length lst))
(cond
((< n 1) lst)
((= n 1) (cdr lst))
((= n 2) (cddr lst))
((= n 3) (cdddr lst))
((= n 4) (cddddr lst))
((and (>= n 5) (< n L))
(setq i 0)
(if (< n (/ L 2.0))
(progn
(while (and (setq a (car lst)) (< i n))
(setq lst (cdr lst) i (1+ i))
)
lst
)
(progn
(setq lst (reverse lst))
(while (and (setq a (car lst)) (< i (- L n)))
(setq lst1 (cons a lst1) lst (cdr lst) i (1+ i))
)
lst1
)
)
)
)
)
(defun fy_Z0 ;选择集、Z轴归0(command版,AutoCAD2010有样条曲线的图容易闪退)
(ss / oldcmd)
(setq oldcmd (getvar "cmdecho"))
(setvar "cmdecho" 0)
(if ss
(vl-cmdf "._move" ss "" "_non" '(0 0 1e99) "" "._move" ss "" "_non" '(0 0 -1e99) "")
)
(setvar "cmdecho" oldcmd)
(princ)
)
(defun fy_GetCurveint ;获得任何曲线交点 by mccad
(ent_1 ent_2 / intpoints n ptlist)
(vl-load-com) ;提供一个用ax的方法，对所有曲线均有效
(if (= (type ent_1) 'ENAME) (setq ent_1 (vlax-ename->vla-object ent_1)))
(if (= (type ent_2) 'ENAME) (setq ent_2 (vlax-ename->vla-object ent_2)))
(setq intpoints (vlax-variant-value (vla-intersectwith ent_1 ent_2 acextendnone)))
(cond ((> (vlax-safearray-get-u-bound intpoints 1) 0)
(setq n 0)
(repeat (/ (+ 1 (- (vlax-safearray-get-u-bound intpoints 1) (vlax-safearray-get-l-bound intpoints 1))) 3)
(setq ptlist (cons (list (vlax-safearray-get-element intpoints n)
(vlax-safearray-get-element intpoints (+ 1 n))
(vlax-safearray-get-element intpoints (+ 2 n))
) ptlist))
(setq n (+ 3 n))
)
)
)
(if ptlist
(progn
(if (and (= (length ptlist) 2) (equal (car ptlist) (cadr ptlist) 0.001))
(setq ptlist (cdr ptlist))
)
ptlist
)
nil
)
)
(defun fy_GetBox ;返回最大外型两对角点的表
(SS1 / fy_GetssBox fy_GetEnBox fy_GetExtents)
(defun fy_GetssBox ;返回集最大外框两对角点的表
(ss / boxlst maxlst minlst objlst)
(setq objlst (mapcar 'vlax-ename->vla-object (fy_enlst ss)))
(setq boxlst (mapcar 'fy_GetEnBox objlst))
(setq minlst (mapcar 'car boxlst))
(setq maxlst (mapcar 'cadr boxlst))
(list
(apply 'mapcar (cons 'min minlst))
(apply 'mapcar (cons 'max maxlst))
)
)
(defun fy_GetEnBox (obj) ;返回对象最大外框两对角点的表
(if (= (type obj) 'ENAME) (setq obj (vlax-ename->vla-object obj)))
(vla-getboundingbox obj 'Minp 'Maxp)
(mapcar 'vlax-safearray->list (list Minp Maxp))
)
(defun fy_GetExtents(lst) ;返回点表最大外框两对角点的表
(list
(apply 'mapcar (cons 'min lst))
(apply 'mapcar (cons 'max lst))
)
)
(cond
((= (type SS1) 'PICKSET) (fy_GetssBox SS1)) ;集
((= (type SS1) 'ENAME) (fy_GetEnBox SS1)) ;图元
((= (type SS1) 'VLA-object) (fy_GetEnBox (vlax-vla-object->ename SS1))) ;vla对象
((= (type SS1) 'LIST) (fy_GetExtents SS1)) ;点表
(t nil)
)
)
(defun fy_m2p ;得到二维两点的中心坐标
(p1 p2)
(mapcar '(lambda (a b) (* (+ a b) 0.5)) p1 p2)
)
(defun fy_maketext ;生成一个text
(str pt gao ang wfac angx att st / p0 p1 y1 y2)
;例：(fy_maketext 文字 三维点 字高 旋转角度 宽度因子 倾斜角度 对齐样式 字型)
;(fy_maketext "test" (getpoint) (getvar "TEXTSIZE") 0 1 0 14 (getvar "TEXTSTYLE"))
;当前字型 (getvar "TEXTSTYLE")
;对齐样式：0:中心，11:左上，12:左中，13:左下，14:左下，21:中上，22:正中，23:中下，31:右上，32:右中，33:右下
;旋转角度与倾斜：以(度)为单位
(setq
p0 (append '(10) pt) ;插入点
p1 (append '(11) pt) ;插入点
gao (cons '40 gao) ;字高
str (cons '1 str) ;文字内容
angx (cons '51 (* pi (/ angx 180.0))) ;倾斜角度
ang (cons '50 (* pi (/ ang 180.0))) ;旋转角度
wfac (cons '41 wfac) ;宽度因子
)
(if (not st) (setq st "standard"))
(setq st (cons '7 st)) ;字型
(cond ;对齐样式
((= att 0) (setq y1 (cons 72 4) y2 (cons 73 0)))
((= att 11) (setq y1 (cons 72 0) y2 (cons 73 3)))
((= att 12) (setq y1 (cons 72 0) y2 (cons 73 2)))
((= att 13) (setq y1 (cons 72 0) y2 (cons 73 1)))
((= att 14) (setq y1 (cons 72 0) y2 (cons 73 0)))
((= att 21) (setq y1 (cons 72 1) y2 (cons 73 3)))
((= att 22) (setq y1 (cons 72 1) y2 (cons 73 2)))
((= att 23) (setq y1 (cons 72 1) y2 (cons 73 1)))
((= att 31) (setq y1 (cons 72 2) y2 (cons 73 3)))
((= att 32) (setq y1 (cons 72 2) y2 (cons 73 2)))
((= att 33) (setq y1 (cons 72 2) y2 (cons 73 1)))
)
(entmakex (list '(0 . "TEXT") '(71 . 0) str p0 p1 gao ang wfac angx y1 y2 st))
)
(defun fy_makeline ;生成一条line
(pt1 pt2)
;;参数：pt1:起点，pt2:终点,均为三维点,即(x y z)
(entmakex (list '(0 . "line") (cons 10 pt1) (cons 11 pt2)))
)
(defun fy_makecircle ;生成一个circle
(pt r / ent)
;;参数：pt:圆心(三维点即(x y z))，r:半径
(entmakex (list '(0 . "circle") (cons 10 pt) (cons 40 r)))
)
(defun fy_makerec ;生成矩形
(p1 p2)
(entmakex
(list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 4)
'(70 . 1)
'(43 . 0.0)
'(38 . 0.0)
'(39 . 0.0)
(cons 10 (trans (list (car p1) (cadr p1)) 1 0))
(cons 10 (trans (list (car p2) (cadr p1)) 1 0))
(cons 10 (trans (list (car p2) (cadr p2)) 1 0))
(cons 10 (trans (list (car p1) (cadr p2)) 1 0))
)
)
)
(defun fy_AddBlock ;用[选择集/obj表]做成一个块 ;by fsxm
(ss_or_objlst name InsertionPoint del / block blocks doc)
;ss_or_objlst 选择集或objlst表
;name：块名，匿名块为："*U"
;del：T删除原对象，nil不删除原对象
(setq doc (vla-get-activedocument (vlax-get-acad-object)))
(if (atom ss_or_objlst) ;如果不是表
(setq ss_or_objlst (mapcar 'vlax-ename->vla-object (fy_enlst ss_or_objlst)))
)
(setq blocks (vla-get-Blocks doc))
(setq block (vla-add Blocks (vlax-3d-point InsertionPoint) name))
(vlax-invoke doc 'CopyObjects ss_or_objlst block)
(if del (mapcar 'vla-delete ss_or_objlst)) ;删除选择集
block
)
(defun fy_Dynamic ;动态对象函数
(#Kwd #data #cursor / #key #mode #Run #val #i_i #lst #Left #Right)
;参数 #Kwd 一触即发关键字 '("DYNAMIC" "A" "B") 第一个"DYNAMIC"为当鼠标移动时
;参数 #data 关键字表Kwd对应运行的程序,相当于assco提取data表,注顺序对应
;参数 #Left 点击鼠标左键动作,并结束动态
;参数 #Right 点击鼠标右键动作,并结束动态
;参数 #cursor 是grread后面的参数,控制光标的显示
;全局变量 tPt: 鼠标移动点 :key:按键
;(回车"\r") (空格" ") (backspace "\010") (Tab "\t") (按了键盘 "\002")
;看看按了啥：(while T (princ "\n") (princ (grread T 8))) (chr 数值)查键
(setq #Kwd (mapcar 'strcase #Kwd) #run t #i_i t)
(if (member "LEFT" #Kwd) (setq #Left "LEFT") (setq #Left nil))
(if (member "RIGHT" #Kwd) (setq #Right "RIGHT") (setq #Right nil))
(foreach en #Kwd
(setq #lst (cons (cons en (car #data)) #lst) #data (cdr #data))
)
(while (and #Run (setq #mode (grread t 12 #cursor) #val (cadr #mode) #mode (car #mode)))
(if (null #i_i)
(cond
((= #mode 5) (setq tPt: (trans #val 1 0) #key "DYNAMIC")) ;鼠标移动
((= #mode 2) (setq #key (car (member (setq :key: (strcase (chr #val))) #Kwd)))) ;按了键盘
((= #mode 3) (if #Left (setq #key #Left)) (setq #Run nil)) ;鼠标左键
((= #mode 12) (if #Right (setq #key #Right)) (setq #Run nil)) ;鼠标右键
)
(setq #i_i nil)
)
(if (and #key (assoc #key #lst)) (eval (cdr (assoc #key #lst))))
)
(princ)
)
(defun fy_LispVar(v) ;由ActiveX变体返回LISP值
(cond
((= (type v) 'variant)
(fy_LispVar (variant-value v))
)
((= (type v) 'safearray)
(mapcar 'fy_LispVar (safearray-value v)))
(T v)
)
)
(defun fy_DclGetkeys ;每个控件赋一个变量xx_后缀 ;by nonsmall
(keylst _str / key)
;keylst：key表
;_str：变量的后缀
(if (not _str) (setq _str "_bak"))
(foreach key keylst
(set (read (strcat key _str)) (get_tile key))
)
)
(defun fy_DclAction ;还原控件+控件触发动作 ;by nonsmall
(keylst _str)
;keylst：key表
;_str：变量的后缀
(if (not _str) (setq _str "_bak"))
(foreach key keylst
(if (eval (read (strcat key _str))) (set_tile key (eval (read (strcat key _str)))))
(action_tile key "(Action_Keys $key $value)")
)
)
(defun fy_DclHelp ;帮助窗口
(title str_lst / dcl_id lst2)
(if (= (type str_lst) 'STR) (setq str_lst (list str_lst)))
(setq lst2 (vl-sort str_lst (function (lambda (a b) (> (strlen a) (strlen b)))))) ;找出最长字符串
(setq width (+ (strlen (car lst2)) 2))
(setq height (+ (length str_lst) 2))
(if (> height 50) (setq height 50))
(setq dcl_id (fy_DclWrite
(list "DclHelp:dialog{label=" title
";:list_box{width=" (rtos width)
";key =\"lst\";height=" (rtos height)
";}:row{spacer_1;spacer_1;:button{label=\"确定\";key =\"cancel\";is_cancel=true;height=2;}spacer_1;spacer_1;}}"
)
)
)
(new_dialog "DclHelp" dcl_id)
(fy_DclList "lst" str_lst)
(if (= (start_dialog) 0) (unload_dialog dcl_id))
(princ)
)
(defun fy_DclWrite ;临时生成Dcl文件,返回dcl_id ;by nonsmall
(lst / dcl_file file str dcl_id dcl-name)
(vl-load-com)
(setq dcl_file (vl-filename-mktemp nil nil ".dcl"))
(setq file (open dcl_file "w"))
(foreach str lst (write-line str file))
(close file)
(setq dcl_id (load_dialog dcl_file)) ;对话框加载
(vl-file-delete dcl_file) ;加载后删除dcl文件
;(setq dcl-name (substr (car lst) 1 (vl-string-search ":dialog" (car lst))))
;(new_dialog dcl-name dcl_id)
dcl_id
)
(defun fy_DclNoEnabled ;关闭控件
(keylist / key)
(foreach key keylist (mode_tile key 1))
)
(defun fy_DclEnabled ;激活控件
(keylist / key)
(foreach key keylist (mode_tile key 0))
)
(defun fy_DclList ;填写对话框的表
(key keylst)
(start_list key)
(mapcar 'add_list keylst)
(end_list)
)
(defun fy_tbl ;符号表
(tbl / lay layer layname)
;"LAYER"、"LTYPE"、"VIEW"、"STYLE"、"BLOCK"、"UCS"、"APPID"、"DIMSTYLE" "VPORT"
(setq layer nil lay (tblnext tbl T))
(while (/= lay nil)
(setq layname (cdr (assoc 2 lay))
layer (cons layname layer)
lay (tblnext tbl)
)
)
(setq layer (acad_strlsort layer))
)
(defun fy_sssu ;选择集相减 by kkq0305
(ss1 ss2 / n en)
;[返回] ss1除去ss2之后选择集 或者 nil
(setq n 0)
(while (setq en (ssname ss1 n))
(and (ssmemb en ss2)
(ssdel en ss1)
(setq n (1- n))
)
(setq n (1+ n))
)
ss1
)
(defun fy_ssJoin ;选择集合并，返回合并后选择集，参数 选择集 图元都可以 by Gu_xl
(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
)
)
(defun fy_ini2Roman ;整数转罗马数字字符串 by mahuan1279
(N / str)
;;参数: N 整数
;;返回值: 字符串
;(setq str (list "Ⅰ" "Ⅱ" "Ⅲ" "Ⅳ" "Ⅴ" "Ⅵ" "Ⅶ" "Ⅷ" "Ⅸ" "Ⅹ" "Ⅺ" "Ⅻ"))
;(mapcar 'vl-string->list str) ;==>((162 241) (162 242) (162 243) (162 244) (162 245) (162 246) (162 247) (162 248) (162 249) (162 250) (162 251) (162 252))
;(setq str (list "1" "2" "3" "4" "5" "6" "7" "8" "9" "10" "11" "12"))
;(mapcar 'vl-string->list str) ;==>((49) (50) (51) (52) (53) (54) (55) (56) (57) (49 48) (49 49) (49 50))
(setq str "")
(cond
((>= N 1000) (progn (repeat (/ N 1000) (setq str (strcat "M" str))) (setq str (strcat str (fy_ini2Roman (rem N 1000))))))
((and (> 1000 N) (>= N 900)) (setq str (strcat "CM" (fy_ini2Roman (rem (- N 900) 1000)))))
((and (> 900 N) (>= N 500)) (setq str (strcat "D" (fy_ini2Roman (rem (- N 500) 1000)))))
((and (> 500 N) (>= N 400)) (setq str (strcat "CD" (fy_ini2Roman (rem (- N 400) 100)))))
((and (> 400 N) (>= N 100)) (progn (repeat (/ N 100) (setq str (strcat "C" str))) (setq str (strcat str (fy_ini2Roman (rem N 100))))))
((and (> 100 N) (>= N 90)) (setq str (strcat "XC" (fy_ini2Roman (rem (- N 90) 10 )))))
((and (> 90 N) (>= N 50)) (setq str (strcat "L" (fy_ini2Roman (rem (- N 50) 100)))))
((and (> 50 N) (>= N 40)) (setq str (strcat "XL" (fy_ini2Roman (rem (- N 40) 10)))))
((and (> 40 N) (>= N 10)) (progn (repeat (/ N 10) (setq str (strcat "X" str))) (setq str (strcat str (fy_ini2Roman (rem N 10))))))
((and (> 10 N) (>= N 9)) (setq str (strcat "IX" (fy_ini2Roman (rem (- N 9) 10)))))
((and (> 9 N) (>= N 5)) (setq str (strcat "V" (fy_ini2Roman (rem (- N 5) 10)))))
((and (> 5 N) (>= N 4)) (setq str (strcat "IX" (fy_ini2Roman (rem (- N 4) 10)))))
(t (progn (if (= N 0) (setq str "") (repeat N (setq str (strcat "I" str))))))
)
)
(defun fy_Roman2ini ;罗马数字字符串转为整数，不进行合法性判断 by freedom_ice
(str / n num roman_digit_dic i j)
;;参数: str 罗马数字字符串
;;返回值: 整数
(setq roman_digit_dic
(list (cons "I" 1)
(cons "V" 5)
(cons "X" 10)
(cons "L" 50)
(cons "C" 100)
(cons "D" 500)
(cons "M" 1000)
)
)
(if (assoc str roman_digit_dic)
(cdr (assoc str roman_digit_dic))
(progn
(setq n 1 num 0)
(repeat (- (strlen str) 1)
(setq i (cdr (assoc (substr str n 1) roman_digit_dic)))
(setq j (cdr (assoc (substr str (+ n 1) 1) roman_digit_dic)))
(if (< i j)
(setq num (- num i))
(setq num (+ num i))
)
(setq n (1+ n))
)
(setq num (+ num j))
)
)
)
(princ "\n局部放大v1.3.7，命令gb")
(princ) |
|
|Archiver|手机版|中国膜结构网_中国空间膜结构协会
发表于 2024-4-8 21:29:25