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

明经CAD社区

 找回密码
 注册

QQ登录

只需一步，快速开始

搜索
明经CAD社区»社区 › 开发篇 › AutoLISP/Visual LISP 编程技术 › 求两个LiSP小程序，一个是加编号的，一个是加边框的
12下一页
返回列表 发新帖
查看: 4722|回复: 15

[源码] 求两个LiSP小程序，一个是加编号的，一个是加边框的

[复制链接]
如梦
发表于 2014-3-8 23:00 | 显示全部楼层 |阅读模式
加边框的能达到图片的效果就行了，加编号的，不要像图片那样非得选择实体的东西，我需要的就是输入命令后直接用鼠标到处去点就能够出来编号了的！谢谢大家了
程序

本帖子中包含更多资源

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

x

相关帖子
回复

使用道具 举报

362896182
发表于 2014-7-3 22:48 | 显示全部楼层
  1. ;;加边框
  2. (Defun c:tt(/ *AcadObject* *DwgObject* *ModelSpace* *Layers* *Blocks* *LineTypes*
  3.       RightDis UpDis selecollection index ptlist VlaObject maxpoint minpoint
  4.       pt1 pt2 pt3 pt4 polylinept polypt )
  5.   (vl-load-com)
  6.   (setq  *AcadObject* (vlax-get-acad-object)
  7.   *DwgObject*  (vla-get-activedocument *AcadObject*)
  8.   *ModelSpace* (vla-get-modelspace *DwgObject*)
  9.   *Layers*     (vla-get-layers *DwgObject*)
  10.   *Blocks*     (vla-get-blocks *DwgObject*)
  11.   *LineTypes*  (vla-get-linetypes *DwgObject*)
  12.   )
  13.   (if (not RightDis_1)(setq RightDis_1 10.0))
  14.   (setq RightDis(getreal (strcat"\n请输入左右偏移距离:<"(rtos RightDis_1)">")))
  15.   (if RightDis(setq RightDis_1 RightDis)(setq RightDis RightDis_1))
  16.   (if (not UpDis_1)(setq UpDis_1 10.0))
  17.   (setq (getreal (strcat"\n请输上下偏移距离:<"(rtos UpDis_1)">")))
  18.   (if UpDis(setq UpDis_1 UpDis)(setq UpDis UpDis_1))
  19.   (setq selecollection(ssget))
  20.   (while selecollection
  21.     (setq index 0 ptlist nil)
  22.     (repeat (sslength selecollection)
  23.   (setq VlaObject(vlax-ename->vla-object(ssname selecollection index)))
  24.   (vlax-invoke-method VlaObject 'GetBoundingBox 'minpoint 'maxpoint)
  25.         (setq maxpoint(vlax-safearray->list maxpoint))
  26.   (setq minpoint(vlax-safearray->list minpoint))
  27.   (setq ptlist(append ptlist(list maxpoint minpoint)))
  28.   (setq index(1+ index))
  29.   )
  30.     (setq MinPoint(apply 'mapcar (cons 'min ptlist)))
  31.     (setq MaxPoint(apply 'mapcar (cons 'max ptlist)))
  32.     (setq pt1(list(-(car MinPoint)RightDis)(-(cadr MinPoint)UpDis)0))
  33.     (setq pt3(list(+(car maxpoint)RightDis)(+(cadr maxpoint)UpDis)0))
  34.     (setq pt2(list(car pt3)(cadr pt1)0))
  35.     (Setq pt4(list(car pt1)(cadr pt3)0))
  36.     (setq polylinept(append pt1 pt2 pt3 pt4 pt1))
  37.     (setq polypt(vlax-make-safearray vlax-vbDouble '(0 . 14)))
  38.     (vlax-safearray-fill polypt  polylinept)
  39.     (vlax-invoke-method *modelspace* 'addpolyline polypt)
  40.     (setq selecollection(ssget))
  41.     )
  42.   (prin1)
  43.   )

回复 支持 反对

使用道具 举报

362896182
发表于 2014-7-3 23:42 | 显示全部楼层
  1. ;;加边框
  2. ;;design:guowei
  3. ;;2014/07/03
  4. (Defun c:tt(/ *AcadObject* *DwgObject* *ModelSpace* *Layers* *Blocks* *LineTypes*
  5.       RightDis UpDis selecollection index ptlist VlaObject maxpoint minpoint
  6.       pt1 pt2 pt3 pt4 polylinept polypt )
  7.   (vl-load-com)
  8.   (setq  *AcadObject* (vlax-get-acad-object)
  9.   *DwgObject*  (vla-get-activedocument *AcadObject*)
  10.   *ModelSpace* (vla-get-modelspace *DwgObject*)
  11.   *Layers*     (vla-get-layers *DwgObject*)
  12.   *Blocks*     (vla-get-blocks *DwgObject*)
  13.   *LineTypes*  (vla-get-linetypes *DwgObject*)
  14.   )
  15.   (if (not RightDis_1)(setq RightDis_1 10.0))
  16.   (setq RightDis(getreal (strcat"\n请输入左右偏移距离:<"(rtos RightDis_1)">")))
  17.   (if RightDis(setq RightDis_1 RightDis)(setq RightDis RightDis_1))
  18.   (if (not UpDis_1)(setq UpDis_1 10.0))
  19.   (setq UpDis(getreal (strcat"\n请输上下偏移距离:<"(rtos UpDis_1)">")))
  20.   (if UpDis(setq UpDis_1 UpDis)(setq UpDis UpDis_1))
  21.   (setq selecollection(ssget))
  22.   (while selecollection
  23.     (setq index 0 ptlist nil)
  24.     (repeat (sslength selecollection)
  25.   (setq VlaObject(vlax-ename->vla-object(ssname selecollection index)))
  26.   (vlax-invoke-method VlaObject 'GetBoundingBox 'minpoint 'maxpoint)
  27.         (setq maxpoint(vlax-safearray->list maxpoint))
  28.   (setq minpoint(vlax-safearray->list minpoint))
  29.   (setq ptlist(append ptlist(list maxpoint minpoint)))
  30.   (setq index(1+ index))
  31.   )
  32.     (setq MinPoint(apply 'mapcar (cons 'min ptlist)))
  33.     (setq MaxPoint(apply 'mapcar (cons 'max ptlist)))
  34.     (setq pt1(list(-(car MinPoint)RightDis)(-(cadr MinPoint)UpDis)0))
  35.     (setq pt3(list(+(car maxpoint)RightDis)(+(cadr maxpoint)UpDis)0))
  36.     (setq pt2(list(car pt3)(cadr pt1)0))
  37.     (Setq pt4(list(car pt1)(cadr pt3)0))
  38.     (setq polylinept(append pt1 pt2 pt3 pt4 pt1))
  39.     (setq polypt(vlax-make-safearray vlax-vbDouble '(0 . 14)))
  40.     (vlax-safearray-fill polypt  polylinept)
  41.     (vlax-invoke-method *modelspace* 'addpolyline polypt)
  42.     (setq selecollection(ssget))
  43.     )
  44.   (prin1)
  45.   )

  47. ;;加编号
  48. ;;desing:guowei
  49. ;;2014/07/03
  50. (DEFUN C:EE(/ *AcadObject* *DwgObject* *ModelSpace* *Layers* *Blocks* *LineTypes*
  51.       TxtHeight txt index InsertPoint TextString)
  52.   (vl-load-com)
  53.   (setq  *AcadObject* (vlax-get-acad-object)
  54.   *DwgObject*  (vla-get-activedocument *AcadObject*)
  55.   *ModelSpace* (vla-get-modelspace *DwgObject*)
  56.   *Layers*     (vla-get-layers *DwgObject*)
  57.   *Blocks*     (vla-get-blocks *DwgObject*)
  58.   *LineTypes*  (vla-get-linetypes *DwgObject*)
  59.   )
  60.   (setq TxtHeight(getvar "dimtxt"))
  61.   (if(not txt_1)(setq txt_1 "荣鑫刀模hg140301-"))
  62.   (setq txt(getstring (strcat"\n请输入前辍:<"txt_1">")))
  63.   (if(or(= txt "")(= txt nil))(setq txt txt_1)(setq txt_1 txt))
  64.   (if(not index_1)(setq index_1 1))
  65.   (setq index(getint (strcat "\n请输入序号:<"(rtos index_1 2 0)">")))
  66.   (if index(setq index_1 index)(setq index index_1))
  67.   (while(setq InsertPoint(trans(getpoint "\n输入序号插入点:")1 0))
  68.     (setq TextString(strcat txt(rtos index 2 0)))
  69.     (vlax-invoke-method *ModelSpace* 'addtext TextString(vlax-3d-point InsertPoint) TxtHeight)
  70.     (setq index_1(setq index(1+ index)))
  71.     )
  72.   (prin1)
  73.   )

评分

参与人数 1明经币 +1 金钱 +20 收起 理由
如梦 + 1 + 20 神马都是浮云

查看全部评分

回复 支持 反对

使用道具 举报

xyp1964
发表于 2014-7-4 08:33 | 显示全部楼层
  2. ;; 加边框，需要e派工具箱(XCAD)的支持
  3. (defun c:tt ()
  4.   (setq dd (Udist 1 "" "边框宽度<输入或鼠标直接量取>" dd nil))
  5.   (while (setq ss (ssget))
  6.     (setq p1 (xyp-Pt2XY (xyp-9pt ss 1) (- dd) (- dd))
  7.           p9 (xyp-Pt2XY (xyp-9pt ss 9) dd dd)
  8.           s1 (xyp-rectang p1 p9)
  9.     )
  10.   )
  11.   (princ)
  12. )
回复 支持 反对

使用道具 举报

ZZXXQQ
发表于 2014-7-4 08:38 | 显示全部楼层
  2. ;尾号递增
  3. (defun c:tt ()
  4. (setvar "CMDECHO" 0)
  5. (vl-load-com)
  6. (setq n 1)
  7. (setq str (if (= (type str) 'STR) str ""))
  8. (setq str (getstring (strcat "\n文字前缀" str ": ")))
  9. (while (setq pt (getpoint "\n封闭区域内一点: "))
  10.   (setq s1 (entlast) ss  (ssadd))
  11.   (command "boundary" pt "")
  12.   (while (setq s1 (entnext s1)) (ssadd s1 ss))
  13.   (if (> (sslength ss) 0) (progn
  14.    (setq i -1 plst (list))
  15.    (repeat (sslength ss)
  16.     (setq en (ssname ss (setq i (1+ i))))
  17.     (vla-getboundingbox(vlax-ename->vla-object en) 'p1 'p2)
  18.     (setq plst (append plst (list(vlax-safearray->list p1)(vlax-safearray->list p2))))
  19.    )
  20.    (command "_.ERASE" ss "")
  21.    (setq p1 (apply 'mapcar (cons 'min plst)))
  22.    (setq p2 (apply 'mapcar (cons 'max plst)))
  23. ;   (setq p1 (list (apply 'min (mapcar 'car plst)) (apply 'min (mapcar 'cadr plst))))
  24. ;   (setq p2 (list (apply 'max (mapcar 'car plst)) (apply 'max (mapcar 'cadr plst))))
  25.    (setq pm (mapcar '(lambda (a b) (/ (+ a b) 2)) p1 p2))
  26.    (command "_.TEXT" "M" pm 300 "" (strcat str (itoa n)))
  27.    (setq n (1+ n))
  28.   ))
  29. )
  30. (setvar "CMDECHO" 1)
  31. (princ)
  32. )
  2. ;;加边框
  3. (defun c:ttt ()
  4. (setvar "CMDECHO" 0)
  5. (vl-load-com)
  6. (setq bx (getdist "\nEnter Around Space 输入四周间隔: "))
  7. (while (progn (princ "\n选择加框物体: ") (setq ss (ssget)))
  8.   (setq i -1 plst (list))
  9.   (repeat (sslength ss)
  10.    (setq en (ssname ss (setq i (1+ i))))
  11.    (vla-getboundingbox(vlax-ename->vla-object en) 'p1 'p2)
  12.    (setq plst (append plst (list(vlax-safearray->list p1)(vlax-safearray->list p2))))
  13.   )
  14.   (setq p1 (apply 'mapcar (cons 'min plst)))
  15.   (setq p2 (apply 'mapcar (cons 'max plst)))
  16.   (setq p1 (mapcar '- p1 (list bx bx)))
  17.   (setq p2 (mapcar '+ p2 (list bx bx)))
  18.   (command "_.RECTANG" p1 p2)
  19. )
  20. (setvar "CMDECHO" 1)
  21. (prin1)
  22. )
回复 支持 反对

使用道具 举报

xyp1964
发表于 2014-7-4 08:41 | 显示全部楼层
;; e派工具箱内置功能

本帖子中包含更多资源

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

x
回复 支持 反对

使用道具 举报

如梦
 楼主| 发表于 2014-7-4 20:22 | 显示全部楼层
xyp1964 发表于 2014-7-4 08:41
;; e派工具箱内置功能

院长，我那个图片就是你内置的，坦白讲，你的确实很好，但是我们这个行业用不着那么大的工具箱，加载太慢了。。。。让你分离出来。你不愿意。。我只能在这里求兄弟们了。。。

点评

xyp1964
兄弟，你太较劲了  发表于 2014-7-5 09:39
回复 支持 反对

使用道具 举报

如梦
 楼主| 发表于 2014-7-4 20:52 | 显示全部楼层
362896182 发表于 2014-7-3 23:42

谢谢，兄弟你那个加板框的还有问题，文字是块的那种会出现问题，你的加编号是是很好的，没有问题，zz的编号是不对的，你这个板框和zz的是一样的问题，希望能给改进下
回复 支持 反对

使用道具 举报

ZZXXQQ
发表于 2014-7-4 22:19 | 显示全部楼层
如梦 发表于 2014-7-4 20:52
谢谢，兄弟你那个加板框的还有问题，文字是块的那种会出现问题，你的加编号是是很好的，没有问题，zz的编 ...

程序调试没问题。要不给个调试图。
回复 支持 反对

使用道具 举报

恕放之生命
发表于 2014-7-11 22:14 | 显示全部楼层
新手路过学习一下，谢谢分享。
回复 支持 反对

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-5-3 13:57 , Processed in 0.732553 second(s), 32 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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