[LISP程序]：抛砖引玉：能生成各种定位方式文本的程序，供编程爱好者测试使用。

urljit · 发表于 2004-9-24 21:13:16

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

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

×

自己测试自己的程序使用的，觉得有必要就贴上来了，欢迎指正。
[PHP]
(defun c:ttt (/ t72 t73 bt_pt bt_pt11 elist)
  (setq bt_pt (getpoint "\n指出插入点："))
  (setq t72 0)
  (repeat 3
(setq t73 0)
(repeat 4
   (setq elist (list (cons 0 "TEXT")
(CONS 8 "TEST")
(cons 1 "This is my test text")
(cons 7 "standard")
(cons 10 bt_pt)
(cons 11 bt_pt)
(cons 40 40)
(cons 50 0)
(cons 41 0.7)
(cons 71 0)
(cons 72 t72)
(cons 73 t73)
(cons 62 4)
   )
   )
   (entmake elist)
   (setq bt_pt (polar bt_pt (* pi 1.5) 120))
   (setq t73 (1+ t73))
)
(setq t72 (1+ t72))
  )
  (repeat 3
(setq bt_pt11 (polar bt_pt 0 600))
(setq elist (list (cons 0 "TEXT")
      (CONS 8 "TEST")
      (cons 1 "This is my test text")
      (cons 7 "standard")
      (cons 10 bt_pt)
      (cons 11 bt_pt11)
      (cons 40 40)
      (cons 50 0)
      (cons 41 1)
      (cons 71 0)
      (cons 72 t72)
      (cons 73 0)
      (cons 62 4)
)
)
(entmake elist)
(setq bt_pt (polar bt_pt (* pi 1.5) 120))
(setq t72 (1+ t72))
  )
  (princ)
)
;;;----------------------------------------------------------------------------
(PRINC "\n  TTT  V1.0已加载。以TTT启动命令。")
(princ)

[/PHP]

Free-Lancer · 发表于 2004-9-24 23:35:05

最初由 urljit 发布
[B]自己测试自己的程序使用的，觉得有必要就贴上来了，欢迎指正。
[PHP]
(defun c:ttt (/ t72 t73 bt_pt bt_pt11 elist)
  (setq bt_pt (getpoint "\n指出插入点："))
  (setq t72 0)
  (repeat 3
(setq t73 ... [/B]

很好的例子，不过我现在更喜欢用Vla方法

(defun c:ttt (/ pt txt )
(if (setq pt (getpoint "\nInsert Point: "))
(progn
(setq txt (vla-addtext
(vla-get-modelspace
(vla-get-activedocument (vlax-get-acad-object))
)
"This is my test text"
(vlax-3d-point pt)
40.
)
)
(mapcar
'(lambda (x / t1 insp)
(setq t1 (vla-copy txt))
(vla-move
t1
(vlax-3d-point pt)
(setq
insp (vlax-3d-point (setq pt (polar pt (* 0.5 pi) 50)))
)
)
(vla-put-alignment t1 (eval x))
(vla-put-textalignmentpoint t1 insp)
)
'(acAlignmentCenter
acAlignmentRight
acAlignmentAligned
acAlignmentMiddle
acAlignmentFit
acAlignmentTopLeft
acAlignmentTopCenter
acAlignmentTopRight
acAlignmentMiddleLeft
acAlignmentMiddleCenter
acAlignmentMiddleRight
acAlignmentBottomLeft
acAlignmentBottomCenter
acAlignmentBottomRight
)
)
)
)
(princ)
)

(defun c:ttt (/ pt txt ) 
  (if (setq pt (getpoint "\nInsert Point: ")) 
    (progn 
      (setq txt        (vla-addtext 
                  (vla-get-modelspace 
                    (vla-get-activedocument (vlax-get-acad-object)) 
                  ) 
                  "This is my test text" 
                  (vlax-3d-point pt) 
                  40. 
                ) 
      ) 
      (mapcar 
        '(lambda (x / t1 insp) 
           (setq t1 (vla-copy txt)) 
           (vla-move 
             t1 
             (vlax-3d-point pt) 
             (setq 
               insp (vlax-3d-point (setq pt (polar pt (* 0.5 pi) 50))) 
             ) 
           ) 
           (vla-put-alignment t1 (eval x)) 
           (vla-put-textalignmentpoint t1 insp) 
         ) 
        '(acAlignmentCenter 
           acAlignmentRight 
           acAlignmentAligned 
           acAlignmentMiddle 
           acAlignmentFit 
           acAlignmentTopLeft 
           acAlignmentTopCenter 
           acAlignmentTopRight 
           acAlignmentMiddleLeft 
           acAlignmentMiddleCenter 
           acAlignmentMiddleRight 
           acAlignmentBottomLeft 
           acAlignmentBottomCenter 
           acAlignmentBottomRight 
          ) 
      ) 
    ) 
  ) 
  (princ) 
)

urljit · 发表于 2004-9-25 12:35:13

果然引出“玉”来了，还是楼上的兄弟厉害，vlisp！能否指教一二？与我QQ联系好么？

Free-Lancer · 发表于 2004-9-25 13:16:32

最初由 urljit 发布
[B]果然引出“玉”来了，还是楼上的兄弟厉害，vlisp！能否指教一二？与我QQ联系好么？ [/B]

楼上兄弟，我们好像在一个城市。

urljit · 发表于 2004-9-25 16:14:56

Free-Lancer 你好：请与我联系好么？

shisj · 发表于 2004-9-27 10:04:03

谢谢楼上的高手提供源代码，我也学习一下

urljit · 发表于 2004-9-27 14:08:53

ｓｈｉｓｊ你过奖了，我也不是什么高手，互相学习，有机会可以联系联系。

chwen2000 · 发表于 2004-10-4 10:58:12

谢谢了

urljit · 发表于 2004-10-15 22:01:50

同在一个城市的Free-Lancer 兄弟：我正在学习vl，你的程序能否修改一下，让字符串尽量排列整齐些？

Free-Lancer · 发表于 2004-10-15 23:33:39

最初由 urljit 发布
[B]同在一个城市的Free-Lancer 兄弟：我正在学习vl，你的程序能否修改一下，让字符串尽量排列整齐些？ [/B]

你在写什么？字串对齐？这样

(defun c:ttt (/ pt txt)
(if (setq pt (getpoint "\nInsert Point: "))
(progn
(setq txt (vla-addtext
(vla-get-modelspace
(vla-get-activedocument (vlax-get-acad-object))
)
"This is my test text"
(vlax-3d-point pt)
40.
)
)
(mapcar
'(lambda (x / t1 inspt)
(setq t1 (vla-copy txt))
(vla-move
t1
(vlax-3d-point pt)
(vlax-3d-point
(setq pt (polar pt (* 0.5 pi) 70))
)
)
(vla-put-alignment t1 (eval x))
(vla-put-textalignmentpoint t1 (vlax-3d-point pt))
(setq inspt (vla-get-insertionpoint t1))
(if (or (vl-string-search "Center" (vl-princ-to-string x))
(equal (eval x) acAlignmentMiddle)
(vl-string-search "Right" (vl-princ-to-string x))
)
(vla-move t1 inspt (vlax-3d-point pt))
)
(if (or (equal (eval x) acAlignmentMiddleLeft)
(equal (eval x) acAlignmentTopLeft)
)
(vla-move t1 inspt (vlax-3d-point pt))
)
)
'(acAlignmentCenter
acAlignmentRight ; acAlignmentAligned
acAlignmentMiddle ; acAlignmentFit
acAlignmentTopLeft acAlignmentTopCenter
acAlignmentTopRight acAlignmentMiddleLeft
acAlignmentMiddleCenter acAlignmentMiddleRight
acAlignmentBottomLeft acAlignmentBottomCenter
acAlignmentBottomRight
)
)
)
)
(princ)
)

(defun c:ttt (/ pt txt) 
  (if (setq pt (getpoint "\nInsert Point: ")) 
    (progn 
      (setq txt        (vla-addtext 
                  (vla-get-modelspace 
                    (vla-get-activedocument (vlax-get-acad-object)) 
                  ) 
                  "This is my test text" 
                  (vlax-3d-point pt) 
                  40. 
                ) 
      ) 
      (mapcar 
        '(lambda (x / t1 inspt) 
           (setq t1 (vla-copy txt)) 
           (vla-move 
             t1 
             (vlax-3d-point pt) 
             (vlax-3d-point 
               (setq pt (polar pt (* 0.5 pi) 70)) 
             ) 
           ) 
           (vla-put-alignment t1 (eval x)) 
           (vla-put-textalignmentpoint t1 (vlax-3d-point pt)) 
           (setq inspt (vla-get-insertionpoint t1)) 
           (if (or (vl-string-search "Center" (vl-princ-to-string x)) 
                   (equal (eval x) acAlignmentMiddle) 
                   (vl-string-search "Right" (vl-princ-to-string x)) 
               ) 
             (vla-move t1 inspt (vlax-3d-point pt)) 
           ) 
           (if (or (equal (eval x) acAlignmentMiddleLeft) 
                   (equal (eval x) acAlignmentTopLeft) 
               ) 
             (vla-move t1 inspt (vlax-3d-point pt)) 
           ) 
         ) 
        '(acAlignmentCenter 
           acAlignmentRight                ; acAlignmentAligned 
           acAlignmentMiddle                ; acAlignmentFit 
           acAlignmentTopLeft                 acAlignmentTopCenter 
           acAlignmentTopRight                 acAlignmentMiddleLeft 
           acAlignmentMiddleCenter         acAlignmentMiddleRight 
           acAlignmentBottomLeft         acAlignmentBottomCenter 
 
           acAlignmentBottomRight 
          ) 
      ) 
    ) 
  ) 
  (princ) 
)

urljit · 发表于 2004-10-16 15:14:40

好弟兄，你的程序就是厉害，我已经试用过了，有时间联系。

梦断江南 · 发表于 2004-10-16 21:04:37

我觉得原来的就很好了.一眼就可以看出文字定位方式的特点.

urljit · 发表于 2004-10-17 21:07:42

正好给了我一个学习、请教的机会，在最新的代码中，为什么不能合并两个if呢？看起来他们是一样的呀。

经过学习，终于搞定，代码如下：[PHP]
(defun c:tttv (/ pt txt al_pt)
  (vl-load-com)
  (setq crtv (vla-get-modelspace
         (vla-get-activedocument (vlax-get-acad-object))
      )
  )
  (if (setq pt (getpoint "\nInsert Point: "))
(progn
   (setq txt (vla-addtext
   crtv
   "This is my test text"
   (vlax-3d-point pt)
   40.
)
   )
   (mapcar
'(lambda (x / t1 inspt)
   (setq t1 (vla-copy txt))
   (vla-move
      t1
      (vlax-3d-point pt)
      (vlax-3d-point
         (setq pt (polar pt (* 1.5 pi) 70))
      )
   )
   (vla-put-alignment t1 (eval x))
   (vla-put-textalignmentpoint t1 (vlax-3d-point pt))
   (setq inspt (vla-get-insertionpoint t1))
   (if (or (vl-string-search "Center" (vl-princ-to-string x))
   (vl-string-search "Right" (vl-princ-to-string x))
   (equal (eval x) acAlignmentMiddle)
   (equal (eval x) acAlignmentMiddleLeft)
   (equal (eval x) acAlignmentTopLeft)
         )
      (progn
         (vla-move t1 inspt (vlax-3d-point pt))
      )
   )
   ;;移动为整齐形式
   (if (or (equal (eval x) acAlignmentAligned)
   (equal (eval x) acAlignmentFit)
         )
      (progn
         (vla-rotate t1 (vlax-3d-point pt) (* 0.5 pi))
         (setq inspt (vla-get-insertionpoint t1))

         (vla-move t1 inspt (vlax-3d-point pt))
         (vla-put-TextAlignmentPoint t1 al_pt)
      )
   )
   ;;处理fit aligned形式
   (if (equal (eval x) acAlignmentRight)
      (progn
         (setq al_pt (vla-get-TextAlignmentPoint t1))
      )
   )
   ;;获得right形式的alignmentpoint
   (IF AL_PT
      (setq
         al_pt (vlax-3d-point
         (polar (vlax-safearray->list
(vlax-variant-value al_pt)
      )
      (* 1.5 pi)
      70
         )
      )
      )
   )
   )
'(acAlignmentCenter          acAlignmentRight
   acAlignmentAligned          acAlignmentMiddle
   acAlignmentFit          acAlignmentTopLeft
   acAlignmentTopCenter          acAlignmentTopRight
   acAlignmentMiddleLeft          acAlignmentMiddleCenter
   acAlignmentMiddleRight    acAlignmentBottomLeft
   acAlignmentBottomCenter    acAlignmentBottomRight
   )
   )
)
  )
  (setq al_pt nil)
  (princ)
)
[/PHP]

账号		自动登录	找回密码
密码			立即注册

[LISP程序]：抛砖引玉：能生成各种定位方式文本的程序，供编程爱好者测试使用。

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子

Re: [LISP程序]：抛砖引玉：能生成各种定位方式文本的程序，供编程爱好者测试使用。