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

波涛

   本人是从事测绘工作的，经常处理测绘地形图，需要在地形图上进行剪切图形，通过选择一条封闭的多义线，自动把范围内的图形经过剪切写块写出来，现遇到一个问题：在选择到多义线后，如何把与范围线相交的可以剪切的实体进行剪切，我已经能编写到

ThisDrawing.SendCommand "_trim" & vbCr & det1 & vbCr & vbCr & det2 & vbCr & vbCr

det1-----为范围线，det2-----为被剪切对象的点，现在的问题是怎样得到det2，不是通过屏幕点取，而是程序自动求得

在此先谢谢各位，我的邮箱:sunrj-jn@163.com

波涛

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

波涛

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

小顽童

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

clement

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

楼主获取交点是不是用的类似下面的方法：

objEnt.IntersectWith(objSelect, acExtendNone)

jsnjwang

(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)))
)

波涛

谢谢6楼的无私奉献，由于我是用VBA编写，对lisp不太熟，但大体能看懂一点，与我后来找到的答案类似。由于没带代码，我就把思路说一下：

1。先选择范围线；

2。把范围线用0ffset命令向外偏移0.01(删除范围内的向内偏移0.01)；

3。取出偏移线的各个顶点坐标;

4。利用trim命令的栏选（F）功能，就可以把所有能剪切的实体全部剪切掉

波涛

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

ljq

cad扩展中有现成的命令extrim

mycad

cad2006中无extrim吗