求贱人工具箱里【文字表格居中】程序源码

半听可乐 · 发表于 2012-7-13 11:33

贱人工具箱里【文字表格居中】程序源码，类似也行，使用方法就是框选单行文字，然后文字自动在所处的格子内居中

石井鱼 · 发表于 2012-7-13 11:33

我这边有一个，可以用。
(vl-load-com)
(defun c:WZJZh(/ err)
(defun algion (msg /    ss    lst    i    vlalst  boxlst  x
         cor1 cor2 findboxpt    newboxpt          en1
         en    enlst y    y2
      )
  (princ msg)
  (setq ss (ssget '((0 . "text"))))
  (setq lst nil)
  (setq i 0)
  (repeat (sslength ss)
(setq lst (cons (ssname ss i) lst))
(setq i (1+ i))
  )
  (setq vlalst (mapcar 'vlax-ename->vla-object lst))
  (setq boxlst (mapcar '(lambda (x / cor1 cor2)
   (vla-GetBoundingBox x 'cor1 'cor2)
   (list (vlax-safearray->list cor1)
(vlax-safearray->list cor2)
   )
)
         vlalst
         )
  )
  (setq
findboxpt (mapcar '(lambda (x)
   (polar (car x)
(angle (car x) (cadr x))
(/ (DISTANCE (car x) (cadr x)) 2.0)
   )
         )
      boxlst
      )
  )
  (setq newboxpt (mapcar '(lambda (x)
      (setq en1 (entlast))
      (vl-cmdf "_boundary" x "")
      (setq en (entlast))
      (if (not (equal en1 en))
      (progn
(setq enlst (entget en))
(setq lst (vl-remove-if-not
      '(lambda (y) (= (car y) 10))
      enlst
   )
)
(setq cor1 (vl-remove 10 (car lst))
      cor2 (vl-remove 10 (nth 2 lst))
)
(entdel en)
(polar cor1
         (angle cor1 cor2)
         (/ (DISTANCE cor1 cor2) 2.0)
)
      )
      )
   )
   findboxpt
   )
  )

  (mapcar '(lambda (x y y2)
      (vla-move x (vlax-3d-point y) (vlax-3d-point y2))
   )
   vlalst
   findboxpt
   newboxpt
  )

)
(setq err(VL-CATCH-ALL-APPLY 'algion (list "\n选择文字: ")))
  (princ)
  )

zyhandw · 发表于 2012-7-13 12:00

嗯，试了下，可以用！

hao3ren · 发表于 2012-7-13 12:40

(vl-load-com)
(defun c:JZ(/ err)
(defun algion (msg /    ss    lst    i    vlalst  boxlst  x
         cor1 cor2 findboxpt    newboxpt          en1
         en    enlst y    y2
      )
  (princ msg)
  (setq ss (ssget '((0 . "text"))))
  (setq lst nil)
  (setq i 0)
  (repeat (sslength ss)
(setq lst (cons (ssname ss i) lst))
(setq i (1+ i))
  )
  (setq vlalst (mapcar 'vlax-ename->vla-object lst))
  (setq boxlst (mapcar '(lambda (x / cor1 cor2)
   (vla-GetBoundingBox x 'cor1 'cor2)
   (list (vlax-safearray->list cor1)
(vlax-safearray->list cor2)
   )
)
         vlalst
         )
  )
  (setq
findboxpt (mapcar '(lambda (x)
   (polar (car x)
(angle (car x) (cadr x))
(/ (DISTANCE (car x) (cadr x)) 2.0)
   )
         )
      boxlst
      )
  )
  (setq newboxpt (mapcar '(lambda (x)
      (setq en1 (entlast))
      (vl-cmdf "_boundary" x "")
      (setq en (entlast))
      (if (not (equal en1 en))
      (progn
(setq enlst (entget en))
(setq lst (vl-remove-if-not
      '(lambda (y) (= (car y) 10))
      enlst
   )
)
(setq cor1 (vl-remove 10 (car lst))
      cor2 (vl-remove 10 (nth 2 lst))
)
(entdel en)
(polar cor1
         (angle cor1 cor2)
         (/ (DISTANCE cor1 cor2) 2.0)
)
      )
      )
   )
   findboxpt
   )
  )

  (mapcar '(lambda (x y y2)
      (vla-move x (vlax-3d-point y) (vlax-3d-point y2))
   )
   vlalst
   findboxpt
   newboxpt
  )

)
(setq err(VL-CATCH-ALL-APPLY 'algion (list "\n师兄选择单行文字: ")))
  (princ)
  )

hao3ren · 发表于 2012-7-13 12:42

;;表格文字居中
(princ "\n飞诗CAD-表格文字居中 1.0，支持Text,Mtext。")
(defun c:mid_table_text
   (/ *error* cen cmd h hobj la nss objs pt ss v vars w)
  (princ "\n选择要居中的文本:")
  (setq ss (ssget '((0 . "*text"))))
  (or ss (fsxm-silenceexit))
  (setq v '("cmdecho" "fillmode" "hpname" "hpassoc"))
  (setq vars (mapcar 'getvar v))
  (defun *error* (msg)
(foreach obj objs (vla-put-Visible obj 1))
(mapcar 'setvar v vars)
(vla-EndUndoMark *doc*)
(princ msg)
  )
  (vla-StartUndoMark *doc*)
  (mapcar 'setvar v '(0 0 "SOLID" 0))
  (setq nss (ssadd))
  (setq objs (mapcar 'vlax-ename->vla-object (fsxm-ss->enlist ss)))
  (foreach obj objs (vla-put-Visible obj 0))
  (if (getcname "-hatch")
(setq cmd ".-hatch")
(setq cmd ".-boundary")
  )
  (foreach obj objs
(if (= (vla-get-ObjectName obj) "AcDbMText")
   (progn
(setq w (vla-get-Width obj))
(vla-put-Width obj 0)
(setq pt (apply 'fsxm-midpt (fsxm-obj-box obj)))
(vla-put-Width obj w)
   )
   (setq pt (apply 'fsxm-midpt (fsxm-obj-box obj)))
)
(setq la (entlast))
(command cmd (trans pt 0 1) "")
(while (/= 0 (getvar "cmdactive")) (command))
(vla-put-Visible obj 1)
(setq h (entlast))
(if (/= h la) ;生成了剖面线
   (progn
(setq hobj (vlax-ename->vla-object h))
(setq cen (apply 'fsxm-midpt (fsxm-obj-box hobj)))
(mapcar 'entdel (fsxm-newenlist la))
(vlax-invoke obj 'move pt cen)
(ssadd (vlax-vla-object->ename obj) nss)
   )
)
  )
  (*error* (strcat "\n执行完成！共处理文字<"
   (itoa (sslength ss))
   ">个，成功<"
   (itoa (sslength nss))
   ">个..."
   )
  )
  ;;(sssetfirst nil nss)
  (princ)
)

半听可乐 · 发表于 2012-7-13 13:06

石井鱼发表于 2012-7-13 11:56
我这边有一个，可以用。
(vl-load-com)
(defun c:WZJZh(/ err)

运行结果有CAD提示：BOUNDARY 已创建 1 个多段线，怎么回事？而且感觉程序运行有点慢

xyp1964 · 发表于 2012-7-13 13:07

本帖最后由 xyp1964 于 2012-7-13 13:10 编辑

;; 文字表格居中伪源码需要e派工具箱(XCAD)的支持
(defun c:tt ()
(CMDLA0)
(setq ss (ssget '((0 . "TEXT")))
i -1
)
(while (setq s1 (ssname ss (setq i (1+ i))))
(xyp-Table-JustifyText s1 0 1)
)
(CMDLA1)
)

半听可乐 · 发表于 2012-7-13 13:09

hao3ren 发表于 2012-7-13 12:42
;;表格文字居中
(princ "\n飞诗CAD-表格文字居中 1.0，支持Text,Mtext。")
(defun c:mid_table_text

这个我用不了~~

半听可乐 · 发表于 2012-7-13 13:16

xyp1964 发表于 2012-7-13 13:07

用不了，给个全的吧

hf423 · 发表于 2012-7-13 13:35

xyp1964 发表于 2012-7-13 13:07

院长威武，但院长的函数库太大了，让人敬而远之。

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

求贱人工具箱里【文字表格居中】程序源码

最佳答案

本帖被以下淘专辑推荐:

相关帖子

点评

本帖子中包含更多资源

点评