乐筑天下

搜索
欢迎各位开发者和用户入驻本平台 尊重版权,从我做起,拒绝盗版,拒绝倒卖 签到、发布资源、邀请好友注册,可以获得银币 请注意保管好自己的密码,避免账户资金被盗
查看: 57|回复: 3

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

[复制链接]

11

主题

21

帖子

4

银币

初露锋芒

Rank: 3Rank: 3Rank: 3

铜币
65
发表于 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) "")   
)
回复

使用道具 举报

124

主题

837

帖子

9

银币

顶梁支柱

Rank: 50Rank: 50

铜币
1333
发表于 2003-6-6 08:58:00 | 显示全部楼层
在执行最后两行代码之前,依据PT_LIST 作一条辅助的LWPOLYLINE或POLYLINE,在执行move平移操作的同时,也移动新生成的LWPOLYLINE或POLYLINE。移动后,得到多义线的坐标表就是PT_LIST 移动之后的点表.
回复

使用道具 举报

124

主题

837

帖子

9

银币

顶梁支柱

Rank: 50Rank: 50

铜币
1333
发表于 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)
  )
回复

使用道具 举报

29

主题

1152

帖子

10

银币

顶梁支柱

Rank: 50Rank: 50

铜币
1268
发表于 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
  )
;;------------------------------------------------------------------
回复

使用道具 举报

发表回复

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

  • 微信公众平台

  • 扫描访问手机版

  • 点击图片下载手机App

QQ|关于我们|小黑屋|乐筑天下 繁体中文

GMT+8, 2025-7-3 11:50 , Processed in 0.568915 second(s), 60 queries .

© 2020-2025 乐筑天下

联系客服 关注微信 帮助中心 下载APP 返回顶部 返回列表