明经CAD社区

 找回密码
 注册

扫一扫,访问微社区

QQ登录

只需一步,快速开始

查看: 132|回复: 3

多段线坐标除以1000?

[复制链接]
发表于 2019-10-15 11:38 | 显示全部楼层 |阅读模式
本帖最后由 树櫴希德 于 2019-10-15 12:41 编辑

  1. ;;;;;;;;;;;;;
  2. (defun cx-ss2en
  3.   (ss / enlst)
  4.   (cond
  5.     ((= (type ss) 'PICKSET)
  6.       (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex SS)))
  7.     )
  8.     ((= (type ss) 'LIST)
  9.       (setq enlst (ssadd))
  10.       (last (mapcar '(lambda (x) (ssadd x enlst)) ss))
  11.     )
  12.     ((='ename(type ss))
  13.       (ssadd ss)
  14.     )
  15.   )
  16. )
  17. ;;;;;;;;;;;;;
  18. ;(setq pzx'(1000 2000 3000))
  19. (defun plinexy(e / 210LAST pts)
  20. (SETQ 210LAST  (last(assoc 210 (entget e)) )  )
  21. (setq pts  (mapcar'cdr(vl-remove-if'(lambda(x)(/=(car x)10))(entget e))) )
  22. (COND
  23.    ( (= 210LAST 1)  (setq pts  pts  )    )
  24.   ( (= 210LAST -1)  (setq pts (mapcar '(lambda(x) (trans x '(0 0 -1) 0)) pts  )   )    )
  25.    )

  26.   pts
  27.   )
  28. ;3、点表生成多段线
  29. (defun makepl (lst / pt)
  30. (entmake (append    (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(8 . "ctpzx") (cons 90 (length lst)) (cons 70 129))
  31.       (mapcar '(lambda (pt)(cons 10 pt)) lst ))
  32.   ) )

  33. ;(mapcar  '(lambda (x)    (mapcar  '(lambda (x)     (/ x 1000)      )     x    )      )    (plinexy (car(entsel)))    )

  34. (defun c:s1000 ( / lst pzx)

  35. (setq lst (ssget '( (0 . "lwpolyline") (8 . "0")) ) )

  36.   (foreach  x (cx-ss2en lst)

  37.     (setq pzx (mapcar  '(lambda (x)    (mapcar  '(lambda (x)     (/ x 1000)      )     x    )      )    (plinexy x)    ))
  38.       (makepl pzx)
  39.     )

  40. (princ)
  41.   )


 楼主| 发表于 2019-11-9 13:33 | 显示全部楼层
  1. ;;[功能]自动识别ARX版本加载
  2. (defun c:addarx (/ WINSHELL SHFOLDER CATCHIT PATH FILES BANBEN XT R L ADDNAME)
  3.   (vl-load-com)
  4.   (setq winshell (vlax-create-object "Shell.Application"))
  5.   (setq shFolder (vlax-invoke-method WinShell 'BrowseForFolder 0 "选择加载ARX的文件夹:" 1))
  6.   (setq catchit (vl-catch-all-apply
  7.               '(lambda ()
  8.                  (setq shFolder (vlax-get-property shFolder 'self))
  9.                  (setq path (strcat (vlax-get-property shFolder 'path) "\\"));文件夹路径
  10.                )
  11.             )
  12.   )
  13.   (if (vl-catch-all-error-p catchit)
  14.     nil
  15.     path
  16.   )
  17.   (setq files (vl-directory-files path "*.arx" 1)) ;获取所有文件名
  18.   (setq banben (getvar "ACADVER"));返回返回产品的版本号
  19.   ;(setq xt (getenv "PROCESSOR_ARCHITECTURE")) ;返回正在使用的操作系统,
  20.   (setq xt (strcat "x" (substr (getenv "PROCESSOR_ARCHITECTURE") (1- (strlen (getenv "PROCESSOR_ARCHITECTURE"))) 2)))
  21.   (setq r (vlax-create-object "vbscript.regexp"))
  22.   (vlax-put-property r 'Global 1)
  23.   (vlax-put-property r 'Pattern (strcat "([^" "." "]+)"))
  24.   (vlax-for x (vlax-invoke r 'Execute (car files)) (setq L (cons (vla-get-Value x) L)))
  25.   (vlax-release-object r)
  26.   (setq L (reverse L))
  27.   (setq Addname (strcat path (car L) ".R" (substr banben 1 2) "d." xt ".arx")) ;加载文件名"ArxSearchRange.R17d.x86.arx"  
  28.   (if Addname
  29.     (arxload Addname)
  30.     (princ "\n 未找到对应加载版本文件!请自行联系作者")
  31.   )  
  32. )

 楼主| 发表于 2019-11-18 20:38 | 显示全部楼层
  1. (defun c:t1 ( / *error* )  ;(批量边界并移动)
  2.   (vl-load-com)
  3. (setq pt(getpoint))
  4. (setq en(entlast))
  5. (vl-cmdf "BOUNDARY" pt "")
  6. (vl-cmdf "MOVE" (xyp-SSelEntnext en) "" pt pause)
  7. (setvar "OSMODE" osm )
  8. (princ)
  9. )

  10. (defun xyp-SSelEntnext (en / ss)
  11.   (setq ss (ssadd))
  12.   (while (setq en (entnext en))
  13.     (ssadd en ss)
  14.   )
  15.   (if (zerop (sslength ss))
  16.     nil
  17.     ss
  18.   )
  19. )

 楼主| 发表于 2019-11-18 20:39 | 显示全部楼层
  1. (defun display (bd / pt1 pt2 pt3 pt4)
  2.   (setq  pt1 (car bd)
  3.   pt3 (cadr bd)
  4.   pt2 (list (car pt3) (cadr pt1))
  5.   pt4 (list (car pt1) (cadr pt3))
  6.   )  
  7.   (if (and (car pt1) (cadr pt1) (car pt3) (cadr pt3))
  8.     (grvecs (list 1 pt1 pt2 pt2 pt3 pt3 pt4 pt4 pt1))
  9.   )
  10. )
  11. (defun getcorn (/ corn-get corn-name corn-lst corn-ss corn-xh corn-bd)
  12.   (princ "\n点取区域")
  13.   (setq corn-xh t)
  14.   (while corn-xh
  15.     (setq corn-get (grread 1 7 0))  ;把当前的转入设备的值赋给变量
  16.     (cond      
  17.       ((= 5 (car corn-get))    ;mousemove
  18.        (setq corn-lst nil)
  19.        (setq corn-name (4-line corn-get fp))
  20.           ;画出4条直线,并返回每条线的起点终点
  21.        (mapcar
  22.    '(lambda (x)
  23.       (setq
  24.         corn-ss (ssget
  25.       "c"    ;选择每条直线相交的图元,块除外
  26.       (cadr x)
  27.       (caddr x)
  28.       '((0 . "LWPOLYLINE,LINE"))
  29.           )
  30.       )
  31.       (mapcar '(lambda (y) (ssdel (car y) corn-ss)) corn-name)
  32.           ;从选择集去除辅助线
  33.       (redraw)
  34.       (if  (> (sslength corn-ss) 0)      
  35.         (setq
  36.     corn-lst (cons (All-inters (car x) corn-ss) corn-lst)
  37.         )
  38.           ;所有交点的表
  39.       )
  40.     )
  41.    corn-name
  42.        )
  43.        (setq corn-lst (reverse corn-lst))
  44.        (mapcar '(lambda (x) (entdel (car x))) corn-name) ;删除4条直线
  45.        (setq corn-bd (Lately-pt corn-lst))
  46.        (redraw)
  47.        (display corn-bd)
  48.       )
  49.       ((= 3 (car corn-get))    ;变量为3开头时为点击左键
  50.        (setq  corn-xh nil)
  51.       )
  52.       ((= 11 (car corn-get))    ;rightdown
  53.        (setq corn-bd nil corn-xh nil)
  54.       )
  55.     )
  56.   )

  57.   (redraw)
  58.   corn-bd
  59. )
  60. ;;说明:判断表是不是4个元素
  61. (defun Lately-pt (lst / min-x max-x min-y max-y)
  62.   (if (= (length lst) 4)
  63.     (progn
  64.       (setq max-y (car (vl-sort (mapcar 'cadr (nth 0 lst)) '<)))
  65.       (setq min-y (car (vl-sort (mapcar 'cadr (nth 1 lst)) '>)))
  66.       (setq min-x (car (vl-sort (mapcar 'car (nth 2 lst)) '>)))
  67.       (setq max-x (car (vl-sort (mapcar 'car (nth 3 lst)) '<)))
  68.       (list (list min-x min-y 0.0) (list max-x max-y 0.0))
  69.     )
  70.   )
  71. )
  72. ;;说明:以鼠标为起点绘制4条直线
  73. ;;参数:get:当前鼠标坐标
  74. ;;参数:lst:当前屏幕坐标
  75. ;;返回:lst 4个图元名+起点+终点  上下左右
  76. (defun 4-line (get    lst       /    line_name_s
  77.          line_name_x       line_name_y     line_name_z
  78.          pt1    pt2       pt3  pt4     pt5
  79.         )
  80.   (setq pt5 (cadr get))

  81.           ;纵向直线上
  82.   (setq  line_name_s
  83.    (entmakex
  84.      (list
  85.        '(0 . "LINE")
  86.        (cons 10 (trans pt5 1 0))
  87.        (cons
  88.          11
  89.          (trans (setq pt1 (list (caadr get) (cadadr (lst))))
  90.           1
  91.           0
  92.          )
  93.        )
  94.      )
  95.    )
  96.   )
  97.           ;纵向直线下
  98.   (setq  line_name_x
  99.    (entmakex
  100.      (list
  101.        '(0 . "LINE")
  102.        (cons 10 (trans pt5 1 0))
  103.        (cons
  104.          11
  105.          (trans (setq pt2 (list (caadr get) (cadar (lst))))
  106.           1
  107.           0
  108.          )
  109.        )
  110.      )
  111.    )
  112.   )
  113.           ;横向直线左
  114.   (setq  line_name_z
  115.    (entmakex
  116.      (list
  117.        '(0 . "LINE")
  118.        (cons 10 (trans pt5 1 0))
  119.        (cons
  120.          11
  121.          (trans (setq pt3 (list (caar (lst)) (cadadr get)))
  122.           1
  123.           0
  124.          )
  125.        )
  126.      )
  127.    )
  128.   )
  129.           ;横向直线右
  130.   (setq  line_name_y
  131.    (entmakex
  132.      (list
  133.        '(0 . "LINE")
  134.        (cons 10 (trans pt5 1 0))
  135.        (cons
  136.          11
  137.          (trans (setq pt4 (list (caadr (lst)) (cadadr get)))
  138.           1
  139.           0
  140.          )
  141.        )
  142.      )
  143.    )
  144.   )
  145.   (list
  146.     (list line_name_s pt5 pt1)
  147.     (list line_name_x pt5 pt2)
  148.     (list line_name_z pt5 pt3)
  149.     (list line_name_y pt5 pt4)
  150.   )
  151. )
  152.           ;屏幕两对角坐标
  153. (defun fp (/ c03 c08 c04 c05 c07 c06 c09 c01 c02)
  154.   (setq  c03 (getvar "viewctr")
  155.   c03 (trans c03 1 2)
  156.   c08 (getvar "viewsize")
  157.   c04 (getvar "screensize")
  158.   c07 (car c04)
  159.   c06 (cadr c04)
  160.   c09 (/ (* c08 c07) c06)
  161.   c01 (list (- (car c03) (* 0.5 c09)) (- (cadr c03) (* 0.5 c08)))
  162.   c02 (list (+ (car c03) (* 0.5 c09)) (+ (cadr c03) (* 0.5 c08)))
  163.   c01 (trans c01 2 1)
  164.   c02 (trans c02 2 1)
  165.   )
  166.   (list c01 c02)
  167. )
  168. ;;说明:一个图元和多个图元所有交点
  169. ;;参数:name:图元名
  170. ;;参数:ss:选择集
  171. ;;返回:交点lst
  172. (defun All-inters
  173.        (name ss / All-inters-pt All-inters-lst All-inters-xh)
  174.   (setq All-inters-xh 0)
  175.   (repeat (sslength ss)
  176.     (if  (setq All-inters-pt
  177.          (HH:TwoEntsInters
  178.      name
  179.      (ssname ss All-inters-xh)
  180.      0
  181.          )
  182.   )
  183.       (setq All-inters-lst (append All-inters-pt All-inters-lst))
  184.     )
  185.     (setq All-inters-xh (1+ All-inters-xh))
  186.   )
  187.   All-inters-lst
  188. )
  189. ;;[功能] 两对象交点列表
  190. ;;acextendnone 0 不延伸
  191. ;;acextendthisentity 1 延伸基准对象
  192. ;;acextendotherentity 2
  193. ;;acextendboth 3
  194. ;;示例(HH:TwoEntsInters (car(entsel)) (car(entsel)) 0)
  195. (defun HH:TwoEntsInters  (e1 e2 Flag / OBJ1 OBJ2 PTL PTS)
  196.   (setq obj1 (vlax-ename->vla-object e1))
  197.   (setq obj2 (vlax-ename->vla-object e2))
  198.   (setq pts (vlax-invoke obj1 'Intersectwith obj2 Flag))
  199.   (while pts
  200.     (setq
  201.       ptl (cons  (trans (list (car pts) (cadr pts) (caddr pts)) 0 1)
  202.     ptl
  203.     )
  204.     )
  205.     (setq pts (cdddr pts))
  206.   )
  207.   ptl
  208. )


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

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号  
©2000-2017 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2019-12-12 18:29 , Processed in 0.165873 second(s), 27 queries , Gzip On.

Powered by Discuz! X3.3

© 2001-2013 Comsenz Inc.

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