多段线坐标除以1000？

树櫴希德 · 发表于 2019-10-15 11:38:48

本帖最后由树櫴希德于 2019-10-15 12:41 编辑

;;;;;;;;;;;;;
(defun cx-ss2en
(ss / enlst)
(cond
((= (type ss) 'PICKSET)
(vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex SS)))
)
((= (type ss) 'LIST)
(setq enlst (ssadd))
(last (mapcar '(lambda (x) (ssadd x enlst)) ss))
)
((='ename(type ss))
(ssadd ss)
)
)
)
;;;;;;;;;;;;;
;(setq pzx'(1000 2000 3000))
(defun plinexy(e / 210LAST pts)
(SETQ 210LAST (last(assoc 210 (entget e)) ) )
(setq pts (mapcar'cdr(vl-remove-if'(lambda(x)(/=(car x)10))(entget e))) )
(COND
( (= 210LAST 1) (setq pts pts ) )
( (= 210LAST -1) (setq pts (mapcar '(lambda(x) (trans x '(0 0 -1) 0)) pts ) ) )
)
pts
)
;3、点表生成多段线
(defun makepl (lst / pt)
(entmake (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(8 . "ctpzx") (cons 90 (length lst)) (cons 70 129))
(mapcar '(lambda (pt)(cons 10 pt)) lst ))
) )
;(mapcar '(lambda (x) (mapcar '(lambda (x) (/ x 1000) ) x ) ) (plinexy (car(entsel))) )
(defun c:s1000 ( / lst pzx)
(setq lst (ssget '( (0 . "lwpolyline") (8 . "0")) ) )
(foreach x (cx-ss2en lst)
(setq pzx (mapcar '(lambda (x) (mapcar '(lambda (x) (/ x 1000) ) x ) ) (plinexy x) ))
(makepl pzx)
)
(princ)
)

;;;;;;;;;;;;; 
(defun cx-ss2en 
  (ss / enlst) 
  (cond 
    ((= (type ss) 'PICKSET) 
      (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex SS))) 
    ) 
    ((= (type ss) 'LIST) 
      (setq enlst (ssadd)) 
      (last (mapcar '(lambda (x) (ssadd x enlst)) ss)) 
    ) 
    ((='ename(type ss)) 
      (ssadd ss) 
    ) 
  ) 
) 
;;;;;;;;;;;;; 
;(setq pzx'(1000 2000 3000)) 
(defun plinexy(e / 210LAST pts) 
(SETQ 210LAST  (last(assoc 210 (entget e)) )  ) 
 (setq pts  (mapcar'cdr(vl-remove-if'(lambda(x)(/=(car x)10))(entget e))) ) 
(COND 
   ( (= 210LAST 1)  (setq pts  pts  )    ) 
  ( (= 210LAST -1)  (setq pts (mapcar '(lambda(x) (trans x '(0 0 -1) 0)) pts  )   )    ) 
   ) 
 
  pts 
  ) 
;3、点表生成多段线 
(defun makepl (lst / pt) 
(entmake (append    (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(8 . "ctpzx") (cons 90 (length lst)) (cons 70 129)) 
      (mapcar '(lambda (pt)(cons 10 pt)) lst )) 
  ) ) 
 
;(mapcar  '(lambda (x)    (mapcar  '(lambda (x)     (/ x 1000)      )     x    )      )    (plinexy (car(entsel)))    ) 
 
(defun c:s1000 ( / lst pzx) 
 
 (setq lst (ssget '( (0 . "lwpolyline") (8 . "0")) ) ) 
 
  (foreach  x (cx-ss2en lst) 
 
    (setq pzx (mapcar  '(lambda (x)    (mapcar  '(lambda (x)     (/ x 1000)      )     x    )      )    (plinexy x)    )) 
      (makepl pzx) 
    ) 
 
(princ) 
  )

树櫴希德 · 发表于 2019-11-9 13:33:41

;;[功能]自动识别ARX版本加载
(defun c:addarx (/ WINSHELL SHFOLDER CATCHIT PATH FILES BANBEN XT R L ADDNAME)
(vl-load-com)
(setq winshell (vlax-create-object "Shell.Application"))
(setq shFolder (vlax-invoke-method WinShell 'BrowseForFolder 0 "选择加载ARX的文件夹:" 1))
(setq catchit (vl-catch-all-apply
'(lambda ()
(setq shFolder (vlax-get-property shFolder 'self))
(setq path (strcat (vlax-get-property shFolder 'path) "\\"));文件夹路径
)
)
)
(if (vl-catch-all-error-p catchit)
nil
path
)
(setq files (vl-directory-files path "*.arx" 1)) ;获取所有文件名
(setq banben (getvar "ACADVER"));返回返回产品的版本号
;(setq xt (getenv "PROCESSOR_ARCHITECTURE")) ;返回正在使用的操作系统，
(setq xt (strcat "x" (substr (getenv "PROCESSOR_ARCHITECTURE") (1- (strlen (getenv "PROCESSOR_ARCHITECTURE"))) 2)))
(setq r (vlax-create-object "vbscript.regexp"))
(vlax-put-property r 'Global 1)
(vlax-put-property r 'Pattern (strcat "([^" "." "]+)"))
(vlax-for x (vlax-invoke r 'Execute (car files)) (setq L (cons (vla-get-Value x) L)))
(vlax-release-object r)
(setq L (reverse L))
(setq Addname (strcat path (car L) ".R" (substr banben 1 2) "d." xt ".arx")) ;加载文件名"ArxSearchRange.R17d.x86.arx"
(if Addname
(arxload Addname)
(princ "\n 未找到对应加载版本文件！请自行联系作者")
)
)

;;[功能]自动识别ARX版本加载 
(defun c:addarx (/ WINSHELL SHFOLDER CATCHIT PATH FILES BANBEN XT R L ADDNAME) 
  (vl-load-com) 
  (setq winshell (vlax-create-object "Shell.Application")) 
  (setq shFolder (vlax-invoke-method WinShell 'BrowseForFolder 0 "选择加载ARX的文件夹:" 1)) 
  (setq catchit (vl-catch-all-apply 
              '(lambda () 
                 (setq shFolder (vlax-get-property shFolder 'self)) 
                 (setq path (strcat (vlax-get-property shFolder 'path) "\\"));文件夹路径 
               ) 
            ) 
  ) 
  (if (vl-catch-all-error-p catchit) 
    nil 
    path 
  ) 
  (setq files (vl-directory-files path "*.arx" 1)) ;获取所有文件名 
  (setq banben (getvar "ACADVER"));返回返回产品的版本号 
  ;(setq xt (getenv "PROCESSOR_ARCHITECTURE")) ;返回正在使用的操作系统， 
  (setq xt (strcat "x" (substr (getenv "PROCESSOR_ARCHITECTURE") (1- (strlen (getenv "PROCESSOR_ARCHITECTURE"))) 2))) 
  (setq r (vlax-create-object "vbscript.regexp")) 
  (vlax-put-property r 'Global 1) 
  (vlax-put-property r 'Pattern (strcat "([^" "." "]+)")) 
  (vlax-for x (vlax-invoke r 'Execute (car files)) (setq L (cons (vla-get-Value x) L))) 
  (vlax-release-object r) 
  (setq L (reverse L)) 
  (setq Addname (strcat path (car L) ".R" (substr banben 1 2) "d." xt ".arx")) ;加载文件名"ArxSearchRange.R17d.x86.arx"   
  (if Addname 
    (arxload Addname) 
    (princ "\n 未找到对应加载版本文件！请自行联系作者") 
  )   
)

树櫴希德 · 发表于 2019-11-18 20:38:25

(defun c:t1 ( / *error* ) ;(批量边界并移动)
(vl-load-com)
(setq pt(getpoint))
(setq en(entlast))
(vl-cmdf "BOUNDARY" pt "")
(vl-cmdf "MOVE" (xyp-SSelEntnext en) "" pt pause)
(setvar "OSMODE" osm )
(princ)
)
(defun xyp-SSelEntnext (en / ss)
(setq ss (ssadd))
(while (setq en (entnext en))
(ssadd en ss)
)
(if (zerop (sslength ss))
nil
ss
)
)

树櫴希德 · 发表于 2019-11-18 20:39:17

(defun display (bd / pt1 pt2 pt3 pt4)
(setq pt1 (car bd)
pt3 (cadr bd)
pt2 (list (car pt3) (cadr pt1))
pt4 (list (car pt1) (cadr pt3))
)
(if (and (car pt1) (cadr pt1) (car pt3) (cadr pt3))
(grvecs (list 1 pt1 pt2 pt2 pt3 pt3 pt4 pt4 pt1))
)
)
(defun getcorn (/ corn-get corn-name corn-lst corn-ss corn-xh corn-bd)
(princ "\n点取区域")
(setq corn-xh t)
(while corn-xh
(setq corn-get (grread 1 7 0)) ;把当前的转入设备的值赋给变量
(cond
((= 5 (car corn-get)) ;mousemove
(setq corn-lst nil)
(setq corn-name (4-line corn-get fp))
;画出4条直线，并返回每条线的起点终点
(mapcar
'(lambda (x)
(setq
corn-ss (ssget
"c" ;选择每条直线相交的图元，块除外
(cadr x)
(caddr x)
'((0 . "LWPOLYLINE,LINE"))
)
)
(mapcar '(lambda (y) (ssdel (car y) corn-ss)) corn-name)
;从选择集去除辅助线
(redraw)
(if (> (sslength corn-ss) 0)
(setq
corn-lst (cons (All-inters (car x) corn-ss) corn-lst)
)
;所有交点的表
)
)
corn-name
)
(setq corn-lst (reverse corn-lst))
(mapcar '(lambda (x) (entdel (car x))) corn-name) ;删除4条直线
(setq corn-bd (Lately-pt corn-lst))
(redraw)
(display corn-bd)
)
((= 3 (car corn-get)) ;变量为3开头时为点击左键
(setq corn-xh nil)
)
((= 11 (car corn-get)) ;rightdown
(setq corn-bd nil corn-xh nil)
)
)
)
(redraw)
corn-bd
)
;;说明:判断表是不是4个元素
(defun Lately-pt (lst / min-x max-x min-y max-y)
(if (= (length lst) 4)
(progn
(setq max-y (car (vl-sort (mapcar 'cadr (nth 0 lst)) '<)))
(setq min-y (car (vl-sort (mapcar 'cadr (nth 1 lst)) '>)))
(setq min-x (car (vl-sort (mapcar 'car (nth 2 lst)) '>)))
(setq max-x (car (vl-sort (mapcar 'car (nth 3 lst)) '<)))
(list (list min-x min-y 0.0) (list max-x max-y 0.0))
)
)
)
;;说明:以鼠标为起点绘制4条直线
;;参数:get:当前鼠标坐标
;;参数:lst:当前屏幕坐标
;;返回:lst 4个图元名+起点+终点上下左右
(defun 4-line (get lst / line_name_s
line_name_x line_name_y line_name_z
pt1 pt2 pt3 pt4 pt5
)
(setq pt5 (cadr get))
;纵向直线上
(setq line_name_s
(entmakex
(list
'(0 . "LINE")
(cons 10 (trans pt5 1 0))
(cons
11
(trans (setq pt1 (list (caadr get) (cadadr (lst))))
1
0
)
)
)
)
)
;纵向直线下
(setq line_name_x
(entmakex
(list
'(0 . "LINE")
(cons 10 (trans pt5 1 0))
(cons
11
(trans (setq pt2 (list (caadr get) (cadar (lst))))
1
0
)
)
)
)
)
;横向直线左
(setq line_name_z
(entmakex
(list
'(0 . "LINE")
(cons 10 (trans pt5 1 0))
(cons
11
(trans (setq pt3 (list (caar (lst)) (cadadr get)))
1
0
)
)
)
)
)
;横向直线右
(setq line_name_y
(entmakex
(list
'(0 . "LINE")
(cons 10 (trans pt5 1 0))
(cons
11
(trans (setq pt4 (list (caadr (lst)) (cadadr get)))
1
0
)
)
)
)
)
(list
(list line_name_s pt5 pt1)
(list line_name_x pt5 pt2)
(list line_name_z pt5 pt3)
(list line_name_y pt5 pt4)
)
)
;屏幕两对角坐标
(defun fp (/ c03 c08 c04 c05 c07 c06 c09 c01 c02)
(setq c03 (getvar "viewctr")
c03 (trans c03 1 2)
c08 (getvar "viewsize")
c04 (getvar "screensize")
c07 (car c04)
c06 (cadr c04)
c09 (/ (* c08 c07) c06)
c01 (list (- (car c03) (* 0.5 c09)) (- (cadr c03) (* 0.5 c08)))
c02 (list (+ (car c03) (* 0.5 c09)) (+ (cadr c03) (* 0.5 c08)))
c01 (trans c01 2 1)
c02 (trans c02 2 1)
)
(list c01 c02)
)
;;说明:一个图元和多个图元所有交点
;;参数:name:图元名
;;参数:ss:选择集
;;返回:交点lst
(defun All-inters
(name ss / All-inters-pt All-inters-lst All-inters-xh)
(setq All-inters-xh 0)
(repeat (sslength ss)
(if (setq All-inters-pt
(HH:TwoEntsInters
name
(ssname ss All-inters-xh)
0
)
)
(setq All-inters-lst (append All-inters-pt All-inters-lst))
)
(setq All-inters-xh (1+ All-inters-xh))
)
All-inters-lst
)
;;[功能] 两对象交点列表
;;acextendnone 0 不延伸
;;acextendthisentity 1 延伸基准对象
;;acextendotherentity 2
;;acextendboth 3
;;示例(HH:TwoEntsInters (car(entsel)) (car(entsel)) 0)
(defun HH:TwoEntsInters (e1 e2 Flag / OBJ1 OBJ2 PTL PTS)
(setq obj1 (vlax-ename->vla-object e1))
(setq obj2 (vlax-ename->vla-object e2))
(setq pts (vlax-invoke obj1 'Intersectwith obj2 Flag))
(while pts
(setq
ptl (cons (trans (list (car pts) (cadr pts) (caddr pts)) 0 1)
ptl
)
)
(setq pts (cdddr pts))
)
ptl
)

(defun display (bd / pt1 pt2 pt3 pt4) 
  (setq  pt1 (car bd) 
  pt3 (cadr bd) 
  pt2 (list (car pt3) (cadr pt1)) 
  pt4 (list (car pt1) (cadr pt3)) 
  )   
  (if (and (car pt1) (cadr pt1) (car pt3) (cadr pt3)) 
    (grvecs (list 1 pt1 pt2 pt2 pt3 pt3 pt4 pt4 pt1)) 
  ) 
) 
(defun getcorn (/ corn-get corn-name corn-lst corn-ss corn-xh corn-bd) 
  (princ "\n点取区域") 
  (setq corn-xh t) 
  (while corn-xh 
    (setq corn-get (grread 1 7 0))  ;把当前的转入设备的值赋给变量 
    (cond       
      ((= 5 (car corn-get))    ;mousemove 
       (setq corn-lst nil) 
       (setq corn-name (4-line corn-get fp)) 
          ;画出4条直线，并返回每条线的起点终点 
       (mapcar 
   '(lambda (x) 
      (setq 
        corn-ss (ssget 
      "c"    ;选择每条直线相交的图元，块除外 
      (cadr x) 
      (caddr x) 
      '((0 . "LWPOLYLINE,LINE")) 
          ) 
      ) 
      (mapcar '(lambda (y) (ssdel (car y) corn-ss)) corn-name) 
          ;从选择集去除辅助线 
      (redraw) 
      (if  (> (sslength corn-ss) 0)       
        (setq 
    corn-lst (cons (All-inters (car x) corn-ss) corn-lst) 
        ) 
          ;所有交点的表 
      ) 
    ) 
   corn-name 
       ) 
       (setq corn-lst (reverse corn-lst)) 
       (mapcar '(lambda (x) (entdel (car x))) corn-name) ;删除4条直线 
       (setq corn-bd (Lately-pt corn-lst)) 
       (redraw) 
       (display corn-bd) 
      ) 
      ((= 3 (car corn-get))    ;变量为3开头时为点击左键 
       (setq  corn-xh nil) 
      ) 
      ((= 11 (car corn-get))    ;rightdown 
       (setq corn-bd nil corn-xh nil) 
      ) 
    ) 
  ) 
 
  (redraw) 
  corn-bd 
) 
;;说明:判断表是不是4个元素 
(defun Lately-pt (lst / min-x max-x min-y max-y) 
  (if (= (length lst) 4) 
    (progn 
      (setq max-y (car (vl-sort (mapcar 'cadr (nth 0 lst)) '<))) 
      (setq min-y (car (vl-sort (mapcar 'cadr (nth 1 lst)) '>))) 
      (setq min-x (car (vl-sort (mapcar 'car (nth 2 lst)) '>))) 
      (setq max-x (car (vl-sort (mapcar 'car (nth 3 lst)) '<))) 
      (list (list min-x min-y 0.0) (list max-x max-y 0.0)) 
    ) 
  ) 
) 
;;说明:以鼠标为起点绘制4条直线 
;;参数:get:当前鼠标坐标 
;;参数:lst:当前屏幕坐标 
;;返回:lst 4个图元名+起点+终点  上下左右 
(defun 4-line (get    lst       /    line_name_s 
         line_name_x       line_name_y     line_name_z 
         pt1    pt2       pt3  pt4     pt5 
        ) 
  (setq pt5 (cadr get)) 
 
          ;纵向直线上 
  (setq  line_name_s 
   (entmakex 
     (list 
       '(0 . "LINE") 
       (cons 10 (trans pt5 1 0)) 
       (cons 
         11 
         (trans (setq pt1 (list (caadr get) (cadadr (lst)))) 
          1 
          0 
         ) 
       ) 
     ) 
   ) 
  ) 
          ;纵向直线下 
  (setq  line_name_x 
   (entmakex 
     (list 
       '(0 . "LINE") 
       (cons 10 (trans pt5 1 0)) 
       (cons 
         11 
         (trans (setq pt2 (list (caadr get) (cadar (lst)))) 
          1 
          0 
         ) 
       ) 
     ) 
   ) 
  ) 
          ;横向直线左 
  (setq  line_name_z 
   (entmakex 
     (list 
       '(0 . "LINE") 
       (cons 10 (trans pt5 1 0)) 
       (cons 
         11 
         (trans (setq pt3 (list (caar (lst)) (cadadr get))) 
          1 
          0 
         ) 
       ) 
     ) 
   ) 
  ) 
          ;横向直线右 
  (setq  line_name_y 
   (entmakex 
     (list 
       '(0 . "LINE") 
       (cons 10 (trans pt5 1 0)) 
       (cons 
         11 
         (trans (setq pt4 (list (caadr (lst)) (cadadr get))) 
          1 
          0 
         ) 
       ) 
     ) 
   ) 
  ) 
  (list 
    (list line_name_s pt5 pt1) 
    (list line_name_x pt5 pt2) 
    (list line_name_z pt5 pt3) 
    (list line_name_y pt5 pt4) 
  ) 
) 
          ;屏幕两对角坐标 
(defun fp (/ c03 c08 c04 c05 c07 c06 c09 c01 c02) 
  (setq  c03 (getvar "viewctr") 
  c03 (trans c03 1 2) 
  c08 (getvar "viewsize") 
  c04 (getvar "screensize") 
  c07 (car c04) 
  c06 (cadr c04) 
  c09 (/ (* c08 c07) c06) 
  c01 (list (- (car c03) (* 0.5 c09)) (- (cadr c03) (* 0.5 c08))) 
  c02 (list (+ (car c03) (* 0.5 c09)) (+ (cadr c03) (* 0.5 c08))) 
  c01 (trans c01 2 1) 
  c02 (trans c02 2 1) 
  ) 
  (list c01 c02) 
) 
;;说明:一个图元和多个图元所有交点 
;;参数:name:图元名 
;;参数:ss:选择集 
;;返回:交点lst 
(defun All-inters 
       (name ss / All-inters-pt All-inters-lst All-inters-xh) 
  (setq All-inters-xh 0) 
  (repeat (sslength ss) 
    (if  (setq All-inters-pt 
         (HH:TwoEntsInters 
     name 
     (ssname ss All-inters-xh) 
     0 
         ) 
  ) 
      (setq All-inters-lst (append All-inters-pt All-inters-lst)) 
    ) 
    (setq All-inters-xh (1+ All-inters-xh)) 
  ) 
  All-inters-lst 
) 
;;[功能] 两对象交点列表 
;;acextendnone 0 不延伸 
;;acextendthisentity 1 延伸基准对象 
;;acextendotherentity 2 
;;acextendboth 3 
;;示例(HH:TwoEntsInters (car(entsel)) (car(entsel)) 0) 
(defun HH:TwoEntsInters  (e1 e2 Flag / OBJ1 OBJ2 PTL PTS) 
  (setq obj1 (vlax-ename->vla-object e1)) 
  (setq obj2 (vlax-ename->vla-object e2)) 
  (setq pts (vlax-invoke obj1 'Intersectwith obj2 Flag)) 
  (while pts 
    (setq 
      ptl (cons  (trans (list (car pts) (cadr pts) (caddr pts)) 0 1) 
    ptl 
    ) 
    ) 
    (setq pts (cdddr pts)) 
  ) 
  ptl 
)

杨张张 · 发表于 2020-3-1 19:54:17

来看看楼主，学习

f4800 · 发表于 2020-11-1 14:38:07

学习学习。。。

yuanziyou · 发表于 2020-11-4 22:41:55

其实你这个问题就是单位mm和m的问题，地形图上一般一个单位代表1m，而很多cad设计图纸图上一个单位一般是1mm，把地形图插入设计图纸后，你拿到这张设计图纸会发现坐标是对的，但是数字被放大了一千倍。这时如果想保证坐标正确，且单位是米，正确解决方案是：1.在此设计图纸上输入“units”,将“插入时的缩放单位”这个选项改为“毫米”后保存；2.新建一个文件，输入“units”，将“插入时的缩放单位”这个选项改为“米”，输入“insert”插入刚才的设计图纸，插入点都输0,比例1,旋转0,然后确定。

账号		自动登录	找回密码
密码			注册

多段线坐标除以1000？

相关帖子

浏览过的版块