明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
12
返回列表 发新帖
楼主: 树櫴希德

石必强大神函数excel数字日期转cad

[复制链接]
 楼主| 发表于 2021-1-28 21:21:48 | 显示全部楼层
  1. ;获取所有字体样式
  2. (defun EF:Style-getAllTextStyles (
  3.                                    /
  4.                                    TextStyles lstFonts
  5.                                    Typeface Bold Italic CharSet PitchAndFamily
  6.                                  )
  7.   (setq TextStyles (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument) 'TextStyles))
  8.   (vlax-for TextStyle TextStyles
  9.     (vla-getFont TextStyle 'Typeface 'Bold 'Italic 'CharSet 'PitchAndFamily)
  10.     (setq lstFonts (cons
  11.                      (list
  12.                            (vla-get-Name TextStyle)
  13.                            (vla-get-FontFile TextStyle)
  14.                            (vla-get-BigFontFile TextStyle)
  15.                            Typeface
  16.                            (vla-get-Height TextStyle)
  17.                            (vla-get-Width TextStyle)
  18.                            (vla-get-ObliqueAngle TextStyle)
  19.                          )
  20.                      lstFonts
  21.                    )
  22.     )
  23.   )
  24.   (reverse lstFonts)
  25. )

  26. ;;167.7 [功能] Entmake居中单行文字
  27. (defun EntmakeText (PT STR Textheigh style)
  28.   (entmakeX
  29.     (list '(0 . "TEXT")
  30.    (cons 1 str)
  31.    (cons 10 pt)
  32.    (cons 40 Textheigh)
  33.    (cons 11 pt)
  34.     (cons 7 style)
  35.    (cons 72 1)
  36.    (cons 73 2)
  37.     )
  38.   )
  39. )
  40. (setq i 0)
  41. (foreach a (EF:Style-getAllTextStyles)


  42. (EntmakeText (getpoint"\n请点击位置:") "区123" 30 (car a))
  43. (setq i (1+ i)) (print i)


  44.   )
  45. (princ)
  46. ;(nth 20 (EF:Style-getAllTextStyles))

 楼主| 发表于 2021-2-1 21:03:06 | 显示全部楼层
  1. (defun PoInPl(pt lst / i p1 p2 an anl ret)
  2.     (setq i -1 p1 (last lst))
  3.     (while(and(not ret)(setq p2(nth(setq i(1+ i))lst)))
  4.       (cond((equal p2 pt 1e-6)(setq ret t))
  5.      (t(setq an(-(angle pt p1)(angle pt p2)))
  6.       (if(equal pi(abs an) 1e-6)
  7.         (setq ret t)
  8.         (setq anl(cons(rem an PI)anl)))))
  9.       (setq p1 p2))
  10.     (cond(ret 0);线上;
  11.    (t(if(equal PI(abs(apply'+ anl))1e-6)1 -1))))
  12.   (defun PlDir(p / n m p1 p2 p3 o a a1 a2)
  13.     (setq n(length p)pi2(+ pi pi)m 2 p1(nth 0 p)p2(nth 1 p))
  14.     (while(< m n)
  15.       (setq p3(nth m p)
  16.       o(list(/(+(+(car p1)(car p2))(car p3))3)(/(+(+(cadr p1)(cadr p2))(cadr p3))3))
  17.       m(if(<(PoInPl o p)1)n(1+ m))))
  18.     (setq a(angle o p1) a1(-(angle o p2)a)
  19.     a1(if(< a1 0)(+ a1 pi2)a1)
  20.     a2(-(angle o p3)a)
  21.     a2(if(< a2 0)(+ a2 pi2)a2)
  22.     m(if(> a1 a2)t)))
  23.   (defun Plinexy(e / p a b n ob q et d d1 en et)
  24.     (setq a(entget e)ob(vlax-ename->vla-object e)et(cdr(assoc 0 a))n 0 p nil d nil)
  25.     (cond((="LWPOLYLINE"et)
  26.     (repeat(length a)(setq b (nth n a) n (+ n 1))
  27.       (if (= 10 (car b))(progn
  28.         (setq q(list (cadr b) (caddr b))d1(vlax-curve-getDistAtPoint ob q))
  29.         (if p (if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))
  30.           (setq p (list q)))))))
  31.    ((="POLYLINE"et)
  32.     (SETQ EN (ENTGET (SETQ E (ENTNEXT E))))
  33.     (WHILE (/= (CDR (ASSOC 0 EN)) "SEQEND")
  34.       (SETQ q (CDR (ASSOC 10 EN))d1(vlax-curve-getDistAtPoint ob q)q(reverse(cdr(reverse q))))
  35.       (if p(if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))(setq p(list q)))
  36.       (SETQ EN (ENTGET (SETQ E (ENTNEXT E)))))
  37.     (setq p(reverse p))))P)
  38.   (defun midlstnm(n m lst / a lst1)
  39.     (setq a 0)
  40.     (vl-member-if'(lambda(x)(if(<= n(setq a(1+ a))m)(setq lst1 (cons x lst1)))(if(> a m)t))lst)
  41.     (reverse lst1))
  42.   (defun cdrnlst(n lst / a nlst)
  43.     (setq a 0)
  44.     (if(< n(length lst))(setq nlst(vl-member-if'(lambda(x)(setq a (1+ a))(< n a))lst)))
  45.     nlst)
  46.   (defun clockwise(pt / a i)
  47.     (setq a(list(eval(cons'min(mapcar'car pt)))(eval(cons'max(mapcar'cadr pt))))
  48.     a(cdar(vl-sort(mapcar'(lambda(x)(cons(distance x a)x))pt)(function(lambda(x y)(<(car x)(car y))))))
  49.     i(vl-position a pt)
  50.     pt(append(cdrnlst i pt)(midlstnm 0 i pt))))
  51. (defun modplver(e pt / e2);;将多线段顶点坐标改为PT所定义的点
  52.   (setq e(entget e)e2(member(assoc 90 e)e))
  53.   (foreach x e2(setq e(vl-remove x e)))
  54.   (setq e(append e(list(cons 90 (length pt))(assoc 70 e2)))
  55.   e(if(assoc 43 e2)(append e(list(assoc 43 e2))))
  56.   e(if(assoc 38 e2)(append e(list(assoc 38 e2))))
  57.   e(if(assoc 39 e2)(append e(list(assoc 39 e2))))
  58.   e2(member(assoc 10 e2)e2))
  59.   (foreach x(mapcar'(lambda(x)(list(car x)(cadr x)))pt)
  60.     (setq e(append e(list(cons 10 x)(cadr e2)(caddr e2)'(42 . 0)))e2(cddddr e2)))
  61.   (entmod e))
  62. (defun c:tt()
  63.   (setq e(car(entsel)))
  64.   (setq pt(plinexy e))
  65.   (setq pt(if(pldir pt)pt(reverse pt)));;如果pt不是顺时针方向将其反向
  66.   (modplver e(clockwise pt));;将pt(clockwise pt)的起点调整为西北角
  67. )


发表于 2022-2-6 10:53:50 | 显示全部楼层
大发程序啊!
发表于 2024-5-21 19:30:18 | 显示全部楼层
(setq bn (strcat (menucmd "M=$(edtime,$(getvar,date),YYYYMODDhhmmss)")))
您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-11-5 23:32 , Processed in 0.176764 second(s), 16 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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