多段线坐标除以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 ptspts) )
( (= 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")) ) )

(foreachx (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 未找到对应加载版本文件！请自行联系作者")
)
)

树櫴希德 发表于 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)
(setqpt1 (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开头时为点击左键
   (setqcorn-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    pt3pt4 pt5
   )
(setq pt5 (cadr get))

      ;纵向直线上
(setqline_name_s
(entmakex
(list
   '(0 . "LINE")
   (cons 10 (trans pt5 1 0))
   (cons
      11
      (trans (setq pt1 (list (caadr get) (cadadr (lst))))
      1
      0
      )
   )
)
)
)
      ;纵向直线下
(setqline_name_x
(entmakex
(list
   '(0 . "LINE")
   (cons 10 (trans pt5 1 0))
   (cons
      11
      (trans (setq pt2 (list (caadr get) (cadar (lst))))
      1
      0
      )
   )
)
)
)
      ;横向直线左
(setqline_name_z
(entmakex
(list
   '(0 . "LINE")
   (cons 10 (trans pt5 1 0))
   (cons
      11
      (trans (setq pt3 (list (caar (lst)) (cadadr get)))
      1
      0
      )
   )
)
)
)
      ;横向直线右
(setqline_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)
(setqc03 (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,然后确定。

页: [1]

明经CAD社区's Archiver

多段线坐标除以1000？