设为首页收藏本站转
发帖领奖家园QQ群申请版主版主评价切换到宽版

 找回密码
 立即注册

QQ登录

只需一步，快速开始

扫一扫，访问微社区

晓东CAD家园-论坛»论坛 › ╃CAD编程开发 › A/VLISP › [弹指神通]：能者不难,望赐教
返回列表 发新帖
查看: 1718|回复: 10

[弹指神通]：能者不难,望赐教

[复制链接]
linhui12
发表于 2008-4-5 22:30:04 | 显示全部楼层 |阅读模式
【广而告之】积分规则、D豆获取攻略       窝窝空间装扮攻略

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要 登录 才可以下载或查看，没有账号？立即注册

×
以下是一个可读取任意线的顶点坐标,并已文本输出的程序,希望大家帮忙改改,让它一行一根线数据而不是一行一个点的数据,我所提取的多义线只有2~4点.写出数据要保证4个点.数据形式如下:
(线)1,x1,y1z1,x2,y2,z2,x3,y3,z3,x4,y4,z4----(点与点间以逗号隔开)
(线)2,x1,y1,z1,x2,y2,z2,x3,y3,z3,x4,y4,z4
(线)3,x1,y1,z1,x2,y2,z2,x3,y3,z3,9999,9999,9999--(点数不够以9999补满)

;[PHP]
;;;;;;;;;;;;;;;根据等高线标高取出数据
(DEFUN C:outh
       (/ SST H fi N I J K p NAME DXF TYPE_LINE XY_COUNT F x y PT1 D N1)
  (setq        fi '((-4 . "<OR")                ; Filter for ssget.
             (0 . "POLYLINE")
             (0 . "LWPOLYLINE")
             (0 . "SHAPE")
             (0 . "INSERT")
             (-4 . "OR>")
            )
  )
(setq F (getfiled "写出文件" 　 "" "txt" 1))
(SETQ F (OPEN F "w"))
  (PROMPT " \n选取等高线:")
  (SETQ SST (SSGET fi))
  (SETQ N (SSLENGTH SST))
  (SETQ J 0)
  (setq k 0)
  (setq p (getint " \n指定起始点号<1>:"))
  (IF (= NIL P)
    (setq p 1)
  )
  (REPEAT N
    (SETQ NAME (SSNAME SST J))
    (SETQ J (1+ J))
    (SETQ DXF (ENTGET NAME))
    (SETQ TYPE_LINE (CDR (ASSOC 0 DXF)))
    (COND (
           (= TYPE_LINE "POLYLINE")
           (SETQ XY_COUNT (POLYLINE DXF NAME))
           (setq i (length xy_count))
           (setq k 0)
           (repeat i
             (setq y (nth k xy_count))
             (setq h (nth 2 y))
             (setq x (nth 1 y))
             (setq y (nth 0 y))
             (setq y (strcat (itoa P)
                             ","
                             (rtos Y 2 3)
                             ","
                             (rtos X 2 3)
                             ","
                             (rtos h 2 3)
                     )
             )
             (write-line y f)
             (setq p (1+ p))
             (setq k (1+ k))
             (setq D D)
             (setq N1 N1)
           )
          )
          ((= TYPE_LINE "LWPOLYLINE")
           (SETQ H (CDR (ASSOC 38 DXF)))
           (SETQ XY_COUNT (LWPOLYLINE DXF))
           (setq i (length xy_count))
           (setq k 0)
           (repeat i
             (setq y (nth k xy_count))
             (setq x (nth 1 y))
             (setq y (nth 0 y))
             (setq y (strcat (itoa P)
                             ","
                             (rtos X 2 3)
                             ","
                             (rtos Y 2 3)
                             ","
                             (rtos h 2 3)
                     )
             )
             (write-line y f)
             (setq p (1+ p))
             (setq k (1+ k))
             (setq D D)
             (setq N1 N1)
           )
          )
          ((OR (= TYPE_LINE "SHAPE") (= TYPE_LINE "INSERT"))
           (SETQ PT1 (CDR (ASSOC 10 DXF)))
           (SETQ X (NTH 1 PT1))
           (SETQ Y (NTH 0 PT1))
           (SETQ H (NTH 2 PT1))
           (setq y (strcat (itoa P)
                           ","
                           (rtos Y 2 3)
                           ","
                           (rtos X 2 3)
                           ","
                           (rtos h 2 3)
                   )
           )
           (write-line y f)
           (setq p (1+ p))
           (setq D D)
           (setq N1 N1)
          )
    )
  )
  (close f)
)
;;;;;;;;;;;;;;;;;;;
(defun POLYLINE        (DXF E1 / XY E2 count_xy pd)
  (setq count_xy nil)
  (SETQ DXF (MEMBER (ASSOC 330 DXF) DXF))
  (SETQ E2 (ENTNEXT E1))
  (SETQ DXF (ENTGET E2))

  (setq e1 (cdr (assoc 0 dxf)))
  (while (= e1 "VERTEX")
    (setq e1 (cdr (assoc 10 dxf)))
    (setq pd (cdr (assoc 70 dxf)))
    (if (/= pd 16)
        (setq count_xy (cons e1 count_xy))
    )
    (setq e1 e2)
    (SETQ E2 (ENTNEXT E1))
    (SETQ DXF (ENTGET E2))
    (setq e1 (cdr (assoc 0 dxf)))
  )
  (setq COUNT_XY (reverse count_xy))
)
;;;;;;;;;;;;;;;;;;;;;;;
(defun LWPOLYLINE (DXF / XY COUNT_XY)
  (SETQ XY (ASSOC 10 DXF))
  (SETQ COUNT_XY ())
  (WHILE XY
    (SETQ DXF (MEMBER XY DXF))
    (SETQ XY (CDR (ASSOC 10 DXF)))
    (SETQ DXF (CDR DXF))
    (SETQ COUNT_XY (CONS XY COUNT_XY))
    (SETQ XY (ASSOC 10 DXF))
  )
  (setq COUNT_XY (reverse COUNT_XY))
)
;;;;;;;;;;;;;
(defun ap-3d->2d (p1 / a b c)
  (setq a (nth 0 p1))
  (setq b (nth 1 p1))
  (setq p1 (list a b))
)

;;;;;;;;;;;;;;;;;
(DEFUN PDINDX (SST    P1     /            DIST   INDX          B         JD        N
               J      K             DIST_SST           MAX_P1 MAX_P2 NAME        INDX
               JD_NEAR             MESG
              )
  (SETQ J 0)
  (SETQ P1 (AP-3D->2D P1))
  (SETQ N (SSLENGTH SST))
  (REPEAT N
    (SETQ B (SSNAMEX SST J))
    (SETQ JD (AP-3D->2D (NTH 0 (CDR (NTH 3 (NTH 0 B))))))

    (SETQ NAME (NTH 1 (NTH 0 B)))
    (SETQ DIST (distance p1 jd))
    (SETQ DIST_SST (CONS DIST DIST_SST))
    (SETQ NAME_SST (CONS NAME NAME_SST))
    (SETQ J (1+ J))
  )
  (SETQ J 0)
  (WHILE (/= J (- N 1))
    (SETQ K 0)
    (WHILE (/= K (- N 1))
      (SETQ MAX_P1 (NTH K DIST_SST))
      (SETQ MAX_P2 (NTH (+ K 1) DIST_SST))
      (IF (> MAX_P1 MAX_P2)
        (PROGN
          (SETQ B (CDR (MEMBER MAX_P2 DIST_SST)))
          (SETQ B (CONS MAX_P1 B))
          (SETQ B (CONS MAX_P2 B))
          (SETQ JD (- K 1))
          (REPEAT K
            (SETQ MAX_P1 (NTH JD DIST_SST))
            (SETQ B (CONS MAX_P1 B))
            (SETQ JD (- JD 1))
          )
          (SETQ DIST_SST B)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
          (SETQ MAX_P1 (NTH K NAME_SST))
          (SETQ MAX_P2 (NTH (+ K 1) NAME_SST))

          (SETQ B (CDR (MEMBER MAX_P2 NAME_SST)))
          (SETQ B (CONS MAX_P1 B))
          (SETQ B (CONS MAX_P2 B))
          (SETQ JD (- K 1))
          (REPEAT K
            (SETQ MAX_P1 (NTH JD NAME_SST))
            (SETQ B (CONS MAX_P1 B))
            (SETQ JD (- JD 1))
          )
          (SETQ NAME_SST B)
        )
      )
      (SETQ K (1+ K))
    )
    (SETQ J (1+ J))
  )
  (SETQ NAME_SST NAME_SST)
)
;[PHP]
setq, COUNT, DXF

相关帖子

论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复

使用道具 举报

zml84

已领礼包: 2个

财富等级: 恭喜发财
发表于 2008-4-8 14:55:02 | 显示全部楼层

  3. ;;;根据等高线标高取出数据
  4. (defun C:OUTH (/ SS F P I EN ENT LX STR STR_H)
  5.     (if        (and (princ " \n选取等高线:")
  6.              (setq
  7.                  SS (ssget '((0 . "POLYLINE,LWPOLYLINE,SHAPE,INSERT")))
  8.              )
  9.              (setq F (getfiled "写出文件" 　 "" "txt" 1))
  10.              (setq F (open F "w"))
  11.         )
  12.         (progn
  13.             (if        (setq P (getint " \n指定起始点号<1>:"))
  14.                 (setq P P)
  15.                 (setq P 1)
  16.             )
  17.             ;;逐个处理
  18.             (setq I 0)
  19.             (repeat (sslength SS)
  20.                 (setq EN  (ssname SS I)
  21.                       ENT (entget EN)
  22.                       LX  (cdr (assoc 0 ENT))
  23.                 )
  24.                 ;;
  25.                 (setq STR (itoa (+ P I)))
  26.                 (if (= LX "LWPOLYLINE")
  27.                     (setq STR_H (rtos (cdr (assoc 38 ENT)) 2 3))
  28.                     (foreach N ENT
  29.                         (if (= (car N) 10)
  30.                             (setq STR (strcat STR
  31.                                               ","
  32.                                               (rtos (cadr N) 2 3)
  33.                                               ","
  34.                                               (rtos (caddr N) 2 3)
  35.                                               ","
  36.                                               STR_H
  37.                                       )
  38.                             )
  39.                         )
  40.                     )
  41.                     (foreach N ENT
  42.                         (if (= (car N) 10)
  43.                             (setq STR (strcat STR
  44.                                               ","
  45.                                               (rtos (cadr N) 2 3)
  46.                                               ","
  47.                                               (rtos (caddr N) 2 3)
  48.                                               ","
  49.                                               (rtos (cadddr N) 2 3)
  50.                                       )
  51.                             )
  52.                         )
  53.                     )
  54.                 )
  55.                 ;;写入内容
  56.                 (write-line STR F)
  57.                 (setq I (1+ I))
  58.             )
  59.             ;;
  60.             (princ (strcat "\n>>>写入完成! " (itoa I) " 个对象。"))
  61.             (close F)
  62.         )
  63.     )
  64.     (princ)
  65. )
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

linhui12
 楼主| 发表于 2008-4-8 17:33:24 | 显示全部楼层
【广而告之】积分规则、D豆获取攻略       窝窝空间装扮攻略
感谢"zm184"的回复,
可是您的程序加载时出错了呀
提示:错误: 参数太多: (IF (= LX "LWPOLYLINE") (SETQ STR_H (RTOS (CDR (ASSOC 38 ENT)) 2 3)) (FOREACH N ENT (IF (= (CAR N) 10) (SETQ STR (STRCAT STR "," (RTOS (CADR N) 2 3) "," (RTOS (CADDR N) 2 3) "," STR_H)))) (FOREACH N ENT (IF (= (CAR N) 10) (SETQ STR (STRCAT STR "," (RTOS (CADR N) 2 3) "," (RTOS (CADDR N) 2 3) "," (RTOS (CADDDR N) 2 3))))))
希望帮忙找找原因,谢谢
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

zml84

已领礼包: 2个

财富等级: 恭喜发财
发表于 2008-4-8 21:11:49 | 显示全部楼层

已改正


  3. ;;;根据等高线标高取出数据
  4. (defun C:OUTH (/ SS F P I EN ENT LX STR STR_H)
  5.     (if        (and (princ " \n选取等高线:")
  6.              (setq
  7.                  SS (ssget '((0 . "POLYLINE,LWPOLYLINE,SHAPE,INSERT")))
  8.              )
  9.              (setq F (getfiled "写出文件" 　 "" "txt" 1))
  10.              (setq F (open F "w"))
  11.         )
  12.         (progn
  13.             (if        (setq P (getint " \n指定起始点号<1>:"))
  14.                 (setq P P)
  15.                 (setq P 1)
  16.             )
  17.             ;;逐个处理
  18.             (setq I 0)
  19.             (repeat (sslength SS)
  20.                 (setq EN  (ssname SS I)
  21.                       ENT (entget EN)
  22.                       LX  (cdr (assoc 0 ENT))
  23.                 )
  24.                 ;;
  25.                 (setq STR (itoa (+ P I)))
  26.                 (if (and (= LX "LWPOLYLINE")
  27.                          (setq STR_H (rtos (cdr (assoc 38 ENT)) 2 3))
  28.                     )
  29.                     (foreach N ENT
  30.                         (if (= (car N) 10)
  31.                             (setq STR (strcat STR
  32.                                               ","
  33.                                               (rtos (cadr N) 2 3)
  34.                                               ","
  35.                                               (rtos (caddr N) 2 3)
  36.                                               ","
  37.                                               STR_H
  38.                                       )
  39.                             )
  40.                         )
  41.                     )
  42.                     (foreach N ENT
  43.                         (if (= (car N) 10)
  44.                             (setq STR (strcat STR
  45.                                               ","
  46.                                               (rtos (cadr N) 2 3)
  47.                                               ","
  48.                                               (rtos (caddr N) 2 3)
  49.                                               ","
  50.                                               (rtos (cadddr N) 2 3)
  51.                                       )
  52.                             )
  53.                         )
  54.                     )
  55.                 )
  56.                 ;;写入内容
  57.                 (write-line STR F)
  58.                 (setq I (1+ I))
  59.             )
  60.             ;;
  61.             (princ (strcat "\n>>>写入完成! " (itoa I) " 个对象。"))
  62.             (close F)
  63.         )
  64.     )
  65.     (princ)
  66. )
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

linhui12
 楼主| 发表于 2008-4-9 16:25:50 | 显示全部楼层
【广而告之】积分规则、D豆获取攻略       窝窝空间装扮攻略
ZM184你好,你的程序使用后提取出来的信息怎么会是以下形式的呢?
1,0,0,0
2,0,0,0
3,0,0,0
4,0,0,0
5,0,0,0
6,0,0,0
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

cy956
发表于 2008-4-10 22:07:07 | 显示全部楼层
你用的是pline线而不是zm184的lwpline线。
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

mayubao2008
发表于 2008-4-10 22:55:41 | 显示全部楼层
【广而告之】积分规则、D豆获取攻略       窝窝空间装扮攻略
太复杂了啊
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

linhui12
 楼主| 发表于 2008-4-11 18:44:27 | 显示全部楼层
大家可否帮忙改改让他实现"POLYLINE"啊,谢谢
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

雨箭风刀
发表于 2008-4-12 00:40:00 | 显示全部楼层
【广而告之】积分规则、D豆获取攻略       窝窝空间装扮攻略
  2. (DEFUN C:ttt (/ E FI I LST P PT SS STR)
  3.   (setq fi '((0 . "*POLYLINE")))        ; Filter for ssget.
  4.   (setq Fn (getfiled "写出文件" "" "txt" 1))
  5.   (SETQ F (OPEN Fn "w"))
  6.   (PROMPT " \n选取等高线:")
  7.   (SETQ SS (SSGET fi))
  8.   (SETQ i -1)
  9.   (IF (not (setq p (getint " \n指定起始点号<1>:")))
  10.     (setq p 1)
  11.   )
  12.   (while (setq i (1+ i)
  13.                e (ssname ss i)
  14.          )
  15.     (setq str (strcat "(线)" (itoa p))
  16.           p   (1+ p)
  17.           ii -1
  18.     )
  19.     (repeat 4
  20.     (if        (setq ii (1+ ii)
  21.               pt (vlax-curve-getpointatparam e ii))
  22.       (setq str        (strcat        str","(rtos (car pt) 2 3)","(rtos (cadr pt) 2 3)","(rtos (caddr pt) 2 3)))
  23.       (setq str (strcat str "," "9999,9999,9999"))
  24.     )
  25.    )
  26.     (setq lst (cons str lst))
  27.   )
  28.   (mapcar '(lambda(x)(write-line x f)) (reverse lst))
  29.   (close f)
  30.   (princ)
  31. )
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

linhui12
 楼主| 发表于 2008-4-12 08:41:50 | 显示全部楼层
非常感谢大家的回复,经测试"雨箭风刀"的程序完全符合要求,谢谢大家.
小弟还有个要求,如果反过来呢,我要用一个程序读取:数据形式如下:
(线)1,14325,-1624,2475,14325,-1851,2475,14930,-2200,2475,14930,-4665,2475
(线)2,14930,-4668,2475,14930,-5053,2475,15900,-5053,2550,15900,-5413,2550
(线)3,15900,-6245,2550,15900,-7066,2550,9999,9999,9999,9999,9999,9999--(9999不画)
(线)4,14325,1621,2475,14325,-1621,2475,9999,9999,9999,9999,9999,9999
(线)5,14930,4668,2475,14930,2200,2475,14325,1851,2475,14325,1624,2475
(线)6,15900,5413,2550,15900,5053,2550,14930,5053,2475,14930,4668,2475
(线)7,15900,7066,2550,15900,6245,2550,9999,9999,9999,9999,9999,9999
让其生成POLYLINE线,要怎么实现呢???(所有9999,9999,9999不画)
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

leeyuan
发表于 2008-5-15 23:14:01 | 显示全部楼层
【广而告之】积分规则、D豆获取攻略       窝窝空间装扮攻略
楼主的要求还真不少，自己琢磨下就很容易根据数据生成线
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

QQ|申请友链|Archiver|手机版|小黑屋|辽公网安备|晓东CAD家园 ( 辽ICP备15016793号 )

GMT+8, 2024-11-15 07:00 , Processed in 0.438557 second(s), 51 queries , Gzip On.

Powered by Discuz! X3.5

© 2001-2024 Discuz! Team.

快速回复 返回顶部 返回列表