明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 8215|回复: 15

推荐一款lisp插件,强迫症患者专用,用于线条去小数

[复制链接]
发表于 2017-12-12 10:37:57 | 显示全部楼层 |阅读模式
插件是网上找的,作用本来是给线段 直线 圆弧 墙体 柱子什么的去除小数  但现在不知道什么原因对于天正墙体不起作用,有没有大神帮忙看一下。
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;"
                "}"
        "}"
  )
)

点评

大家不要赞错了 highflybir版主发在 http://bbs.mjtd.com/forum.php?mod=viewthread&tid=86961&highlight=%C8%A1%D5%FB  发表于 2021-5-22 02:10
 楼主| 发表于 2017-12-13 14:19:35 | 显示全部楼层
panliang9 发表于 2017-12-13 11:41
这程序很有意思哦,感谢楼主放出来!

兼职是强迫症患者的福音  特别是像画个图纸都要开7位8位小数的患者
发表于 2024-10-4 10:49:37 | 显示全部楼层
可以用,不知道哪些地方能用到,先收藏学习了  谢谢分享
发表于 2017-12-13 11:41:08 | 显示全部楼层
这程序很有意思哦,感谢楼主放出来!
发表于 2018-7-31 14:05:22 | 显示全部楼层
这个不错,谢谢
发表于 2018-8-10 09:11:09 | 显示全部楼层
真是牛牛牛,谢谢大神!
发表于 2018-8-13 19:02:13 | 显示全部楼层
真是牛牛牛,谢谢大神!
发表于 2018-8-18 23:03:42 | 显示全部楼层
这个不错,谢谢
发表于 2018-9-26 19:06:59 | 显示全部楼层
谢谢楼主,分享源代码。学习
您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-11-23 07:27 , Processed in 0.232071 second(s), 34 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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