推荐一款lisp插件，强迫症患者专用，用于线条去小数
这插件是网上找的，作用本来是给线段 直线 圆弧 墙体 柱子什么的去除小数但现在不知道什么原因对于天正墙体不起作用，有没有大神帮忙看一下。ps：应插件版权要求 转载说明原创和来源网站。[资源] 【飞鸟集】数据取整（带对话框和不带的两种） highflybir版主
下面放语句
(vl-load-com)
(prompt "\n程序命令是:GZ")
;;;*************************************************************
;;;对CAD的图元或者图元的相对距离零碎数归整，如端点、顶点、线段的
;;;长度的零碎数归整，轴线之间距取整等等。
;;;适用于斯维尔，天正，直线，圆，弧，多段线，块。
;;;可以自定义容差。在这个容差内的数据将会被归整。
;;;譬如歪斜不平的线段可以摆平，轴线间距归整，Z坐标归零等等。
;;;程序可用于整理他人所提条件图、其他程序产生的误差和完美主义者.
;;;*************************************************************
(defun C:GZ (/ *DOC Ent I Locks BasePt Sel str TOL Data filter)
;;出错处理
(defun *error* (msg)
(if (wcmatch (strcase msg t) "*break,*cancel*,*exit*,*取消*")
(princ "\n用户按了<Esc>强制退出")
(princ (strcat "\n" msg))
)
(vla-EndUndoMark
(vla-get-ActiveDocument (vlax-get-acad-object))
) ;回退
(princ)
)
;;初始化处理
(setq *DOC (vla-get-ActiveDocument (vlax-get-acad-object)))
(vla-StartUndoMark *DOC) ;设置回退标志
(setq Locks (Unlock_All_Layers *DOC)) ;解锁所有层
(setq Data (read (getvar "USERS5"))) ;检测是否已设置参数
(if (not (CheckData data))
(setq Data (SetDefault))
)
(setq TOL (cdr (assoc "TOL" Data)))
;;输入部分
(setq str (strcat "\n请选取点[设置(Set)]<" TOL ">:"))
(initget "Set")
(setq BasePt (getpoint str)) ;拾取基准点
(cond ;如果需要设置参数
( (= BasePt "Set")
(setq Data (C:SetByDCL))
(setq BasePt (list (atof (cdr (assoc "X" Data)))
(atof (cdr (assoc "Y" Data)))
(atof (cdr (assoc "Z" Data)))
)
)
)
( BasePt
(setq Data (Replace "X" (rtos (car BasePt) 2 20) Data))
(setq Data (Replace "Y" (rtos (cadr BasePt) 2 20) Data))
(setq Data (Replace "Z" (rtos (caddr BasePt) 2 20) Data))
(setvar "USERS5" (VL-PRIN1-TO-STRING data)) ;;检查基点和更新默认基点
)
(t
(setq BasePt '(0 0 0)) ;默认基准点为'(0 0 0)
)
)
;;检查容差
(setq Data (read (getvar "USERS5")))
(setq TOL (atof (cdr (assoc "TOL" Data))))
(if (<= TOL 0) ;防止被零除和负数容差
(progn
(setq TOL 5.0) ;默认容差为5
(setq Data (Replace "TOL" "5.0" Data))
(setvar "USERS5" (VL-PRIN1-TO-STRING data))
)
)
;;获取图元类型
(setq filter "")
(repeat 10
(if (= (cdar Data) "1")
(setq filter (strcat filter "," (caar data)))
)
(setq Data (cdr Data))
)
(setq filter (substr filter 2))
(if (= filter "")
(setq filter "*LINE,INSERT,CIRCLE,ARC,ELLIPSE,*_COLUMN,*_OPENING,*_WALL")
)
;;处理部分
(setq i 0)
(if (setq sel (ssget (list (cons 0 filter))))
(repeat (sslength sel) ;对选择集的每个实体
(setq ent (ssname sel i))
(RoundEnt ent BasePt TOL) ;进行归整
(setq i (1+ i))
)
)
;;结尾部分
(Restore_Locked_Layers Locks) ;恢复以前图层状态
(vla-EndUndoMark *DOC) ;回退标志结束
(princ)
)
;;;*************************************************************
;;;归整主函数
;;;参数: ent 图元
;;; BasePt 基点
;;; tol 容差
;;;返回值: 无
;;;*************************************************************
(defun RoundEnt (ent BasePt TOL / DXF typ obj pt1 pt2 e pts lst)
(setq DXF (entget ent))
(setq typ (cdr (assoc 0 DXF))) ;图元类型
(setq obj (vlax-ename->vla-object ent))
(cond
( (or (= "LINE" typ) ;线段
(wcmatch typ "*_WALL") ;墙
(wcmatch typ "*_OPENING") ;门窗
)
(setq pt1 (cdr (assoc 10 DXF))) ;起点
(setq pt2 (cdr (assoc 11 DXF))) ;终点
(setq pt1 (RoundPoint pt1 BasePt TOL)) ;起点归整
(setq pt2 (RoundPoint pt2 BasePt TOL)) ;终点归整
(setq DXF (Replace 10 pt1 DXF)) ;替换原起点数据
(setq DXF (Replace 11 pt2 DXF)) ;替换原终点数据
(entmod DXF)
(entupd ent) ;更新图元
)
( (= "LWPOLYLINE" typ) ;多段线
(setq pts nil)
(foreach x DXF
(if (= (car x) 10)
(setq pt1 (RoundPoint (cdr x) BasePt TOL) ;顶点坐标取整
pts (cons (cons 10 pt1) pts)
)
(setq pts (cons x pts))
)
)
(setq pts (reverse pts))
(entmod pts) ;更新顶点坐标
(entupd ent) ;更新多段线
)
( (= "POLYLINE" typ) ;3d多段线
(setq e (entnext ent))
(while (/= (cdr (assoc 0 (setq lst (entget e)))) "SEQEND");循环取得顶点
(setq pt1 (cdr (assoc 10 lst))) ;取得顶点坐标
(setq pt1 (RoundPoint pt1 BasePt TOL)) ;顶点坐标规整
(setq lst (Replace 10 pt1 lst)) ;替换原顶点
(entmod lst)
(entupd e) ;更新图元
(setq e (entnext e)) ;下一个顶点
)
)
( (or (= "INSERT" typ) ;图块
(= "CIRCLE" typ) ;圆
(= "ARC" typ) ;圆弧
(= "ELLIPSE" typ) ;椭圆
)
(setq pt1 (cdr (assoc 10 DXF))) ;插入点或中心点
(setq pt1 (RoundPoint pt1 BasePt TOL)) ;点归整
(setq DXF (Replace 10 pt1 DXF)) ;替换原来点
(entmod DXF)
(entupd ent) ;更新图元
)
( (wcmatch typ "*_COLUMN") ;柱
(setq pt1 (cdr (assoc 11 DXF))) ;柱插入点
(setq pt1 (RoundPoint pt1 BasePt TOL)) ;归整
(setq DXF (Replace 11 pt1 DXF)) ;替换原插入点数据
(entmod DXF)
(entupd ent) ;更新图元
)
)
)
;;;*************************************************************
;;;对点归整--用AutoLISP方式更新(此种情况适用斯维尔或天正)
;;;参数: Point 要归整的点，以表的形式
;;; BasePt 基点
;;; tol 容差
;;;返回值: Pnt 归整后的点(相对基点)，以表的形式
;;;*************************************************************
(defun RoundPoint (Point BasePt TOL / Pnt ptX ptY)
(setq Pnt (trans Point 0 1)) ;考虑到可能在UCS下操作，故转化为用户坐标系
(setq Pnt (mapcar '- Pnt BasePt)) ;相对于基点
(setq ptX (car Pnt)) ;X分量
(setq ptY (cadr Pnt)) ;y分量
(setq ptX (Round ptX TOL)) ;对X分量取整
(setq ptY (Round ptY TOL)) ;对y分量取整
(if (caddr Point) ;如果是三维点
(setq Pnt (list ptX ptY 0)) ;可考虑Z坐标归零或取整
(setq Pnt (list ptX ptY))
)
(setq Pnt (mapcar '+ Pnt BasePt)) ;加上位移量
(setq Pnt (trans Pnt 1 0)) ;再转化为世界坐标系
(if (caddr Point) ;如果是三维点
Pnt ;不变
(list (car Pnt) (cadr Pnt)) ;否则只取X和Y坐标
)
)
;;;*************************************************************
;;;对点归整--用ActiveX方式更新
;;;参数: Array 要归整的点，以安全数组的形式
;;; BasePt 基点
;;; tol 容差
;;;返回值: Pnt 归整后的点(相对基点),以安全数组的形式
;;;*************************************************************
(defun RoundArray (Array BasePt TOL / Pnt)
(setq Pnt (Array->List Array)) ;先转化为List表
(setq Pnt (RoundPoint Pnt BasePt TOL)) ;然后对点表归整(同上)
(setq Pnt (List->Array Pnt)) ;再把点表转化为安全数组
)
;;;*************************************************************
;;;判断容差范围,消除小数(eclimate decimal)
;;;参数: x 要归整的实数
;;; tol 容差
;;;返回值: 归整后的实数
;;;*************************************************************
(defun Round (x TOL / frac half)
(setq half (/ TOL 2.)) ;取半(四舍五入)
(setq frac (rem x TOL))
(if (< (abs frac) half) ;是否过半
(- x frac) ;四舍
(if (< x 0)
(- x frac TOL) ;五入
(- x frac (- TOL)) ;五入
)
)
)
;;;*************************************************************
;;;表转化为安全数组
;;;*************************************************************
(defun List->Array (lst)
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbdouble
(cons 0 (1- (length lst)))
)
lst
)
)
)
;;;*************************************************************
;;;安全数组转化为表
;;;*************************************************************
(defun Array->List (Array)
(vlax-safearray->list (vlax-variant-value Array))
)
;;;*************************************************************
;;;解锁所有的图层
;;;*************************************************************
(defun Unlock_All_Layers (*DOC / Locks)
(vlax-for x (vla-get-layers *DOC)
(if (= (vla-get-lock x) :vlax-true)
(progn
(setq Locks (cons x Locks))
(vla-put-lock x :vlax-false)
)
)
)
(reverse Locks)
)
;;;*************************************************************
;;;解冻所有的图层
;;;*************************************************************
(defun unFreeze_all_layers (*DOC / Layers)
(vlax-for x (vla-get-layers *DOC)
(if (= (vla-get-freeze x) :vlax-true)
(progn
(setq Layers (cons x Layers))
(vla-put-freeze x :vlax-false)
)
)
)
(reverse Layers)
)
;;;*************************************************************
;;;恢复以前图层的状态
;;;*************************************************************
(defun Restore_Locked_Layers (Locks /)
(if Locks
(mapcar
(function
(lambda (x)
(vla-put-lock x :vlax-true)
)
)
Locks
)
)
)
;;;*************************************************************
;;;设置默认参数
;;;*************************************************************
(defun SetDefault ( / Default)
(setq Default
'(("LINE" . "1")
("LWPOLYLINE" . "1")
("POLYLINE" . "1")
("ARC" . "1")
("CIRCLE" . "1")
("ELLIPSE" . "1")
("INSERT" . "1")
("*_COLUMN" . "1")
("*_OPENING" . "1")
("*_WALL" . "1")
("TOL" . "5.0")
("X" . "0.0")
("Y" . "0.0")
("Z" . "0.0")
)
)
(setvar "USERS5" (VL-PRIN1-TO-STRING Default))
Default
)
;;;*************************************************************
;;;检查参数
;;;*************************************************************
(defun CheckData (data)
(equal
(mapcar 'car data)
(list
"LINE" "LWPOLYLINE" "POLYLINE" "ARC" "CIRCLE" "ELLIPSE"
"INSERT" "*_COLUMN" "*_OPENING" "*_WALL" "TOL" "X" "Y" "Z"
)
)
)
;;;*************************************************************
;;;替换点表中的数据
;;;*************************************************************
(defun Replace (key new lst)
(subst (cons key new) (assoc key lst) lst)
)
;;;*************************************************************
;;;以下为从对话框中获得参数
;;;对话框为动态加载。参数设置可以保存。
;;;*************************************************************
(defun C:SetByDCL(/ catchit)
(setq catchit (VL-CATCH-ALL-APPLY 'dcl_load))
(if (vl-catch-all-error-p catchit)
(progn
(princ "\n出错信息是:")
(princ (vl-catch-all-error-message catchit))
nil
)
catchit
)
)
;;;Load the dialog
(defun DCL_load (/ dcl_id DlgRet Dcl_File data)
(setq Dcl_File (Write_Dcl (DialogData))) ;创建临时对话框文件
(setq dcl_id (load_dialog Dcl_File)) ;装入对话框文件(因为是动态，所以不必检查dcl_file)
(vl-file-delete Dcl_File) ;删除临时对话框文件
;;从用户变量中提出上次的对话框数据
(setq data (read (getvar "USERS5"))) ;列表全部控件名称
(if (not (CheckData data))
(setq data (SetDefault))
)
;;开始对话框操作
(setq DlgRet 2)
(while (> DlgRet 1) ;如果没有离开对话框
(new_dialog "DCL" dcl_id) ;因为是动态对话框，所以可以不检查dcl_id
(InitiateDialog data) ;初始化对话框
(setq DlgRet (start_dialog)) ;显示对话框
(cond
( (= DlgRet 2)
(setq data (GETTOL data))
)
( (= DlgRet 3)
(setq data (PickBasePoint data))
)
)
)
;;离开对话框之后的动作
(cond
( (= DlgRet 0)
(princ "\n你取消了设置.") ;返回一个取消的信息给用户
)
)
(setvar "USERS5" (VL-PRIN1-TO-STRING data)) ;把当前对话框数据写入用户变量
(unload_dialog dcl_id) ;卸载对话框
data
)
;;;初始化对话框
(defun InitiateDialog (data)
(action_tile "help" "(helpMsg)") ;help
(action_tile "PICK" "(done_dialog 3)") ;拾取基点
(action_tile "GETTOL" "(done_dialog 2)") ;量取容差
(foreach key data ;全部控件的初始化
(and (cdr key) (set_tile (car key) (cdr key))) ;控件内容
(action_tile (car key)"(Action_DCL_Keys $key $value $data)");点击动作
)
)
;;;如果要在图形中获取容差
(defun GETTOL (data / dist sDist)
(Initget 14)
(setq dist (getdist "\n请输入容差:"))
(if dist
(progn
(setq sDist (rtos dist 2 20))
(set_tile "TOL" sDist)
(Replace "TOL" sDist data) ;更新容差
)
data
)
)
;;;如果要在图形中获取基点
(defun PickBasePoint (data / Pnt strX strY strZ NewDat)
(Initget 8)
(setq Pnt (getPoint "\n请点取基点:"))
(if Pnt
(progn
(setq strX (rtos (car pnt) 2 20))
(setq strY (rtos (cadr pnt) 2 20))
(setq strZ (rtos (caddr pnt) 2 20))
(set_tile "X" strX)
(set_tile "Y" strY)
(set_tile "Z" strZ)
(setq NewDat data)
(setq NewDat (Replace "X" strX NewDat)) ;更新X坐标
(setq NewDat (Replace "Y" strY NewDat)) ;更新Y坐标
(setq NewDat (Replace "Z" strZ NewDat)) ;更新Z坐标
)
data
)
)
;;;在此处添加你自己的帮助函数
(defun helpMsg()
(alert "暂未提供帮助文档!")
)
;;;全部控件的点击动作触发
(defun Action_DCL_Keys (key value keydata / str)
(setq str (get_tile key))
(cond
( (= key "TOL")
(if (<=(atof str) 0)
(progn
(alert "你输入负值或者零!")
(set_tile "TOL" "5.0")
(setq str "5.0")
)
(setq str (rtos (atof str) 2 20))
)
)
( (or (= key "X")
(= key "Y")
(= key "Z")
)
(setq str (rtos (atof str) 2 20))
)
)
(setq data (Replace key str data)) ;每个控件都赋给一个变量 用于下次开启初始化
)
;;;临时生成Dcl文件 返回文件名
(defun Write_Dcl (DialogData / Dcl_File file str)
(setq Dcl_File (vl-filename-mktemp nil nil ".DCL"))
(setq file (open Dcl_File "W"))
(foreach str DialogData
(write-line str file)
)
(close file)
Dcl_File
)
(defun DialogData ()
(list "DCL:dialog"
"{"
"key = \"DLG\" ;"
"label = \"参数设置\";"
"spacer;"
":boxed_row"
"{"
"label = \"图元类型\" ;"
":column"
"{"
":toggle"
"{"
"key = \"LINE\" ;"
"label = \"线段\" ;"
"value = 1 ;"
"}"
":toggle"
"{"
"key = \"LWPOLYLINE\" ;"
"label = \"多段线\" ;"
"value = 1 ;"
"}"
":toggle"
"{"
"key = \"POLYLINE\" ;"
"label = \"三维多段线\" ;"
"value = 1 ;"
"}"
":toggle"
"{"
"key = \"ARC\" ;"
"label = \"弧\" ;"
"value = 1 ;"
"}"
":toggle"
"{"
"key = \"CIRCLE\" ;"
"label = \"圆\" ;"
"value = 1 ;"
"}"
"}"
":column"
"{"
":toggle"
"{"
"key = \"ELLIPSE\" ;"
"label = \"椭圆\" ;"
"value = 1 ;"
"}"
":toggle"
"{"
"key = \"INSERT\" ;"
"label = \"插入块\" ;"
"value = 1 ;"
"}"
":toggle"
"{"
"key = \"*_COLUMN\" ;"
"label = \"柱子\" ;"
"value = 1 ;"
"}"
":toggle"
"{"
"key = \"*_OPENING\" ;"
"label = \"门窗\" ;"
"value = 1 ;"
"}"
":toggle"
"{"
"key = \"*_WALL\" ;"
"label = \"墙\" ;"
"value = 1 ;"
"}"
"}"
"}"
":boxed_column"
"{"
"label = \"容差设置\" ;"
":row"
"{"
":text"
"{"
"key = \"LABLE1\" ;"
"label = \"容差\" ;"
"}"
":edit_box"
"{"
"key = \"TOL\" ;"
"value = \"5.0\" ;"
"fixed_width = true;"
"width = 15;"
"}"
":button"
"{"
"key = \"GETTOL\";"
"label = \"量取容差\";"
"}"
"}"
"spacer;"
"}"
":boxed_row"
"{"
"label = \"基点设置\" ;"
":column"
"{"
":row"
"{"
":text"
"{"
"key = \"LABLEX\" ;"
"label = \"X= \" ;"
"}"
":edit_box"
"{"
"key = \"X\" ;"
"value = \"0.0\" ;"
"fixed_width = true;"
"width = 15;"
"}"
"}"
":row"
"{"
":text"
"{"
"key = \"LABLEY\" ;"
"label = \"Y= \" ;"
"}"
":edit_box"
"{"
"key = \"Y\" ;"
"value = \"0.0\" ;"
"fixed_width = true;"
"width = 15;"
"}"
"}"
":row"
"{"
":text"
"{"
"key = \"LABLEZ\" ;"
"label = \"Z= \" ;"
"}"
":edit_box"
"{"
"key = \"Z\" ;"
"value = \"0.0\" ;"
"fixed_width = true;"
"width = 15;"
"}"
"}"
"spacer;"
"}"
":button"
"{"
"key = \"PICK\";"
"label = \"点取基点\";"
"}"
"}"
"spacer;"
"ok_cancel_help;"
":text"
"{"
"key = \"INFO\" ;"
"label = \"All Copyright Reserved. Highflybird\" ;"
"alignment = centered;"
"}"
"}"
)
)
panliang9 发表于 2017-12-13 11:41
这程序很有意思哦，感谢楼主放出来！
兼职是强迫症患者的福音特别是像画个图纸都要开7位8位小数的患者 可以用，不知道哪些地方能用到，先收藏学习了谢谢分享 这程序很有意思哦，感谢楼主放出来！ 标记一下。 这个不错，谢谢 真是牛牛牛，谢谢大神！ 真是牛牛牛，谢谢大神！ 这个不错，谢谢 谢谢楼主，分享源代码。学习 值得学习
页:
[1]
2