明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
楼主: springwillow

柱定位程序源码

    [复制链接]
发表于 2012-5-21 19:35:24 | 显示全部楼层
这个指定图层。。如果改成。在图中选择指定就非常完美~~
发表于 2012-5-21 19:40:09 | 显示全部楼层


这个是字母标出来滴

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
发表于 2012-5-21 19:44:14 | 显示全部楼层
开源的一定要顶
发表于 2012-5-21 20:01:37 | 显示全部楼层
转载一个某大师的精品之作
无源

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
发表于 2012-5-21 20:50:43 | 显示全部楼层
本帖最后由 xiaoyingzi 于 2012-5-22 13:04 编辑

发个用楼主的改的,特点:采用鼠标框选的角点方位来定标注尺寸的位置
命令:dsz 设置图层
命令:dzz 定位标注



  1. (defun c:dzz ( / getpline MidPof2P PtPerTo2Pts MakeDimAlign DimSyl DimtxtHeight
  2.                  DimFont FontWidFactor D147 s ss n in e tpt1 tpt2 ptl p1 p2 p3 p4
  3.                  ssaxis interss x p0 pp p14 p12 p141 p121 p34 p32 p341 p321
  4.                  d70 d50 myerr myend oldosmode oldcmdecho)
  5.   ;自定义出错函数
  6.   (defun myerr (msg)
  7.     (vl-catch-all-error-p
  8.      (vl-catch-all-apply
  9.      '(lambda ()
  10.         (setq msg(strcase msg t))
  11.         (if (wcmatch msg "*break,*cancel*,*exit*")
  12.             (princ "\n*取消*\n")                 
  13.             (princ (strcat "\n" msg))
  14.         )
  15.         (myend)
  16.       )
  17.      )
  18.     )
  19.     (princ)
  20.   )

  21.   ;自定义结尾函数
  22.   (defun myend ()
  23.     (setvar "osmode" oldosmode)
  24.     (setvar "cmdecho" oldcmdecho)
  25.     (setq *error* olderr)
  26.   )

  27.   (defun dxf (a en)
  28.     (cdr (assoc a en))
  29.   )

  30.   ;根据多线段名获得多线段的端点集合
  31.   (defun getpline (plname / pts x)
  32.     (setq pts '())
  33.     (mapcar
  34.       '(lambda (x)
  35.           (if (= (car x) 10)
  36.               (setq pts (cons (cdr x) pts))
  37.           )
  38.        )
  39.        (entget plname)
  40.     )
  41.     (reverse pts)
  42.     ;按(左上角,左下角,右下角,右上角)排序
  43.     (setq pts (vl-sort pts '(lambda(e1 e2) (not (> (car e1) (car e2))))))
  44.     (setq pts (vl-sort pts '(lambda(e1 e2) (not (> (cadr e1) (cadr e2))))))
  45.     (list  (last pts) (cadr pts) (car pts) (caddr pts))
  46.   )
  47.   
  48.   ;获得点p1和p2两点的中点坐标
  49.   (defun MidPof2P (p1 p2)
  50.     (mapcar '(lambda(x y) (/ (+ x y) 2.0) ) p1 p2)
  51.   )

  52.   ;获得点pt1到其pt2和pt3两点形成线的垂直点(垂足)坐标
  53.   (defun PtPerTo2Pts (pt1 pt2 pt3 / pt4 ang PerPt)
  54.     (setq ang (angle pt2 pt3)
  55.           pt4 (polar pt1 (+ ang (/ pi 2)) 1)
  56.           PerPt (inters pt1 pt4 pt2 pt3 nil)
  57.     )
  58.   )

  59.   ;获得传递来的直线端点集合返回直线所有交点集合
  60.   (defun getinter(line / x y lines inter)
  61.     (setq x 0 y 2 lines line)
  62.     (setq inter '())
  63.     (repeat (- (/ (length lines) 2) 1)
  64.       (repeat (- (/ (- (length lines) x) 2) 1)
  65.         (if (inters (nth x lines)(nth (+ x 1) lines)(nth y lines)(nth (+ y 1) lines))
  66.             (setq inter (cons (inters (nth x lines)(nth (+ x 1) lines)(nth y lines)(nth (+ y 1) lines)) inter))
  67.         )
  68.         (setq y (+ y 2))
  69.       )
  70.       (setq x (+ x 2))
  71.       (setq y (+ x 2))
  72.      )
  73.      (reverse inter)
  74.   )

  75.   ;获得传递来的直线集合返回直线端点集合
  76.   (defun getlines (sszx / ss i en lines)
  77.     (if (setq ss sszx)
  78.         (progn
  79.           (setvar "OSMODE" 0)
  80.           (setq i -1)
  81.           (repeat (sslength ss)
  82.             (setq en (ssname ss (setq i (1+ i))))
  83.             (setq lines (append lines (getline en)))
  84.           )
  85.         )
  86.     )
  87.     (if lines lines)
  88.   )

  89.   ;根据直线名获得直线的两个端点集合
  90.   (defun getline (lname / pts x )
  91.     (setq pts '())
  92.     (mapcar '(lambda (x)
  93.                (if (or (= (car x) 10) (= (car x) 11))
  94.                    (setq pts (cons (3dPoint->2dPoint(cdr x)) pts))
  95.                )
  96.               )
  97.               (entget lname)
  98.     )
  99.     (reverse pts)
  100.   )

  101.   ;3D点转3D点
  102.   (defun 3dPoint->2dPoint  (3dpt)
  103.     (list (float (car 3dpt)) (float (cadr 3dpt)))
  104.   )

  105.   ;判断点是否在多边形内
  106.   (defun isptinpm (pt ptl)
  107.     (equal pi(abs(apply '+(mapcar'(lambda (x y)(rem (- (angle pt x) (angle pt y)) pi))
  108.                                (reverse (cdr (reverse (cons (last ptl) ptl))))
  109.                           ptl
  110.                        )
  111.                )
  112.           )
  113.          1e-6
  114.      )
  115.   )

  116.   (defun MakeDimAlign (d70 d50 d1 p10 p11 p13 p14 lay color / en000)
  117.     (setq en000
  118.        (list
  119.          (cons 0 "DIMENSION")
  120.          (cons 100 "AcDbEntity")
  121.          (cons 8 lay)
  122.          (cons 100 "AcDbDimension")
  123.          (cons 10 p10)
  124.          (cons 11 p11)
  125.          (cons 70 d70)
  126.          (cons 1 d1)
  127.          (cons 100 "AcDbAlignedDimension")
  128.          (cons 13 p13)
  129.          (cons 14 p14)
  130.          (cons 50 d50)
  131.        )
  132.     )
  133.     (if (= (logand d70 5) 0)
  134.         (setq en000 (append en000 (list '(100 . "AcDbRotatedDimension"))))
  135.     )
  136.     (if (/= -1 color) (setq en000 (append en000 (list (cons 62 color)))))
  137.     (if (= nil (entmake en000)) (princ "\n无法生成 Dim 实体."))
  138.   )

  139.   ;标注点
  140.   (defun dimpt (dpt1 dpt2 dpt3 / d d_strLen TxtWidth)  
  141.     (setq d (distance dpt1 dpt2)
  142.           d_strLen (strlen (itoa (fix (+ d 0.5))))
  143.           TxtWidth (* DimtxtHeight FontWidFactor d_strLen)
  144.           p11 (MidPof2P dpt1 dpt2)
  145.           p11 (polar p11 (angle dpt2 dpt3) (+ D147 D147 DimDistance))
  146.     )
  147.     (if (< (- d TxtWidth) 1)
  148.           (setq d70 128         
  149.                 p11 (polar p11 (angle dpt2 dpt1) (/ TxtWidth 2))
  150.           )
  151.           (setq d70 32)
  152.     )
  153.     (setq d50 (angle dpt1 dpt2))
  154.     (MakeDimAlign d70  d50 "" dpt3 p11 dpt1 dpt2 "PUB_DIM" -1)
  155.     (princ)
  156.   )

  157.   ;主程序开始
  158.   (setq olderr *error*)
  159.   (setq *error* myerr)
  160.   (setq oldcmdecho (getvar "cmdecho"))
  161.   (setq oldosmode (getvar "osmode"))
  162.   (setvar "cmdecho" 0)
  163.   (setvar "osmode" 0)
  164.   (setq DimSyl (cdr(assoc 2(tblnext "Dimstyle" t)))                                   ;取得当前的标注样式
  165.         DimtxtHeight (cdr(assoc 140 (tblsearch "Dimstyle" DimSyl)))                   ;标注样式中文字的高度
  166.         DimFont (cdr(assoc 2 (entget(cdr(assoc 340 (tblsearch "Dimstyle" DimSyl)))))) ;标注用到的字体名称
  167.         FontWidFactor (cdr (assoc 41 (tblsearch "style" DimFont)))                    ;文字的宽度系数
  168.         D147 (cdr(assoc 147 (tblsearch "Dimstyle" DimSyl))))                          ;文字离尺寸线的距离;
  169.         ;TxtWidth (* (strlen(itoa(fix (+ RealLength 0.4)))) DimtxtHeight FontWidFactor);标注字符串的实际长度

  170.   ;柱层和轴线层默认设置为广厦的图层
  171.   (if (not ColumnLayer) (setq ColumnLayer "承台"))
  172.   (if (not AxisLayer) (setq AxisLayer "axis,dote,轴线"))
  173.   (setq DimDistance 800)


  174.   (setq tpt1 (getpoint "\n框选要标注的对象(以框选的方位定标注的方位):"))
  175.   (setq tpt2 (getcorner tpt1))
  176.   
  177.   (if (setq s (ssget  "w" tpt1 tpt2 (list (cons 0  "LWPOLYLINE")(cons 8  ColumnLayer))))
  178.    (progn
  179.    (setq n (sslength s) in 0)

  180.    (cond ((and (< (car tpt1) (car tpt2)) (> (cadr tpt1) (cadr tpt2))) (setq ss "1")) ;左上
  181.          ((and (< (car tpt1) (car tpt2)) (< (cadr tpt1) (cadr tpt2))) (setq ss "2")) ;左下
  182.          ((and (> (car tpt1) (car tpt2)) (< (cadr tpt1) (cadr tpt2))) (setq ss "3")) ;右下      
  183.          ((and (> (car tpt1) (car tpt2)) (> (cadr tpt1) (cadr tpt2))) (setq ss "4")) ;右上
  184.    )
  185.    (repeat n
  186.      (setq e (ssname s in) in (1+ in)
  187.            ptl (getpline e)
  188.            p1 (nth 0 ptl)
  189.            p2 (nth 1 ptl)
  190.            p3 (nth 2 ptl)
  191.            p4 (nth 3 ptl)
  192.            ssaxis (ssget "Cp" ptl (list (cons 0 "LINE") (cons 8 AxisLayer)))
  193.      )
  194.      (setq interss (getinter (getlines ssaxis)));获取所有轴线交点坐标
  195.      ;插入轴线交点集合,查找适合的点
  196.      (setq x -1)
  197.      (repeat (length interss)
  198.        (setq pp (nth (setq x (+ 1 x)) interss))
  199.        ;(if (< (max(distance pp p1)(distance pp p2)(distance pp p3)(distance pp p4)) (distance p1 p3))
  200.        ;    (setq p0 pp)
  201.        ;)
  202.        (if (isptinpm pp ptl) (setq p0 pp))
  203.      )

  204.      (if p0
  205.          (progn
  206.            (setq
  207.              p12 (PtPerTo2Pts p0 p1 p2)
  208.              p14 (PtPerTo2Pts p0 p1 p4)
  209.              p32 (PtPerTo2Pts p0 p3 p2)
  210.              p34 (PtPerTo2Pts p0 p3 p4)
  211.              p141 (polar p14 (angle p0 p14) DimDistance)
  212.              p121 (polar p12 (angle p0 p12) DimDistance)
  213.              p341 (polar p34 (angle p0 p34) DimDistance)
  214.              p321 (polar p32 (angle p0 p32) DimDistance)
  215.            )
  216.            (cond ((= ss "1")(dimpt p1 p12 p121)(dimpt p2 p12 p121)(dimpt p1 p14 p141)(dimpt p4 p14 p141));左上
  217.                  ((= ss "2")(dimpt p1 p12 p121)(dimpt p2 p12 p121)(dimpt p3 p32 p321)(dimpt p2 p32 p321));左下
  218.                  ((= ss "3")(dimpt p3 p34 p341)(dimpt p4 p34 p341)(dimpt p3 p32 p321)(dimpt p2 p32 p321));右下
  219.                  ((= ss "4")(dimpt p3 p34 p341)(dimpt p4 p34 p341)(dimpt p1 p14 p141)(dimpt p4 p14 p141));右上
  220.            )
  221.          )
  222.      )
  223.    )
  224.    )
  225.   )
  226.   (myend)
  227.   (princ)
  228. )

  229. (defun c:dsz ()
  230.   (vl-catch-all-error-p
  231.    (vl-catch-all-apply
  232.    '(lambda ()
  233.       (setq AxisLayer (cdr(assoc 8 (entget (car (entsel "\n选取轴线所在层:"))))))
  234.       (setq ColumnLayer (cdr(assoc 8 (entget (car (entsel "\n选取要标注矩形所在层:"))))))
  235.     )
  236.    )
  237.   )
  238.   (princ)
  239. )

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
 楼主| 发表于 2012-5-22 13:05:51 | 显示全部楼层
xiaoyingzi 发表于 2012-5-21 20:50
发个用楼主的改的,特点:采用鼠标框选的角点方位来定标注尺寸的位置
命令:dsz 设置图层
命令:dzz 定位 ...

不错,很好啊!
发表于 2012-5-22 13:34:53 | 显示全部楼层
xiaoyingzi 发表于 2012-5-21 20:50
发个用楼主的改的,特点:采用鼠标框选的角点方位来定标注尺寸的位置
命令:dsz 设置图层
命令:dzz 定位 ...

承台线如果是L线,能否标注呢???
发表于 2012-5-22 14:06:52 | 显示全部楼层
line线不能,可以先用程序连成闭合多义线
发表于 2012-6-27 23:18:23 | 显示全部楼层
提示: 作者被禁止或删除 内容自动屏蔽
发表于 2012-7-26 15:40:42 | 显示全部楼层
提示: 作者被禁止或删除 内容自动屏蔽
您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-11-17 02:30 , Processed in 0.943417 second(s), 91 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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