(DEFUN C:TirmViaLWP(/ old_cmd Ename loop)
(SETQ old_cmd (GETVAR "CMDECHO"))
(SETVAR "CMDECHO" 0)
;(SETQ Ename (CAR (ENTSEL "\n选择裁图范围:")))
(SETQ loop 1)
(WHILE loop
(SETQ ObjPos (ENTSEL "\n选择裁图范围 :"))
(COND
((NULL ObjPos) (PROMPT "已选择0个, 找到0个"))
((not (member (cdr (assoc 0 (setq ed (entget (setq en (car ObjPos)))))) '("POLYLINE" "LWPOLYLINE")) )
(prompt ": 目标不是多义线!"))
(t (setq loop nil))
)
)
(SETQ Ename (CAR ObjPos))
(TrimByFence0 (GetListOfPline0 Ename))
(SETVAR "CMDECHO" old_cmd)
(PRINC)
)
;;;******************************************
;;;**************剪裁并删除图外线状物体的子函数****
;;;******************************************
(DEFUN TrimByFence0(knownCoordList / Count OFFSETDIST BoundaryLine newExtent newCoordList COORD objSequence)
(SETVAR "PLINETYPE" 2)
(SETQ Count 0)
(COMMAND "ZOOM" "E")
;;;;;;;;裁减21次
(REPEAT 21
(SETQ OFFSETDIST (- 2 (* 0.095 Count)))
(SETQ BoundaryLine (GetLwPlineFromList0 knownCoordList))
(COMMAND "OFFSET" OFFSETDIST BoundaryLine "-1000,-1000" "")
(SETQ newExtent (ENTLAST))
(SETQ newCoordList (GetListOfPline0 newExtent) )
(SETQ objSequence 0)
(SETQ COORD (NTH objSequence newCoordList))
(COMMAND "TRIM" BoundaryLine "" "F")
(WHILE COORD
(COMMAND COORD)
(SETQ objSequence (+ objSequence 1))
(SETQ COORD (NTH objSequence newCoordList))
)
(SETQ COORD (NTH 0 newCoordList))
(COMMAND COORD "" "" "ERASE" BoundaryLine newExtent "")
(SETQ Count (+ Count 1))
)
;;;;再以外扩0.1的多边形为基础进行裁切(每次offset 0.01,共10次)
(SETQ Count 0)
(REPEAT 10
(SETQ OFFSETDIST (- 0.1 (* 0.01 Count)))
(SETQ BoundaryLine (GetLwPlineFromList0 knownCoordList))
(COMMAND "OFFSET" OFFSETDIST BoundaryLine "-1000,-1000" "")
(SETQ newExtent (ENTLAST))
(SETQ newCoordList (GetListOfPline0 newExtent) )
(SETQ objSequence 0)
(SETQ COORD (NTH objSequence newCoordList))
(COMMAND "TRIM" BoundaryLine "" "F")
(WHILE COORD
(COMMAND COORD)
(SETQ objSequence (+ objSequence 1))
(SETQ COORD (NTH objSequence newCoordList))
)
(SETQ COORD (NTH 0 newCoordList))
(COMMAND COORD "" "" )
(COMMAND "ERASE" BoundaryLine newExtent "")
(SETQ Count (+ Count 1))
)
;;;;;;得到最大最小坐标,得到内扩0.1的线坐标表
(setq CenterSeg (GetCoordnateOfBLTR0 knownCoordList))
(setq point-BL (car CenterSeg)
point-TR (cadr CenterSeg))
(setq Xmax (car point-TR)
Ymax (cadr point-TR)
Xmin (car point-BL)
Ymin (cadr point-BL))
;;;得到范围的中心点
(setq point-Center (list (/ (+ (car point-BL) (car point-TR)) 2) (/ (+ (cadr point-BL) (cadr point-TR)) 2)))
(SETQ BoundaryLine (GetLwPlineFromList0 knownCoordList))
(COMMAND "OFFSET" "0.01" BoundaryLine point-Center "")
(SETQ newExtent (ENTLAST))
(setq In-CoordList (GetListOfPline0 (ENTLAST)))
(COMMAND "ERASE" BoundaryLine newExtent "")
***********************************************************************************
;;;;;删除剩下的与边界搭上且在边界外的实体;;;;;;;;;;;;;;;;;
;;;;;;思路:先取出找出宽度大于0的线,记录有Num-Wider条,一条一条的将宽度变为0
;;;;;;再取出与扩展后的边界相交的线(用"F"过滤),
;;;;;;用undo命令Num-Wider次,将宽度改回原来的宽度,删除与扩展后的边界相交的线
(setq p1 (nth 0 newcoordlist))
(setq newcoordlist (append newcoordlist (list p1)))
;;;;ss-Wider为宽度大于0的线
(setq ss-Wider (ssget "F" newCoordList
'((-4 . "<or")
(-4 . "<and")
(-4 . "<or")
(0 . "LINE")(0 . "POLYLINE")(0 . "LWPOLYLINE")
(-4 . "or>")
(-4 . "<or")
(-4 . ">")(40 . 0.0)(-4 . ">")(41 . 0.0)
(-4 . "or>")
(-4 . "and>")
(-4 . "or>"))
))
(setq Num-Wider 0) ;;;;;;Num-Wider为宽度大于0的线段
(if ss-Wider
(progn
(setq i 0)
(setq Num-Wider (sslength ss-Wider))
(repeat Num-Wider
(setq ss-every (ssname ss-Wider i))
(setq sse-every (entget ss-every))
(command "pedit" ss-every "w" "0" "")
(setq i (+ i 1))
)
)
)
;;;;;;ss-must-delete为必须删除的线段
(setq ss-must-delete (ssget "F" newCoordList
'((-4 . "<or")
(0 . "LINE")(0 . "LWPOLYLINE")(0 . "POLYLINE")(0 . "ARC")(0 . "CIRCLE")
(-4 . "or>"))
))
;;;;;;ss-must-keep为必须保留的线段
(setq ss-must-keep nil)
(SETQ ss-must-keep (SSGET "CP" In-CoordList))
(if (= ss-must-keep nil)
(setq ss-must-keep (ssadd))
)
(if (> Num-Wider 0)
(command "undo" Num-Wider)
)
(if ss-must-delete
(command "erase" ss-must-delete "r" ss-must-keep "")
)
;;;;;;;;删除搭界的线段完毕
;;;;;删除图外实体
(SETQ SS1 (SSGET "CP" knownCoordList)) ;;;;;;;ss1为所有范围内实体
(IF (= SS1 nil)
(COMMAND "ERASE" "all" "")
(COMMAND "ERASE" "all" "R" SS1 "")
)
;;;;;删除完毕
***********************************************************************************
)
;;;***********************************************************
;;;;;;;根据折线实体名得到各节点的坐标组成的表的子函数
;;;***********************************************************
(DEFUN GetListOfPline0(EntityName / SSE_Pline Coordnate_Vertex LastList)
(SETQ SSE_Pline (ENTGET EntityName))
(SETQ LastList nil)
(IF (= (CDR (ASSOC 0 SSE_Pline)) "LINE")
(PROGN
(setq p1 (cdr (assoc 10 sse_pline))
p2 (cdr (assoc 11 sse_pline)))
(setq p1 (reverse (cdr (reverse p1)))
p2 (reverse (cdr (reverse p2))))
(SETQ LastList (list p1 p2))
)
)
(IF (= (CDR (ASSOC 0 SSE_Pline)) "LWPOLYLINE")
(PROGN
(SETQ LastList (LIST (LIST 0 0)))
(SETQ N 0)
(WHILE (/= (NTH N SSE_PLINE) NIL)
(IF (= (CAR (NTH N SSE_PLINE)) 10)
(SETQ LastList (APPEND LastList (LIST (LIST (CADR (NTH N SSE_PLINE)) (CADDR (NTH N SSE_PLINE)))) ))
)
(SETQ N (+ N 1))
)
(SETQ LastList (CDR LastList))
)
)
(IF (= (CDR (ASSOC 0 SSE_Pline)) "POLYLINE")
(PROGN
(SETQ LastList (LIST (LIST 0 0)))
(SETQ newEntityName (ENTNEXT EntityName))
(WHILE (= (CDR (ASSOC 0 (ENTGET newEntityName))) "VERTEX")
(SETQ LastList (APPEND LastList (LIST (LIST (CADR (ASSOC 10 (ENTGET newEntityName))) (CADDR (ASSOC 10 (ENTGET newEntityName))) )) ))
(SETQ newEntityName (ENTNEXT newEntityName))
)
(SETQ LastList (CDR LastList))
)
)
(IF (= (CDR (ASSOC 0 SSE_Pline)) "ARC")
(PROGN
(SETQ LastList (LIST (LIST 0 0)))
(COMMAND "PEDIT" EntityName "Y" "" "CONVERT" "P" "S" (ENTLAST) "")
(SETQ SSE_Pline (ENTGET (ENTLAST)))
(SETQ N 0)
(WHILE (/= (NTH N SSE_PLINE) NIL)
(IF (= (CAR (NTH N SSE_PLINE)) 10)
(SETQ LastList (APPEND LastList (LIST (LIST (CADR (NTH N SSE_PLINE)) (CADDR (NTH N SSE_PLINE)))) ))
)
(SETQ N (+ N 1))
)
(SETQ LastList (CDR LastList))
(COMMAND "UNDO" 2)
))
(IF (= (CDR (ASSOC 0 SSE_Pline)) "CIRCLE")
(PROGN
(SETQ Ra1 (CDR (assoc 40 SSE_Pline)))
(SETQ P-Center (CDR (assoc 10 SSE_Pline)))
(SETQ P1 (POLAR P-Center 0 Ra1))
(SETQ P2 (POLAR P-Center (* PI 0.5) Ra1))
(SETQ P3 (POLAR P-Center (* PI 1.0) Ra1))
(SETQ P4 (POLAR P-Center (* PI 1.5) Ra1))
(SETQ LastList (LIST P1 P2 P3 P4))
))
(SETQ LastList LastList)
)
;;;***********************************************************
;;;;;;;;;;;;根据一个坐标表得到一条线的子函数
;;;***********************************************************
(DEFUN GetLwPlineFromList0(knownCoordList / newCoordList MainPline)
(SETVAR "PLINETYPE" 2)
(COMMAND "._PLINE")
(FOREACH newCoordList knownCoordList (COMMAND newCoordList))
(COMMAND "C")
(SETQ MainPline (ENTLAST))
)
;;;***********************************************************
;;;;;;;从坐标表中得到范围的左下角和右上角坐标的子函数
;;;***********************************************************
(DEFUN GetCoordnateOfBLTR0(knownCoordList / CurrenPoint Xmin Ymin Xmax Ymax nowCoordnateList)
(SETQ nowCoordnateList knownCoordList)
(SETQ CurrenPoint (CAR nowCoordnateList)
Xmin (CAR CurrenPoint)
Ymin (CADR CurrenPoint)
Xmax (CAR CurrenPoint)
Ymax (CADR CurrenPoint))
(SETQ nowCoordnateList (CDR nowCoordnateList))
(WHILE (/= nowCoordnateList nil)
(SETQ CurrenPoint (CAR nowCoordnateList))
(IF (< (CAR CurrenPoint) Xmin) (SETQ Xmin (CAR CurrenPoint)))
(IF (< (CADR CurrenPoint) Ymin) (SETQ Ymin (CADR CurrenPoint)))
(IF (> (CAR CurrenPoint) Xmax) (SETQ Xmax (CAR CurrenPoint)))
(IF (> (CADR CurrenPoint) Ymax) (SETQ Ymax (CADR CurrenPoint)))
(SETQ nowCoordnateList (CDR nowCoordnateList))
)
(SETQ nowCoordnateList (LIST (LIST Xmin Ymin)(LIST Xmax Ymax)))
)
jdhszh发表于2007-9-14 10:08:00static/image/common/back.gif隐含模块中的编译错误!工程不可查看!耍人呢?
<p>没有啊，我用起都是正常得很呢</p>
回复：（gdzhou）以下是引用jdhszh在2007-9-14 10:08:...
好象是丢失了什么DLL文件！ scas裁图也很好使。 本帖最后由 作者 于 2007-12-9 2:17:53 编辑唉，在Microstation里 一个 FF=命令就搞定了。还用费那么多功夫。 xgr发表于2007-8-30 0:08:00static/image/common/back.gif试试我的代码(defun c:txjq3 (/ aa oldgroup oldcmd oldblip oldsnap en  
<p>这个能不能做成可加载的程序呀,我是菜鸟呀,不会呢,但经常会用这样的需要,谢谢</p> 本帖最后由 作者 于 2008-1-13 1:33:56 编辑 <br /><br /> <p>不知道，你们的程序能否实现我的效果.在MicroStation里真的很容易裁剪图形。</p><p></p><p></p>http://upload.py99.net/files/38/flash/cutdemo.swf 用CASS有个命令