请教高手，对原来的一个程序如何进行改动才能实现新的功能：

hlzhong · 发表于 2003-6-5 08:34:00

请教高手，对原来的一个程序如何进行改动才能实现新的功能。具体情况如下：
下列程序是以前的一个程序，可以通过在CAD中交互框选一空间平面体而返回一点表（表中为各顶点坐标值），而现在我为了在各点坐标值中找一个z坐标最小（即最靠后）的点，并将该空间平面体从该点移到原点，所以在程序最后加了2条语句：(setq A (car (vl-sort PT_LIST '(lambda (z1 z2)(< (caddr z1)(caddr z2))))) )
(command "move" "all" "" A  '(0 0 0) "")
) 这样可以实现该形体按要求移动到原点，但是出现新的问题是：我希望修改后的程序象原来的程序那样能返回一个点表（为移动到原点后各顶点坐标值的点表）以便后续程序能继续从中读取各顶点的坐标值。不知该对下述程序进行如何修改？（注：我只希望程序执行初进行一次选择（框选），否则就可以另外操作一次再调用一次原来的程序得到移动后的形体顶点了。） (defun C:tts (/ SS SS1 N N1 NN ENT CHECK TMP PT_LIST A )

  (command "explode" "all" "")
  (command "explode" "all" "")
  (command "explode" "all" "")

  (defun DO_IT1 ()
(if (not
  (member (setq TMP (cdr (assoc 10 (entget ENT)))) PT_LIST)
)
   (setq PT_LIST (append PT_LIST (list TMP)))
)
(if (not
  (member (setq TMP (cdr (assoc 11 (entget ENT)))) PT_LIST)
)
   (setq PT_LIST (append PT_LIST (list TMP)))
)
  )
  (setq SS (ssget '((0 . "polyline,line,lwpolyline"))))
  (setq PT_LIST '())
  (setq N 0)
  (repeat (sslength SS)
(setq ENT (ssname SS N))
(setq CHECK (cdr (assoc 100 (reverse (entget ENT)))))
(cond
   ((= CHECK "AcDbPolygonMesh")
   (command "_.COPY" ENT "" "0,0" "@")
   (command "_.EXPLODE" (entlast))
   (setq SS1 (ssget &quot"))
   (setq N1 0)
   (repeat (sslength SS1)
(setq ENT (entget (ssname SS1 N1)))
(setq NN 0)
(repeat 4
(if
   (not (member (setq TMP (cdr (assoc (+ 10 NN) ENT))) PT_LIST)
   )
   (setq PT_LIST (append PT_LIST (list TMP)))
)
(setq NN (1+ NN))
)
(setq N1 (1+ N1))
   )
   (command "_.ERASE" SS1 "")
   )
   ((OR(= CHECK "AcDb3dPolyline")
      (= (CDR (ASSOC 0 (ENTGET ENT))) &quotOLYLINE")
      (= (CDR (ASSOC 0 (ENTGET ENT))) "LWPOLYLINE"))
   (command "_.COPY" ENT "" "0,0" "@")
   (command "_.EXPLODE" (entlast))
   (setq SS1 (ssget &quot"))
   (setq N1 0)
   (repeat (sslength SS1)
(setq ENT (ssname SS1 N1))
(DO_IT1)
(setq N1 (1+ N1))
   )
   (command "_.ERASE" SS1 "")
   )
   (t
   (DO_IT1)
   )
)
(setq N (1+ N))
  )

(setq A (car (vl-sort PT_LIST '(lambda (z1 z2)(< (caddr z1)(caddr z2))))) )
(command "move" "all" "" A  '(0 0 0) "")
)

王咣生 · 发表于 2003-6-6 08:58:00

在执行最后两行代码之前,依据PT_LIST 作一条辅助的LWPOLYLINE或POLYLINE,在执行move平移操作的同时,也移动新生成的LWPOLYLINE或POLYLINE。移动后,得到多义线的坐标表就是PT_LIST 移动之后的点表.

王咣生 · 发表于 2003-6-9 10:09:00

(defun C:tts (/ SS SS1 N N1 NN ENT CHECK TMP PT_LIST pt plobj new_PT_LIST A )

  (command "explode" "all" "")
  (command "explode" "all" "")
  (command "explode" "all" "")

  (defun DO_IT1 ()
(if (not
  (member (setq TMP (cdr (assoc 10 (entget ENT)))) PT_LIST)
)
   (setq PT_LIST (append PT_LIST (list TMP)))
)
(if (not
  (member (setq TMP (cdr (assoc 11 (entget ENT)))) PT_LIST)
)
   (setq PT_LIST (append PT_LIST (list TMP)))
)
  )
  (setq SS (ssget '((0 . "polyline,line,lwpolyline"))))
  (setq PT_LIST '())
  (setq N 0)
  (repeat (sslength SS)
(setq ENT (ssname SS N))
(setq CHECK (cdr (assoc 100 (reverse (entget ENT)))))
(cond
   ((= CHECK "AcDbPolygonMesh")
   (command "_.COPY" ENT "" "0,0" "@")
   (command "_.EXPLODE" (entlast))
   (setq SS1 (ssget &quot"))
   (setq N1 0)
   (repeat (sslength SS1)
(setq ENT (entget (ssname SS1 N1)))
(setq NN 0)
(repeat 4
(if
   (not (member (setq TMP (cdr (assoc (+ 10 NN) ENT))) PT_LIST)
   )
   (setq PT_LIST (append PT_LIST (list TMP)))
)
(setq NN (1+ NN))
)
(setq N1 (1+ N1))
   )
   (command "_.ERASE" SS1 "")
   )
   ((OR(= CHECK "AcDb3dPolyline")
      (= (CDR (ASSOC 0 (ENTGET ENT))) &quotOLYLINE")
      (= (CDR (ASSOC 0 (ENTGET ENT))) "LWPOLYLINE"))
   (command "_.COPY" ENT "" "0,0" "@")
   (command "_.EXPLODE" (entlast))
   (setq SS1 (ssget &quot"))
   (setq N1 0)
   (repeat (sslength SS1)
(setq ENT (ssname SS1 N1))
(DO_IT1)
(setq N1 (1+ N1))
   )
   (command "_.ERASE" SS1 "")
   )
   (t
   (DO_IT1)
   )
)
(setq N (1+ N))
  )
  ;;;
  (command "_.PLINE")
  (foreach pt PT_LIST
(command pt)
  )
  (command "")
  (setq plobj (entlast))
  ;;;
(setq A (car (vl-sort PT_LIST '(lambda (z1 z2)(< (caddr z1)(caddr z2))))) )
(command "move" "all" "" A  '(0 0 0) "")
;;;
(setq plobj (entlast))
(setq new_PT_LIST (GetListOfPline plobj))
(entdel plobj)
new_PT_LIST
)
(defun GetListOfPline (EntityName / SSE_Pline N newEntityName)
  (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)) &quotOLYLINE")
(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)
  )

龙龙仔 · 发表于 2003-6-10 07:58:00

;;------------------------------------------------------------------
  (setq       A (car
         (setq
            PT_LIST (vl-sort PT_LIST
                           '(lambda (Z1 Z2) (< (caddr Z1) (caddr Z2)))
                  )
         )
      )
  )
  (command "move" "all" "" A '(0 0 0))
  (mapcar '(lambda (X)
         (mapcar '- X A)
         )
      PT_LIST
  )
;;------------------------------------------------------------------

请教高手，对原来的一个程序如何进行改动才能实现新的功能：

发表回复

精选推荐