设为首页收藏本站CAD论坛CAD教程CAD下载明经币充值
切换到宽版

明经CAD社区

 找回密码
 注册

QQ登录

只需一步，快速开始

搜索
明经CAD社区»社区 › 开发篇 › AutoLISP/Visual LISP 编程技术 › 连续明细标注（新手报到帖）欢迎拍砖
返回列表 发新帖
查看: 2624|回复: 6

[源码] 连续明细标注（新手报到帖）欢迎拍砖

[复制链接]
Rimford
发表于 2014-4-17 22:09:02 | 显示全部楼层 |阅读模式
本帖最后由 Rimford 于 2014-4-17 22:11 编辑

刚到明经社区，有一种相见恨晚的感觉。坛子里的精华太多，看不完啊！
光看贴不发贴，不能称之为交流啊！

这是我自己做的一个可以进行连续明细标注的小程序，还有待进一步完善和扩展，欢迎高手拍砖！
以后我想把明细标注和明细栏关联，请高手指点。之前在清华天河和机械工程师见过类似功能。

  1. (defun c:label_num()
  2.     ;本程序用于零件序号标注，代替多重引线功能
  3.   (commonsets);检查图层设置

  5.     (setvar "clayer" "DIM")
  6.     (setvar "textstyle" "5.0")
  7.   (setq dd 8)(setq dc 1)
  8.   (setq num (getint "\n起始编号 <1>: "))
  9.   (if (null num) (setq num 1))
  10.   (setq dd2(/ dd 5))
  11.   (setq pt1 (getpoint "\n第一点: "))
  12.   (while (/= pt1 nil)
  13.     (command "donut" 0 dd2 pt1 "")
  14.       (setvar "osmode" 16383);打开所有对象捕捉
  15.     (setq pt2 (getpoint "\n第二点: "))
  16.     (setvar "osmode" 0);关闭所有对象捕捉
  17.     (command "line" pt1 pt2 "")
  18.       ;通过pt1-pt2的角度，判断pt3的位置
  19.     (setq ang (angle pt1 pt2))
  20.     (cond  ((and (> ang (* pi 0.5)) (< ang (* pi 1.5)))  (setq pt3 (polar pt2 pi dd)))
  21.       (t (setq pt3 (polar pt2 0 dd)))
  22.     )
  23.     (command "line" pt2 pt3 "")
  24.     (setq en1 (entlast))
  25.    
  26.     (command "text" "m" (polar (get_midpt pt2 pt3) (/ pi 2) (/ dd 2))  0  (itoa num))
  27.     (setq en2 (entlast))

  29.     ;判断是否增加连续序号
  30.       (setq what null)
  31.       (setq num (+ num 1))
  32.       (setq what(getstring "\n[增加连续竖向序号(H)][增加连续横向序号(V)]"))
  33.    
  34.       (if(or (= what "h" ) (= what "H" ))(label_num_H))
  35.       (if(or (= what "v" ) (= what "V" ))(label_num_V))
  36.       ;如果不增加连续序号，则重新开始标注
  37.     (setq pt1 (getpoint "\n第一点: "))
  38.   )
  39.   (prin1)   
  40. )

  42. (defun label_num_V()
  43.     ;本程序用于增加连续横向序号
  44.   (cond  ((and (> ang (* pi 0.0)) (< ang (* pi 0.5)))  (label_num_V1))
  45.       ((and (> ang (* pi 1.0)) (< ang (* pi 1.5)))  (label_num_V1))
  46.       (t (label_num_V2))
  47.     )
  48. )

  50. (defun label_num_V1()
  51.     ;本程序用于增加连续横向序号
  52.    (setq ss1(ssadd))
  53.   (setq en3 nil)

  55.     (setq pan3 "Y")
  56.     (while(= pan3 "Y")
  57.     (cond  ((and (> ang (* pi 0.0)) (< ang (* pi 0.5)))
  58.         (progn
  59.           (setq pt4(polar pt3 (* pi 1.75) dc))
  60.            (setq pt5(polar pt4 (* pi 0.25) dc))
  61.            (setq pt6(polar pt5 (* pi 0.0) dd))
  62.         )
  63.       )
  64.       (t
  65.         (progn
  66.           (setq pt4(polar pt3 (* pi 1.25) dc))
  67.            (setq pt5(polar pt4 (* pi 0.75) dc))
  68.            (setq pt6(polar pt5 (* pi 1.0) dd))
  69.         )
  70.       )
  71.     )
  72.     (command "line" pt3 pt4 "")
  73.     (command "line" pt4 pt5 "")
  74.     (command "line" pt5 pt6 "")
  75.     (command "text" "m" (polar (get_midpt pt5 pt6) (/ pi 2) (/ dd 2)) 0 (itoa num))
  76.   
  77.       (setq pt3 pt6)
  78.   
  79.     (setq num (+ num 1))
  80.     (setq pan3(getstring "\n是否继续横向添加连续序号？[终止添加(N)]"))
  81.       (if (and (/= pan3 "N") (/= pan3 "n"))(setq pan3 "Y"))
  82.   )
  83. )

  85. (defun label_num_V2()
  86.     ;本程序用于增加连续横向序号
  87.   (setq ss1(ssadd));建立或清空选择集
  88.   (setq en3 nil);付值
  89.     (setq en4 nil);付值

  91.     (setq pan4 "Y");付初始值，判断是否继续
  92.     (while(= pan4 "Y")
  93.       (setq ent1 en1)
  94.       (setq ent2 en2)
  95.   
  96.       (ssadd ent1 ss1)
  97.       (ssadd ent2 ss1)
  98.    
  99.       (if(/= en3 nil)
  100.       (progn
  101.           (setq ent3 en3)
  102.           (ssadd ent3 ss1)
  103.       )
  104.     )

  106.       (if(/= en4 nil)
  107.       (progn
  108.           (setq ent4 en4)
  109.           (ssadd ent4 ss1)
  110.       )
  111.     )
  112.    

  114.      (cond  ((and (> ang (* pi 0.5)) (< ang (* pi 1.0)))
  115.          (progn
  116.            (setq pt3(polar pt2 (* pi 1.0) dd))
  117.           (setq pt4(polar pt3 (* pi 1.25) dc))
  118.            (setq pt5(polar pt4 (* pi 0.75) dc))
  119.         )
  120.       )
  121.       ((and (> ang (* pi 1.5)) (< ang (* pi 2.0)))
  122.           (progn
  123.            (setq pt3(polar pt2 (* pi 0.0) dd))
  124.           (setq pt4(polar pt3 (* pi 1.75) dc))
  125.            (setq pt5(polar pt4 (* pi 0.25) dc))
  126.         )
  127.       )
  128.     )
  129.   
  130.       (command "move" ss1 "" pt2 pt5)
  131.   
  132.     (command "line" pt2 pt3 "")
  133.     (setq en1 (entlast))
  134.     (command "text" "m" (polar (get_midpt pt2 pt3) (/ pi 2) (/ dd 2)) 0 (itoa num))
  135.     (setq en2 (entlast))
  136.       (command "line" pt3 pt4 "")
  137.       (setq en3(entlast))
  138.       (command "line" pt4 pt5 "")
  139.       (setq en4(entlast))
  140.   
  141.     (setq num (+ num 1))
  142.     (setq pan4(getstring "\n是否继续横向添加连续序号？[终止添加(N)]"))
  143.       (if (and (/= pan4 "N") (/= pan4 "n"))(setq pan4 "Y"))
  144.   )
  145. )

  147. (defun label_num_H()
  148.     ;本程序用于增加连续纵向序号
  149.   (cond  ((and (> ang (* pi 0.0)) (< ang (* pi 0.5)))  (label_num_H1))
  150.       ((and (> ang (* pi 1.0)) (< ang (* pi 1.5)))  (label_num_H1))
  151.       (t (label_num_H2))
  152.     )
  153.   (prin1)   
  154. )

  156. (defun label_num_H2()
  157.     ;本程序用于增加连续纵向序号
  158.     (setq pan2 "Y")
  159.     (while(= pan2 "Y")
  160.     (cond  ((and (> ang (* pi 0.5)) (< ang (* pi 1.5)))
  161.         (progn
  162.           (setq pt4(polar pt2 (* pi 0.5) dd))
  163.            (setq pt5 (polar pt4 pi dd))
  164.         )
  165.       )
  166.       (t
  167.         (progn
  168.           (setq pt4(polar pt2 (* pi 1.5) dd))
  169.             (setq pt5 (polar pt4 (* pi 0.0) dd))
  170.         )
  171.       )
  172.     )
  173.     (command "line" pt4 pt5 "")
  174.     (command "line" pt2 pt4 "")
  175.     (command "text" "m" (polar (get_midpt pt4 pt5) (/ pi 2) (/ dd 2)) 0 (itoa num))
  176.   
  177.       (setq pt2 pt4)
  178.   
  179.     (setq num (+ num 1))
  180.     (setq pan2(getstring "\n是否继续竖向添加连续序号？[终止添加(N)]"))
  181.       (if (and (/= pan2 "N") (/= pan2 "n"))(setq pan2 "Y"))
  182.   )
  183.   (prin1)   
  184. )

  186. (defun label_num_H1()
  187.     ;本程序用于增加连续纵向序号
  188.   (setq ss1(ssadd))
  189.   (setq en3 nil)

  191.     (setq pan1 "Y")
  192.     (while(= pan1 "Y")
  193.       (setq ent1 en1)
  194.       (setq ent2 en2)
  195.       (ssadd ent1 ss1)
  196.       (ssadd ent2 ss1)
  197.       (if(/= en3 nil)
  198.       (progn
  199.           (setq ent3 en3)
  200.           (ssadd ent3 ss1)
  201.       )
  202.     )
  203.    
  204.      (cond  ((and (> ang (* pi 0.0)) (< ang (* pi 0.5)))  (setq pt4(polar pt2 (* pi 0.5) dd)))
  205.       ((and (> ang (* pi 1.0)) (< ang (* pi 1.5)))  (setq pt4(polar pt2 (* pi 1.5) dd)))
  206.     )

  208.      (command "move" ss1 "" pt2 pt4)
  209.   
  210.     (command "line" pt2 pt3 "")
  211.     (setq en1 (entlast))
  212.     (command "text" "m" (polar (get_midpt pt2 pt3) (/ pi 2) (/ dd 2)) 0 (itoa num))
  213.     (setq en2 (entlast))
  214.       (command "line" pt2 pt4 "")
  215.       (setq en3(entlast))
  216.   
  217.     (setq num (+ num 1))
  218.     (setq pan1(getstring "\n是否继续竖向添加连续序号？[终止添加(N)]"))
  219.       (if (and (/= pan1 "N") (/= pan1 "n"))(setq pan1 "Y"))
  220.   )
  221. )

  223. (defun get_midpt(pt1 pt2);求两点中点坐标
  224.     (setq mx(/ (+ (car pt1) (car pt2)) 2))
  225.       (setq my(/ (+ (cadr pt1) (cadr pt2)) 2))
  226.     (list mx my)
  227. )
  2. <div class="blockcode"><blockquote>;**********************本程序为公用程序，用于加载加载项，设置图层等*******************************
  3. (defun  commonsets()
  4.     ;--------------变量设置-------------------------------------------------
  5.     (setq textfont "SIMFANG.TTF");字体设置为仿宋
  6.     (setq textfont (strcat (strcat (getenv "windir") "\\fonts\") textfont));Windows字体设置
  7. ;;;  (setq bigtextgont "hztxt.shx");大字体设置
  8.     (setq textwidth 0.7);字体比例

  10.     ;------------------ActiveX准备工作-----------------------------------------------------------
  11.     (vl-load-com);加载Visual Lisp扩展功能函数，同时可以控制ActiveX对象
  12.     (setq acadobj(vlax-get-acad-object));取得当前AutoCAD应用程序母体对象
  13.     (setq dwgobj(vla-get-ActiveDocument acadobj));取得作用中的图形文件
  14.     (setq mspace(vla-get-ModelSpace dwgobj));取得模型空间集合对象
  15.     (setq layersobj(vla-get-layers dwgobj));取得图层集合对象
  16.     (setq stylesobj(vla-get-textstyles dwgobj));取得字体集合对象
  17.     (setq linetypesobj(vla-get-linetypes dwgobj));取得字体集合对象
  18.     (setq blocksobj(vla-get-blocks dwgobj));取得图形中的块集合对象
  19.     (setq layoutsobj(vla-get-layouts dwgobj));取得图形中的所有布局设置集合对象
  20.     ;------------------设置图层------------------------------------------------------------------
  21.     ;------------------加载中心线、双点画线和虚线----------
  22.     (vl-catch-all-apply 'vla-load (list linetypesobj "divide" (findfile "acadiso.lin")) );加载双点划线
  23.     (vl-catch-all-apply 'vla-load (list linetypesobj "center" (findfile "acadiso.lin")) );加载中心线
  24.     (vl-catch-all-apply 'vla-load (list linetypesobj "dashed" (findfile "acadiso.lin")) );加载虚线
  25.     ;-------------------取得图层集合列表-------------------
  26.     (setq laylist nil)
  27.     (vlax-for sobj layersobj
  28.     (setq layname(vla-get-name sobj))
  29.         (setq laylist(cons layname laylist))
  30.     )
  31.     ;---------判断图层是否存在，如果不存在，增设该图层-----
  32.     ;---------------设置0图层------------------------------
  33.     (setq lay1(vla-add layersobj "0"))
  34.     (vla-put-color lay1 7)
  35.     (vla-put-linetype lay1 "continuous")
  36.     (vla-put-lineweight lay1 50)
  37.     ;---------------设置CEN图层----------------------------
  38.     (setq lay1(vla-add layersobj "CEN"))
  39.     (vla-put-color lay1 3)
  40.     (vla-put-linetype lay1 "Center")
  41.     (vla-put-lineweight lay1 25)
  42.     ;---------------设置DASH图层---------------------------
  43.     (setq lay1(vla-add layersobj "DASH"))
  44.     (vla-put-color lay1 2)
  45.     (vla-put-linetype lay1 "DASHED")
  46.     (vla-put-lineweight lay1 25)
  47.     ;---------------设置DIM图层----------------------------
  48.     (setq lay1(vla-add layersobj "DIM"))
  49.     (vla-put-color lay1 4)
  50.     (vla-put-linetype lay1 "continuous")
  51.     (vla-put-lineweight lay1 25)
  52.     ;---------------设置DIV图层----------------------------
  53.     (setq lay1(vla-add layersobj "DIV"))
  54.     (vla-put-color lay1 5)
  55.     (vla-put-linetype lay1 "Divide")
  56.     (vla-put-lineweight lay1 25)
  57.     ;---------------设置HAT图层----------------------------
  58.     (setq lay1(vla-add layersobj "HAT"))
  59.     (vla-put-color lay1 6)
  60.     (vla-put-linetype lay1 "continuous")
  61.     (vla-put-lineweight lay1 25)
  62.     ;---------------设置THIN图层---------------------------
  63.     (setq lay1(vla-add layersobj "THIN"))
  64.     (vla-put-color lay1 1)
  65.     (vla-put-linetype lay1 "continuous")
  66.     (vla-put-lineweight lay1 25)
  67.     ;---------------设置TXT图层----------------------------
  68.     (setq lay1(vla-add layersobj "TXT"))
  69.     (vla-put-color lay1 2)
  70.     (vla-put-linetype lay1 "continuous")
  71.     (vla-put-lineweight lay1 25)
  72.     ;---------------设置STR图层----------------------------
  73.     (setq lay1(vla-add layersobj "STR"))
  74.     (vla-put-color lay1 7)
  75.     (vla-put-linetype lay1 "continuous")
  76.     (vla-put-lineweight lay1 50)
  77.     ;-------------------设置文字样式--------------------------------------------------------
  78.     ;-------------------取得文字样式集合列表---------------
  79.     (setq stylist nil)
  80.     (vlax-for tobj stylesobj
  81.     (setq styname(vla-get-name tobj))
  82.         (setq stylist(cons styname laylist))
  83.     )
  84.     ;------------------设置文字样式1.8---------------------
  85.     (setq sty1(vla-add stylesobj "1.8"))
  86.     (vla-put-fontfile sty1 textfont)
  87. ;;;    (vla-put-bigfontfile sty1 bigtextfont)
  88.     (vla-put-height sty1 1.8)
  89.     (vla-put-width sty1 textwidth)
  90.     ;------------------设置文字样式2.5---------------------
  91.     (setq sty1(vla-add stylesobj "2.5"))
  92.     (vla-put-fontfile sty1 textfont)
  93. ;;;    (vla-put-bigfontfile sty1 bigtextfont)
  94.     (vla-put-height sty1 2.5)
  95.     (vla-put-width sty1 textwidth)
  96.     ;------------------设置文字样式3.5---------------------
  97.     (setq sty1(vla-add stylesobj "3.5"))
  98.     (vla-put-fontfile sty1 textfont)
  99. ;;;    (vla-put-bigfontfile sty1 bigtextfont)
  100.     (vla-put-height sty1 3.5)
  101.     (vla-put-width sty1 textwidth)
  102.     ;------------------设置文字样式5.0---------------------
  103.     (setq sty1(vla-add stylesobj "5.0"))
  104.     (vla-put-fontfile sty1 textfont)
  105. ;;;    (vla-put-bigfontfile sty1 bigtextfont)
  106.     (vla-put-height sty1 5.0)
  107.     (vla-put-width sty1 textwidth)
  108.     ;------------------设置文字样式7.0---------------------
  109.     (setq sty1(vla-add stylesobj "7.0"))
  110.     (vla-put-fontfile sty1 textfont)
  111. ;;;    (vla-put-bigfontfile sty1 bigtextfont)
  112.     (vla-put-height sty1 7.0)
  113.     (vla-put-width sty1 textwidth)
  114.     ;------------------设置文字样式10---------------------
  115.     (setq sty1(vla-add stylesobj "10"))
  116.     (vla-put-fontfile sty1 textfont)
  117. ;;;    (vla-put-bigfontfile sty1 bigtextfont)
  118.     (vla-put-height sty1 10)
  119.     (vla-put-width sty1 textwidth)
  120.     ;------------------设置文字样式14---------------------
  121.     (setq sty1(vla-add stylesobj "14"))
  122.     (vla-put-fontfile sty1 textfont)
  123. ;;;    (vla-put-bigfontfile sty1 bigtextfont)
  124.     (vla-put-height sty1 14)
  125.     (vla-put-width sty1 textwidth)
  126.     ;------------------设置文字样式20---------------------
  127.     (setq sty1(vla-add stylesobj "20"))
  128.     (vla-put-fontfile sty1 textfont)
  129. ;;;    (vla-put-bigfontfile sty1 bigtextfont)
  130.     (vla-put-height sty1 20)
  131.     (vla-put-width sty1 textwidth)
  132.   ;-----------------避免不必要的输出--------------------
  133.     (prin1)
  134. ) ;_ 结束defun

本帖子中包含更多资源

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

x

评分

参与人数 2明经币 +2 收起 理由
菜鸟初来乍到 + 1 为焊缝程序来这里加币的，感谢楼主奉献
liuhaixin88 + 1 支持！谢谢分享！

查看全部评分

回复

使用道具 举报

梦里水香
发表于 2014-4-23 15:17:58 | 显示全部楼层
很不错啊，下载下来用了几天，有几个问题想请教一下：
1、能不能把件号跟全局标注比例连接起来，因为标注完后拉件号有时件号太小，不成比例；getvar(dimscale类似这样子的
2、件号对齐不方便，见过langjs弄过一个自动对齐件号的，很不错；《动态引线标注 v2.0》
3、拉出件号的时候能不能是动态可见的，方便调整件号的角度。。。
回复 支持 反对

使用道具 举报

Rimford
 楼主| 发表于 2014-4-24 14:01:43 | 显示全部楼层
梦里水香 发表于 2014-4-23 15:17
很不错啊，下载下来用了几天，有几个问题想请教一下：
1、能不能把件号跟全局标注比例连接起来，因为标注完 ...

这也是我想做的
研究研究先
回复 支持 反对

使用道具 举报

ansyss
发表于 2017-12-18 20:56:31 | 显示全部楼层
楼主请问这个现在优化了吗
回复 支持 反对

使用道具 举报

Rimford
 楼主| 发表于 2017-12-29 22:13:32 | 显示全部楼层
ansyss 发表于 2017-12-18 20:56
楼主请问这个现在优化了吗

你看我另一篇帖子吧，里面有这个优化
回复 支持 反对

使用道具 举报

洪少(刀模)
发表于 2017-12-30 10:52:11 | 显示全部楼层
非常感谢楼主，在这里看到很多VLA函数的用法，谢谢！
回复 支持 反对

使用道具 举报

菜鸟初来乍到
发表于 2023-4-2 08:08:43 | 显示全部楼层
感谢楼主分享
回复 支持 反对

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-11-16 13:24 , Processed in 0.186705 second(s), 27 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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