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

明经CAD社区

 找回密码
 注册

QQ登录

只需一步，快速开始

搜索
明经CAD社区»社区 › 开发篇 › AutoLISP/Visual LISP 编程技术 › 单向阵列
12345下一页
返回列表 发新帖
查看: 12797|回复: 42

[源码] 单向阵列

[复制链接]
自贡黄明儒
发表于 2013-5-29 10:41:19 | 显示全部楼层 |阅读模式
本帖最后由 自贡黄明儒 于 2013-6-13 15:03 编辑

  1. ;;;;;;;;;;;;;;;;;;;;;;单向阵列,文字递增或递减SingleArray
  2. (defun C:SA (/ $ORR MY*ERROR* P0 P1 SS0 SSP0 SSP1 SS_MOVE)
  3.   ;;0  错误处理
  4.   (defun MY*error* (s)
  5.     ;;如果有活动编组，先结束之
  6.     (if (= 8 (logand (getvar "undoctl") 8))
  7.       (command "_undo" "_e")
  8.     )
  9.     (if ss_move
  10.       (command "._erase" ss_move "")
  11.     )
  12.     (setq *error* $orr)
  13.     (princ "\n 出错啦!")
  14.   )
  15.   ;;1  尾数是数字,则加1
  16.   (defun endIncrease (otxt)
  17.     (if (obaEndIsNumber otxt)
  18.       (EndNumberS otxt T)                                   ;增1
  19.       (setq otxt (strcat otxt "1"))
  20.     )
  21.   )
  22.   ;;2  选择集内数字增加
  23.   (defun change (ss1 / ELIST N OBN OTXT)
  24.     (repeat (setq n (sslength ss1))
  25.       (setq obn (ssname ss1 (setq n (1- n))))
  26.       (setq elist (entget obn))
  27.       (cond ((wcmatch (LI_item 0 elist) "ATTDEF")
  28.              (setq otxt (endIncrease (LI_item 2 elist)))
  29.              (entmod (subst (cons 2 otxt) (assoc 2 elist) elist))
  30.             )
  31.             (T
  32.              (setq otxt (endIncrease (LI_item 1 elist)))
  33.              (entmod (subst (cons 1 otxt) (assoc 1 elist) elist))
  34.             )
  35.       )
  36.     )
  37.   )
  38.   ;;3  对象na之后所有实体产生的选择集
  39.   (defun newsel (na / ss e1)
  40.     (if na
  41.       (setq na (entnext na))
  42.       (setq na (entnext))
  43.     )
  44.     (setq ss (ssadd))
  45.     (while na
  46.       (setq e1 (entget na))
  47.       (if (wcmatch (LI_item 0 e1) "VERTEX,SEQEND,ATTRIB")
  48.         nil
  49.         (setq ss (ssadd na ss))
  50.       )
  51.       (setq na (entnext na))
  52.     )
  53.     ss
  54.   )
  55.   ;;4.1 非曲线时，鼠标移动
  56.   (defun do_move (ss0 p0 p1-p0 n / B P1)
  57.     (if ss_move
  58.       (command "._erase" ss_move "")
  59.     )
  60.     (setq b (entlast))
  61.     (setq p1 p0)
  62.     (repeat n
  63.       (setq p1 (mapcar '+ p1 p1-p0))
  64.       (command "copy" ss0 "" "non" p0 "non" p1)
  65.     )
  66.     (setq ss_move (newsel b))
  67.   )
  68.   ;;4.2 非曲线时，阵列
  69.   (defun do_arry (ss0 p0 p1-p0 n / B P1 SS SS1)
  70.     (if ss_move
  71.       (command "._erase" ss_move "")
  72.     )
  73.     (setq p1 p0)
  74.     (setq ss ss0)
  75.     (repeat n
  76.       (setq b (entlast))
  77.       (command "copy" ss "" "non" p1 "non" (setq p1 (mapcar '+ p1 p1-p0)))
  78.       (setq ss (newsel b))
  79.       (command "._Select" ss "")
  80.       (if (setq ss1 (ssget "_p" '((0 . "*TEXT,ATTDEF"))))
  81.         (change ss1)
  82.       )
  83.     )
  84.   )
  85.   ;;4 非曲线时，移动阵列
  86.   (defun p0-next (ss0 p0 p1 / A CODE DISTANC LOOP N NN P1-P0 P2 SS)
  87.     (setq p1-p0 (mapcar '- p1 p0))
  88.     (setq distanc (distance p1 p0))
  89.     (princ "\n    >>>> 输入距离或者拾取点,阵列到:")
  90.     (setq loop T)
  91.     (while loop
  92.       (setq code (grread T 8))
  93.       (cond ((= (car code) 5)
  94.              (setq p2 (cadr code))
  95.              (setq nn n)
  96.              (setq n (fix (/ (distance p2 p0) distanc)))
  97.              (if (/= nn n)
  98.                (do_move ss0 p0 p1-p0 n)
  99.              )
  100.             )
  101.             (t (setq loop nil) (do_arry ss0 p0 p1-p0 n))
  102.       )
  103.     )
  104.   )
  105. ;;5.3 曲线时，鼠标移动
  106.   (defun curve-move (ss0 p00 distanc n en / B DIS DP1)
  107.     (if ss_move
  108.       (command "._erase" ss_move "")
  109.     )
  110.     (setq b (entlast))
  111.     (setq dis (vlax-curve-getDistAtPoint en p00))
  112.     (repeat (abs n)
  113.       (setq p1 (vlax-curve-getPointAtDist en (setq dis (+ dis distanc))))
  114.       (command "_.copy" ss0 "" "non" p00 "non" p1)
  115.     )
  116.     (setq ss_move (newsel b))
  117.   )
  118.   ;;5.2 曲线时，阵列
  119.   (defun curve-arry (ss0 p00 distanc n en / AN B DIS P1 PP PT SS SS1 VT an0)
  120.     (if ss_move
  121.       (command "._erase" ss_move "")
  122.     )
  123.     (setq dis (vlax-curve-getDistAtPoint en p00))
  124.     (setq pp  (vlax-curve-getParamAtPoint en p00)           ;得到这点参数
  125.           vt  (vlax-curve-getFirstDeriv en pp)              ;得到切线
  126.           an0 (angle '(0 0 0) vt)                           ;切线角
  127.     )
  128.     (setq ss ss0)
  129.     (setq pt p00)
  130.     (repeat (abs n)
  131.       (setq b (entlast))
  132.       (setq p1 (vlax-curve-getPointAtDist en (setq dis (+ dis distanc))))
  133.       (command "_.copy" ss "" "non" pt "non" p1)
  134.       (setq pt p1)
  135.       (setq pp (vlax-curve-getParamAtPoint en p1)           ;得到这点参数
  136.             vt (vlax-curve-getFirstDeriv en pp)             ;得到切线
  137.             an (angle '(0 0 0) vt)                          ;切线角
  138.       )
  139.       (setq ss (newsel b))
  140.       (command "_.rotate" SS "" "non" p1 (/ (* 180 (- an an0)) pi))
  141.       (setq an0 an)
  142.       (command "._Select" ss "")
  143.       (if (setq ss1 (ssget "_p" '((0 . "*TEXT,ATTDEF"))))
  144.         (change ss1)
  145.       )
  146.     )
  147.   )
  148.   ;;5.1 检测到曲线时，移动阵列
  149.   (defun curveDoNext (ss0 p0 p1 en / CODE DIST0 DIST1 DIST2 DISTANC LOOP N NN P00 P11 P2)
  150.     (setq p00 (vlax-curve-getClosestPointTo en p0))
  151.     (setq dist0 (vlax-curve-getDistAtPoint en p00))
  152.     (setq p11 (vlax-curve-getClosestPointTo en p1))
  153.     (setq dist1 (vlax-curve-getDistAtPoint en p11))
  154.     (setq distanc (- dist1 dist0))
  155.     (princ "\n    >>>> 输入距离或者拾取点,阵列到:")
  156.     (setq loop T)
  157.     (while loop
  158.       (setq code (grread T 8))
  159.       (cond ((= (car code) 5)
  160.              (setq p2 (cadr code))
  161.              (setq nn n)
  162.              (setq p2 (vlax-curve-getClosestPointTo en p2))
  163.              (setq dist2 (vlax-curve-getDistAtPoint en p2))
  164.              (setq n (fix (/ (- dist2 dist0) distanc)))
  165.              (if (/= nn n)
  166.                (curve-move ss0 p00 distanc n en)
  167.              )
  168.             )
  169.             (t (setq loop nil) (curve-arry ss0 p00 distanc n en))
  170.       )
  171.     )
  172.   )
  173.   ;;5 检测到曲线时，判断是否有相同的曲线
  174.   (defun curveDo (ss0 SSp0 SSp1 p0 p1 / BOOL BOOL1 EN I N)
  175.     ;;检测两个选择集是否有相同的曲线
  176.     (setq bool T)
  177.     (setq n (sslength SSp0))
  178.     (setq i -1)
  179.     (while bool
  180.       (setq en (ssname SSp0 (setq i (1+ i))))
  181.       (if (ssmemb en SSp1)
  182.         (progn (setq bool nil) (setq bool1 T))
  183.       )
  184.       (if (= i n)
  185.         (setq bool nil)
  186.       )
  187.     )
  188.     (if bool1
  189.       (curveDoNext ss0 p0 p1 en)
  190.       (p0-next ss0 p0 p1)
  191.     )
  192.   )
  193.   ;;6 本程序主程序
  194.   (command "undo" "be")
  195.   (setq $orr *error*)
  196.   (setq *error* MY*error*);保证自定义出错处理函数执行,将(defun MY*error*定义为(defun *error*时，可以不用这句
  197.   (if (and (princ "\n > 选择对象来阵列:")
  198.            (setq ss0 (ssget))
  199.            (ayEntSSHighLight ss0)
  200.       )
  201.     (progn
  202.       (if (setq p0 (getpoint "\n  >> 基点:"))
  203.         (setq SSp0 (ssget "c" p0 p0 '((0 . "*line,arc"))))
  204.       )
  205.       (if (and p0 (setq p1 (getpoint p0 "\n   >>> 输入距离或者拾取点,阵列间距:")))
  206.         (setq SSp1 (ssget "c" p1 p1 '((0 . "*line,arc"))))
  207.       )
  208.       (if (and p0 p1 (not (equal p0 p1 0.01)))
  209.         (if (and SSp0 SSp1)
  210.           (curveDo ss0 SSp0 SSp1 p0 p1)
  211.           (p0-next ss0 p0 p1)
  212.         )
  213.       )
  214.     )
  215.   )
  216.   (setq *error* $orr)
  217.   (command "undo" "e")
  218.   (princ)
  219. )
  220. ;;;;;;;;;;;;;;;;;;;;;;单向阵列,文字递增或递减SingleArray




本帖子中包含更多资源

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

x

点评

weiqi
非常不错 有我梦寐以求的 G版 沿线的样子 呵呵  发表于 2013-6-6 19:04

评分

参与人数 1明经币 +1 收起 理由
669423907 + 1 做BOM时很好用，非常感谢

查看全部评分

"觉得好，就打赏"
打赏
还没有人打赏，支持一下
回复

使用道具 举报

自贡黄明儒
 楼主| 发表于 2013-5-29 17:29:48 | 显示全部楼层
本帖最后由 自贡黄明儒 于 2013-5-30 09:03 编辑

  1. ;; 亮显选择集或对象(夹点不显示) 函数
  2.   (defun ayEntSSHighLight (SSorEntName / oldGrips)
  3.     (setq oldGrips (getvar "Grips"))
  4.     (setvar "Grips" 0)
  5.     (cond ((= (type SSorEntName) 'PICKSET)                                                                                                                                                    ; 选择集.
  6.            (sssetfirst nil SSorEntName)
  7.           )                                                                                                                                                                                   ; end_switch
  8.           ((= (type SSorEntName) 'ENAME)                                                                                                                                                      ; 单一实体.
  9.            (sssetfirst nil (ssadd SSorEntName (ssadd)))
  10.           )                                                                                                                                                                                   ; end_switch
  11.     )                                                                                                                                                                                         ; end_cond
  12.     (setvar "Grips" oldGrips)
  13.   )

  15. (Defun LI_item (N E) (CDR (Assoc N E)));;(setq str "aa 10.2 b10x20.002")
  16. (defun EndNumberS (str bool / ENDNUMBER N N1 N2 N3 NEND QIANZ SCOR STREND ZNUMBER)
  17.   (setq n3 (strlen str))  ;字符串总长
  18.   (setq strEND (getNumberS str));末尾数字的字符串
  19.   (setq Nend (nth (1- (length strEND)) strEND))
  20.   (setq n1 (strlen Nend))  ;最后一位数字符串总长
  21.   (setq qianZ (substr str 1 (- n3 n1)));前缀
  22.   (setq Znumber (fix (atof Nend))) ;最后一位数字小数前数字
  23.   (setq n2 (strlen (itoa Znumber))) ;最后一位数字小数前数字长度
  24.   (setq n (- n1 n2 1))   ;小数位数
  25.   (if (> n 0)
  26.     (progn
  27.       (setq Nend (* (expt 10 n) (atof Nend)))
  28.       (if bool
  29. (setq endnumber (1+ Nend))
  30. (setq endnumber (1- Nend))
  31.       )
  32.       (setq scor (strcat qianZ (rtos (/ endnumber (expt 10 n)) 2 3)))
  33.     )
  34.     (progn
  35.       (if bool
  36. (setq endnumber (1+ (atoi Nend)))
  37. (setq endnumber (1- (atoi Nend)))
  38.       )
  39.       (setq scor (strcat qianZ (itoa endnumber)))
  40.     )
  41.   )
  42.   scor
  43. )

回复 支持 0 反对 1

使用道具 举报

GILES.LEI
发表于 2016-10-23 12:48:05 | 显示全部楼层
一开始那个版本只懂改成让文字也能阵列，递增还做不到，黄大师能否指点一下
回复 支持 反对

使用道具 举报

springwillow
发表于 2013-5-29 11:17:48 | 显示全部楼层
这个功能对路的可能有用啊！支持！

点评

自贡黄明儒
我主要用于序号增加,布置编号,托辊沿线布置,明细表中非标图号填写等  发表于 2013-5-29 11:21
回复 支持 反对

使用道具 举报

云中孤鹰
发表于 2013-5-29 17:22:46 | 显示全部楼层
多谢分享，较为实用
回复 支持 反对

使用道具 举报

669423907
发表于 2013-5-29 17:25:41 | 显示全部楼层
无论我怎么选，都一直提示“出错啦！”

点评

自贡黄明儒
注释这句试试(ayEntSSHighLight ss0)  发表于 2013-5-29 17:27
回复 支持 反对

使用道具 举报

669423907
发表于 2013-5-29 17:29:45 | 显示全部楼层
不明白什么意思？

点评

自贡黄明儒
本程序有些函数没有提供,可能是出错的原因,你可以去掉才行.  发表于 2013-5-29 17:31
回复 支持 反对

使用道具 举报

自贡黄明儒
 楼主| 发表于 2013-5-29 17:34:18 | 显示全部楼层
;;;所取字符串末尾是不是数,返回真假
(defun obaEndIsNumber (otxt / E OBALENGTH)
  (setq obaLength (strlen otxt))
  (setq e (ascii (substr otxt obaLength 1)))
  (and (> e 47) (< e 58))
) ;_ 结束defun
;;; 结束defun obaEndIsNumber
回复 支持 反对

使用道具 举报

yoyoho
发表于 2013-5-29 17:50:12 | 显示全部楼层
单向阵列.lsp程序无法使用!
回复 支持 反对

使用道具 举报

wowan1314
发表于 2013-5-29 18:14:14 | 显示全部楼层
很不错！ 支持下
回复 支持 反对

使用道具 举报

成仔
发表于 2013-5-30 08:42:50 | 显示全部楼层
多谢分享，较为实用，支持下
回复 支持 反对

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-11-16 14:38 , Processed in 0.202395 second(s), 30 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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