[VBA]『紧急求助』自动剪切程序

波涛发表于 2005-12-15 15:27:00

本人是从事测绘工作的，经常处理测绘地形图，需要在地形图上进行剪切图形，通过选择一条封闭的多义线，自动把范围内的图形经过剪切写块写出来，现遇到一个问题：在选择到多义线后，如何把与范围线相交的可以剪切的实体进行剪切，我已经能编写到
ThisDrawing.SendCommand "_trim" & vbCr & det1 & vbCr & vbCr & det2 & vbCr & vbCr
det1-----为范围线，det2-----为被剪切对象的点，现在的问题是怎样得到det2，不是通过屏幕点取，而是程序自动求得
在此先谢谢各位，我的邮箱:sunrj-jn@163.com

波涛发表于 2005-12-15 21:27:00

有哪位高手给指点一下迷津，在下不胜感激

波涛发表于 2005-12-17 12:44:00

我的帖子好几天了，也没人理我，是大家不感兴趣，还是别的原因，现我已经找到答案了，如果哪位想知道的话，我们可以交流。

小顽童 发表于 2005-12-18 00:20:00

我想知道，我们交流下可以吗？

clement 发表于 2005-12-21 19:44:00

波涛发表于2005-12-17 12:44:00static/image/common/back.gif我的帖子好几天了，也没人理我，是大家不感兴趣，还是别的原因，现我已经找到答案了，如果哪位想知道的话，我们可以交流。

 楼主获取交点是不是用的类似下面的方法：
objEnt.IntersectWith(objSelect, acExtendNone)

jsnjwang 发表于 2005-12-28 12:24:00

(DEFUN C:CT() (SETQ largeExtentLine (CAR (ENTSEL "请选择范围线:")))
(IF largeExtentLine (progn (PRINC "\n请稍侯...") (SETQ Old_LineType (GETVAR "PLINETYPE")) (SETVAR "PLINETYPE" 2)(SETVAR "CMDECHO" 0)(SETVAR "OSMODE" 0)(SETVAR "CLAYER" "0") (COMMAND "ZOOM" "E" "CONVERT" "P" "")
;;;;;由外范围线得到外扩线的各节点的坐标表及最大和最小坐标 (SETQ newCoordnateList (GetListOfPline0 largeExtentLine)) ;;(SETQ largeMaxMinBLTR (GetCoordnateOfBLTR0 newCoordnateList))
 ;;;;炸碎与已知多义线相交的图块和Region和Hatch (EXPLODEBYFENCE0 newCoordnateList) ;;;;炸碎完毕
;;;;裁剪所有图外实体 (SETQ SSout (TrimByFence0 newCoordnateList)) ;;;;裁剪完毕
(COMMAND "zoom" "e" "PURGE" "A" "" "N" "PURGE" "A" "" "N") (SETVAR "PLINETYPE" Old_LineType) (SETVAR "CLAYER" "0") (princ "\n裁切完毕!")(princ) ) (progn (princ "\n没有选择范围线!!")(princ) ) )
 )
(DEFUN DeleteSetFromSet(firstSet secondSet / firstNum Setobjsequence) (SETQ firstNum (SSLENGTH firstSet)) (SETQ Setobjsequence 0) (REPEAT firstNum (SSDEL (SSNAME firstSet Setobjsequence) secondSet) (SETQ Setobjsequence (+ Setobjsequence 1)) ) (IF (> (SSLENGTH secondSet) 0) (SETQ secondSet secondSet) (SETQ secondSet NIL) ) (SETQ secondSet secondSet) )
(DEFUN GetLwPlineFromList(knownCoordList / newCoordList MainPline) (SETVAR "PLINETYPE" 2) (COMMAND "._PLINE") (FOREACH newCoordList knownCoordList (COMMAND newCoordList)) (COMMAND "C") (SETQ MainPline (ENTLAST)) )
(DEFUN GetListOfPline(EntityName / SSE_Pline Coordnate_Vertex LastList) (SETQ SSE_Pline (ENTGET EntityName)) (SETQ LastList nil) (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)) ) ) (SETQ LastList LastList) )
(DEFUN GetCoordnateOfBLTR(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))) ) 
(DEFUN ExplodeByFence(knownCoordList) (SETQ INSERT_SS (SSGET "F" (APPEND knownCoordList (LIST (NTH 0 knownCoordList))) (LIST (CONS 0 "INSERT")))) ;;将LwPolyline首尾相连append (IF INSERT_SS     (PROGN     (SETQ NUMBER_INSERT (SSLENGTH INSERT_SS))     (SETQ NUM 0)     (REPEAT NUMBER_INSERT (COMMAND "EXPLODE" (SSNAME INSERT_SS NUM)) (SETQ NUM (+ NUM 1))     )     ) ) )
(DEFUN ExplodeAllBLK() (SETQ AllBLK (SSGET "X" (LIST (CONS 0 "INSERT")))) (WHILE (/= AllBLK NIL) (SETQ NumOfAllBLK (SSLENGTH AllBLK)) (SETQ BLKSequence 0) (REPEAT NumOfAllBLK   (COMMAND "EXPLODE" (SSNAME AllBLK BLKSequence))   (SETQ BLKSequence (+ BLKSequence 1)) ) ;;; (COMMAND "EXPLODE" AllBLK) (SETQ AllBLK (SSGET "X" (LIST (CONS 0 "INSERT")))) ) )
(DEFUN TrimByFence(knownCoordList / Count OFFSETDIST BoundaryLine newExtent newCoordList COORD objsequence) (SETVAR "PLINETYPE" 2) (SETQ Count 0) (COMMAND "ZOOM" "E") (REPEAT 21 (SETQ OFFSETDIST (- 2 (* 0.095 Count))) (SETQ BoundaryLine (GetLwPlineFromList knownCoordList)) (COMMAND "OFFSET" OFFSETDIST BoundaryLine "-1000,-1000" "") (SETQ newExtent (ENTLAST))
(SETQ newCoordList (GetListOfPline 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)) ) (SETQ p1 (nth 0 newcoordlist)) (SETQ newcoordlist (append newcoordlist (list p1))) (SETQ ss-leave (ssget "F" newCoordList)) (IF ss-leave (COMMAND "erase" ss-leave "") ) )
 (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 ExplodeAllBLK0() (SETQ AllBLK (SSGET "X" (LIST (CONS 0 "INSERT")))) (WHILE (/= AllBLK NIL) (SETQ NumOfAllBLK (SSLENGTH AllBLK)) (SETQ BLKSequence 0) (REPEAT NumOfAllBLK   (COMMAND "EXPLODE" (SSNAME AllBLK BLKSequence))   (SETQ BLKSequence (+ BLKSequence 1)) ) ;;; (COMMAND "EXPLODE" AllBLK) (SETQ AllBLK (SSGET "X" (LIST (CONS 0 "INSERT")))) ) )
(DEFUN TrimByFence0(knownCoordList / Count OFFSETDIST BoundaryLine newExtent newCoordList COORD objsequence) (SETVAR "PLINETYPE" 2) (SETQ Count 0) (COMMAND "ZOOM" "E")
(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)) )
 (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)) )
(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 "")
(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))   )     ) )
 (setq ss-must-delete (ssget "F" newCoordList   '((-4 . "<or")    (0 . "LINE")(0 . "LWPOLYLINE")(0 . "POLYLINE")(0 . "ARC")(0 . "CIRCLE")   (-4 . "or>")) ))
(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 ExplodeByFence0(knownCoordList)
(SETQ INSERT_SS (SSGET "F" (APPEND knownCoordList (LIST (NTH 0 knownCoordList))) '((-4 . "<or")   (0 . "INSERT")   (0 . "HATCH")   (0 . "REGION") (-4 . "or>")) ));;;
 (IF INSERT_SS     (PROGN     (SETQ NUMBER_INSERT (SSLENGTH INSERT_SS))     (SETQ NUM 0)     (REPEAT NUMBER_INSERT (COMMAND "EXPLODE" (SSNAME INSERT_SS NUM)) (SETQ NUM (+ NUM 1))     )     ) ) )
(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))) )

波涛发表于 2005-12-28 20:37:00

谢谢6楼的无私奉献，由于我是用VBA编写，对lisp不太熟，但大体能看懂一点，与我后来找到的答案类似。由于没带代码，我就把思路说一下：
1。先选择范围线；
2。把范围线用0ffset命令向外偏移0.01(删除范围内的向内偏移0.01)；
3。取出偏移线的各个顶点坐标;
4。利用trim命令的栏选（F）功能，就可以把所有能剪切的实体全部剪切掉

波涛发表于 2005-12-28 20:42:00

IntersectWith 是必须在同一个面才能取得交点，往往地形图都是有高程的，很难取得交点

ljq 发表于 2006-1-3 13:50:00

cad扩展中有现成的命令extrim

mycad 发表于 2006-1-3 16:09:00

cad2006中无extrim吗

页: [1] 2

明经CAD社区's Archiver

[VBA]『紧急求助』自动剪切程序