[求助]：文字与直线平行程序？？？

bububa918 · 发表于 2005-9-18 22:08:12

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

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

×

我记得论坛上以前有个文字与直线平行程序，
现在突然想用一下，找不到，有谁知道？？？

XWT670530 · 发表于 2005-9-18 23:19:10

真有这个程序吗?我非常想,希望有人能发上来!!!

littlecong · 发表于 2005-9-19 12:01:55

我在标注面积的时候，文字就是和线平行的
http://www.xdcad.net/forum/showt ... 2236183#post2236183

leochen · 发表于 2005-9-19 13:03:03

我自己编的lsp，请试用：

(defun c:wr (/ txt lin ls le ang txt1)
 (setq txt (car (entsel "\n选择文字:")))
 (while (or (= txt nil) (/= "TEXT" (cdr (assoc 0 (entget txt)))))
(setq txt (car (entsel "\n选择文字:")))
 )
 (setq lin (car (entsel "\n选择基准直线：")))
 (while (or (= lin nil) (/= "LINE" (cdr (assoc 0 (entget lin)))))
(setq lin (car (entsel "\n选择基准直线：")))
 )
 (setq ls (cdr (assoc 10 (entget lin)))
le (cdr (assoc 11 (entget lin)))
ang (angle ls le)
 )
 (if (and (> ang (* pi 0.5)) (<= ang (* pi 1.5)))
(setq ang (- ang pi))
 )
 (setq
txt1 (subst (cons 50 ang) (assoc 50 (entget txt)) (entget txt))
 )
 (entdel txt)
 (d-text txt1)
 (princ)
)

;;;动态写文字，txt－－文字元素表
(defun d-text (txt / tmp a)
 (setq tmp t)
 (entmake txt)
 (princ "\n选择点：")
 (while tmp
(setq a (grread t 4 0))
(cond
 ((= (car a) 3)
 (entdel (entlast))
 (setq txt (subst (cons 10 (cadr a)) (assoc 10 txt) txt)
 tmp nil
 )
 (entmake txt)
 (redraw)
 )
 ((= (car a) 5)
 (entdel (entlast))
 (setq txt (subst (cons 10 (cadr a)) (assoc 10 txt) txt))
 (entmake txt)
 (redraw (entlast) 3)
 )
 ((or (= (car a) 12) (= (car a) 25))
 (entdel (entlast))
 (setq txt (subst (cons 10 (cadr a)) (assoc 10 txt) txt))
 (entmake txt)
 )
)
 )
 (princ)
)

yshf · 发表于 2005-9-19 16:33:09

用“(entdel txt)”再“(entmake txt)”似乎有点闪烁，也可以改为如下：

(defun c:wr (/ txt lin ls le ang txt1)
 (while (progn
 (setq txt (car (entsel "\n选择文字:")))
 (or (= txt nil) (/= "TEXT" (cdr (assoc 0 (entget txt)))))
 )
 )
 (while (progn
 (setq lin (car (entsel "\n选择基准直线：")))
 (or (= lin nil) (/= "LINE" (cdr (assoc 0 (entget lin)))))
 )
 )
 (setq ang (angle (cdr (assoc 10 (entget lin))) (cdr (assoc 11 (entget lin)))))
 (if (and (> ang (* pi 0.5)) (<= ang (* pi 1.5))) (setq ang (- ang pi)))
 (setq txt1 (subst (cons 50 ang) (assoc 50 (entget txt)) (entget txt)))
 (entmod txt1)(redraw txt 3)
 (d-text txt1)
 (princ)
)

;;;动态写文字，txt－－文字元素表
(defun d-text (txt / tmp a)
 (setq tmp t)
 (princ "\n选择点：")
 (while tmp
(setq a (grread t 4 0))
(cond ((= (car a) 3)
 (setq txt (subst (cons 10 (cadr a)) (assoc 10 txt) txt)
 tmp nil
 )
 (entmod txt)(redraw (entlast) 4)
 )
 ((= (car a) 5)
 (setq txt (subst (cons 10 (cadr a)) (assoc 10 txt) txt))
 (entmod txt)(redraw (entlast) 3)
 )
 ((or (= (car a) 12) (= (car a) 25))
 (setq txt (subst (cons 10 (cadr a)) (assoc 10 txt) txt))
 (entmod txt)(redraw (entlast) 4)
 )
 )
)
(princ)
)

xshrimp · 发表于 2005-9-19 16:54:59

以上两个选择的线只能为line线,当选择pline时就每用了。
[php];;旋转文字,使之平行直线,支持line,pline线。
(defun RTD (r)
 (* 180.0 (/ r pi))
)
(defun dxf (code elist)
 (cdr (assoc code elist))
)
;;;---------强制选择line和pline两种线。---------------------------------
;调用函数方法 ;(princ "\n请选择作为源块的图块:")
 ;;;(setq ss (ss_ll))
 (defun SS_ll (/ m )
 (setq m 1)
 (while m
 (setq ss1 (entsel))
 (cond
 ((not ss1)
 (prompt "\n错误:你什么都没有选择!")
 )
 ;加此段可强制选择sssname的物体.选择别的物体没用.
 ( (and
 (/= "LINE" (cdr (assoc 0 (entget (car ss1)))))
 (/= "LWPOLYLINE" (cdr (assoc 0 (entget (car ss1)))))
 )

 (prompt "\n错误:你选择的不是直线")
 )
 (t (prompt "\n...OK_...") (setq m nil))
 );cond
 );while m
 ss1
);end defun

(defun c:wr (/ m txt txtang txtbastpoint rotang b1 b2 ang0 )
 (prompt "\n *旋转文字,使之平行直线* ")
 (command "undo" "be")
 (setq m 1)
 (while m
(setq txt (entsel "\n选择要旋转的文字< "))
 (cond
 ((not txt)
 (prompt "\n**错误:你什么都没有选择!**")
 )
 ((/= "TEXT" (cdr (assoc 0 (entget (car txt)))))
 (prompt "\n**错误: 你选择的不是文字!**")
 )
 (t (prompt "\n......OK_......") (setq m nil))
);cond
 );while m

 (setq txt_list (entget (car txt)))
 (setq txtang_old_lit (assoc 50 txt_list))
 (setq txtang_old (cdr txtang_old_lit))
 (setq txtbasepoint (cdr (assoc 10 (setq e (entget (car txt))))))
 (setq line_ss (ss_ll))

 (setq ss1 (entget (car line_ss)))
 (setq ss2 (dxf 0 ss1))
 (setq pt (cadr line_ss))
 (setq pt (osnap pt "NEA"))
 (cond
((= ss2 "LINE")
 (setq pt1 (dxf 10 ss1) pt2 (dxf 11 ss1))
 (setq ang0 (angle pt1 pt2))
 (if (and (> ang0 (* PI 0.5)) (<= ang0 (* PI 1.5)))
 (setq ang0 (+ ang0 PI))
 );end if
 );cond1
 ((= ss2 "LWPOLYLINE")
 (setq ss1 (member (assoc 10 ss1) ss1))
 (setq pt1 (dxf 10 ss1))
 (setq r 1)
(while r
 (setq ss1 (cdr ss1)
 ss1 (member (assoc 10 ss1) ss1)
 pt2 (dxf 10 ss1)
 )
 (setq dt1 (distance pt1 pt)
 dt2 (distance pt pt2)
 dt1 (+ dt1 dt2)
 dt1 (rtos dt1 2 1)
 dt1 (distof dt1 2)
 dt2 (distance pt1 pt2)
 dt2 (rtos dt2 2 1)
 dt2 (distof dt2 2)
 )
 (if (= dt1 dt2)
 (setq r nil)
 (setq pt1 pt2)
 )
 );end while
 (setq ang0 (angle pt1 pt2))
 (if (and (> ang0 (* PI 0.5)) (<= ang0 (* PI 1.5)))
 (setq ang0 (+ ang0 PI))
 );end if
 );cond2
 (T (alert "\n所选图元不能进行标注!重新选取.") );T
);cond
 (setq txtang_new_list (cons 50 ang0))

 (command "rotate" txt "" txtbasepoint (rtd (- ang0 txtang_old)))
 (setvar "OSMODE" 4095)
 (prin1)
)[/php]

yshf · 发表于 2005-9-19 17:27:44

xshrimp，你怎么忘记了提供“ss_ll”。照你的说法：当选择了“XLINE”、“RAY”、“POLYLINE”、带弧段的“LWPOLYLINE”时，你的程序同样是“每”用呀！

xshrimp · 发表于 2005-9-19 21:28:42

忘记了,补上,上帖已经修改.

xyp1964 · 发表于 2005-9-20 07:43:43

功能：文本与线或图块的角度相匹配
支持：LINE、POLYLINE、LWPOLYLINE、XLINE、RAY、INSERT
[/COLOR]

[FONT=courier new](load "xyp_lib")
;|加载通用函数(可在签名栏直接下载)
如果已经下载xyp_lib并放到搜索路径下可以不再下载!
利用以下任何一种方式即可加载和运行通用函数内的所有子程序：
1.在acad.lsp中增加(load"xyp_lib")
2.在每个程序内增加(load"xyp_lib")
3.在command下，输入(load"xyp_lib")
4.在菜单.mnl中增加(load"xyp_lib")
5.将xyp_lib.vlx文件直接拽到cad屏幕
[COLOR=red]★通用函数下载地址：[/COLOR]
[url]http://www.xdcad.net/forum/attachme...&postid=1606661[/url]
[url]http://www.mjtd.com/bbs/dispbbs.asp...ID=37554&page=1[/url]|;
;;;文本与线或图块的角度相匹配
(defun c:test ()
(CMDLA0)
(setq s1 (entsel "\n选线或图块 : ")
ob (dxf 0 (entget (car s1)))
)
(cond ((= ob "INSERT") (setq ang (dxf 50 (entget (car s1)))))
((or (= ob "LINE")
(= ob "POLYLINE")
(= ob "LWPOLYLINE")
(= ob "XLINE")
(= ob "RAY")
)
(curve-pts-pte s1)
(setq ang (angle pts pte))
)
(t (princ))
)
(if ang
(progn
(while (> ang (/ pi 2.0))
(setq ang (- ang pi))
)
(princ "\n选择文本 : ")
(setq ss (ssget '((0 . "*TEXT")))
i -1
)
(while (setq s1 (ssname ss (setq i (1+ i))))
(sub_upd s1 50 ang)
)
)
)
(CMDLA1)
)[/FONT]

[FONT=courier new](load "xyp_lib") 
 ;|加载通用函数(可在签名栏直接下载) 
如果已经下载xyp_lib并放到搜索路径下可以不再下载! 
利用以下任何一种方式即可加载和运行通用函数内的所有子程序： 
1.在acad.lsp中增加(load"xyp_lib") 
2.在每个程序内增加(load"xyp_lib") 
3.在command下，输入(load"xyp_lib") 
4.在菜单.mnl中增加(load"xyp_lib") 
5.将xyp_lib.vlx文件直接拽到cad屏幕 
[COLOR=red]★通用函数下载地址：[/COLOR] 
[url]http://www.xdcad.net/forum/attachme...&postid=1606661[/url] 
[url]http://www.mjtd.com/bbs/dispbbs.asp...ID=37554&page=1[/url]|; 
 
;;;文本与线或图块的角度相匹配 
(defun c:test () 
  (CMDLA0) 
  (setq        s1 (entsel "\n选线或图块 : ") 
        ob (dxf 0 (entget (car s1))) 
  ) 
  (cond        ((= ob "INSERT") (setq ang (dxf 50 (entget (car s1))))) 
        ((or (= ob "LINE") 
             (= ob "POLYLINE") 
             (= ob "LWPOLYLINE") 
             (= ob "XLINE") 
             (= ob "RAY") 
         ) 
         (curve-pts-pte s1) 
         (setq ang (angle pts pte)) 
        ) 
        (t (princ)) 
  ) 
  (if ang 
    (progn 
      (while (> ang (/ pi 2.0)) 
        (setq ang (- ang pi)) 
      ) 
      (princ "\n选择文本 : ") 
      (setq ss (ssget '((0 . "*TEXT"))) 
            i  -1 
      ) 
      (while (setq s1 (ssname ss (setq i (1+ i)))) 
        (sub_upd s1 50 ang) 
      ) 
    ) 
  ) 
  (CMDLA1) 
)[/FONT]

wbjdpp （文本角度匹配）：

bububa918 · 发表于 2005-9-20 18:24:02

6楼的，好像程序有问题？
输入中含有多余的闭括号？？

xshrimp · 发表于 2005-9-20 22:40:46

已修改,多了一个";" ,经测试可用.

841594 · 发表于 2005-9-21 16:35:32

xyp1964：好程序，文字如能绕中心点旋转更好。
俺也贴一个，支持所有的线状物体、图块等，直线与之平行，弧线则对其圆心。文字中心点位置不变。

;;;文字向物体对其--by 841594
;;; 2005.9.21
(defun c:tale (/ A B EN ENS ORT PT0 PT1 PT2 PT3)
;;; 求文字的中心点,返回wcs坐标
(defun txtmpt (en / ent box ls pt ang)
(setq ent (entget en)
ang (cdr (assoc 50 ent))
box (textbox ent)
ls (mapcar '(lambda (a b) (* 0.5 (+ a b)))
(car box)
(cadr box)
)
pt (cdr (assoc 10 ent))
)
(polar pt (+ ang (angle '(0 0) ls)) (distance '(0 0) ls))
) ; defun
;;; main
(command "undo" "begin")
(setq ens (entsel "\n请选择参照物体: ")
pt0 (cadr ens)
)
(cond ((setq pt1 (osnap pt0 "cen")))
((setq pt2 (osnap pt0 "nea")))
(1 (setq pt0 nil))
)
(while (and pt0
(setq en (car (entsel "\n请选择要对齐的文字: ")))
(= "TEXT" (cdr (assoc 0 (entget en))))
)
(setq ptm (txtmpt en))
(if (not pt2)
(setq pt3 pt1
pt0 ptm
)
(setq pt3 pt2)
)
(setq ort (cdr (assoc 50 (entget en))))
(command "rotate" en "" "non" ptm)
(if (> (cadr pt3) (cadr pt0))
(command (* 180 (/ (- (angle pt0 pt3) ort (* 0.5 pi)) pi)))
(command (* 180 (/ (- (angle pt3 pt0) ort (* 0.5 pi)) pi)))
)
)
(command "undo" "end")
(princ)
)

;;;文字向物体对其--by 841594 
;;;        2005.9.21 
(defun c:tale (/ A B EN ENS ORT PT0 PT1 PT2 PT3) 
;;;   求文字的中心点,返回wcs坐标 
  (defun txtmpt        (en / ent box ls pt ang) 
    (setq ent (entget en) 
          ang (cdr (assoc 50 ent)) 
          box (textbox ent) 
          ls  (mapcar '(lambda (a b) (* 0.5 (+ a b))) 
                      (car box) 
                      (cadr box) 
              ) 
          pt  (cdr (assoc 10 ent)) 
    ) 
    (polar pt (+ ang (angle '(0 0) ls)) (distance '(0 0) ls)) 
  )                                        ; defun 
;;;  main 
  (command "undo" "begin") 
  (setq        ens (entsel "\n请选择参照物体: ") 
        pt0 (cadr ens) 
  ) 
  (cond        ((setq pt1 (osnap pt0 "cen"))) 
        ((setq pt2 (osnap pt0 "nea"))) 
        (1 (setq pt0 nil)) 
  ) 
  (while (and pt0 
              (setq en (car (entsel "\n请选择要对齐的文字: "))) 
              (= "TEXT" (cdr (assoc 0 (entget en)))) 
         ) 
    (setq ptm (txtmpt en)) 
    (if        (not pt2) 
      (setq pt3        pt1 
            pt0        ptm 
      ) 
      (setq pt3 pt2) 
    ) 
    (setq ort (cdr (assoc 50 (entget en)))) 
    (command "rotate" en "" "non" ptm) 
    (if        (> (cadr pt3) (cadr pt0)) 
      (command (* 180 (/ (- (angle pt0 pt3) ort (* 0.5 pi)) pi))) 
      (command (* 180 (/ (- (angle pt3 pt0) ort (* 0.5 pi)) pi))) 
    ) 
  ) 
  (command "undo" "end") 
  (princ) 
)

liuyj · 发表于 2005-9-22 12:32:53

还可以再扩展，对Mtext、Atrtibute、Attdef等进行操作。

bububa918 · 发表于 2005-9-24 08:44:09

xyp1964,你的程序图块平行似乎不能用？

xyp1964 · 发表于 2005-9-24 09:34:51

最初由 bububa918 发布
[B]xyp1964,你的程序图块平行似乎不能用？ [/B]

试试签名栏下的“角度匹配”程序：
http://www.xdcad.net/forum/showthread.php?s=&threadid=463127

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

[求助] [求助]：文字与直线平行程序？？？

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

相关帖子