请高手帮助修正单行文本操作的小代码

David_Webb

想要代码实现以下功能，我自己尝试写了一下，无法运行，请高手帮助修正代码，谢谢！

1、运行命令后，点选某单行文本
2、之后点选两个对角点
3、将单行文本复制（此功能在我写的代码中没有）
4、将复制的单行文本的对齐方式变为正中对齐，并将对齐点设为第2步中选择的两个点的中点

以下为我写的粗糙不能运行的代码，希望可以节省一点高手的时间

1. (defun c:ct ()
   
2.    (princ "\n select text")
   
3.    (setq ss (ssget ":S" '((0 . "TEXT"))))
   
4.    (setq pt1 (getpoint "\n选择对齐对角线的第一个点："))
   
5.    (setq pt2 (getpoint "\n选择对齐对角线的第二个点："))
   
6.    (setq pt3 (polar pt1 (angle pt1 pt2) (* 0.5 (distance pt1 pt2))))
   
7.    ;----------------------------------------------------------------------
   
8.    (setq old_align (assoc 72 ss))
   
9.    (setq new_align (cons 72 1))
   
10.    (setq ssdata (subst new_align old_align ss))
    
11.    (entmod ssdata)
    
12.    ;----------------------------------------------------------------------
    
13.    (setq old_align2 (assoc 73 ss))
    
14.    (setq new_align2 (cons 73 2))
    
15.    (setq ssdata (subst new_align2 old_align2 ss))
    
16.    (entmod ssdata)
    
17.    ;----------------------------------------------------------------------
    
18.    (setq old_pt (assoc 10 ss))
    
19.    (setq new_pt (cons 10 pt3))
    
20.    (setq ssdata (subst new_pt old_pt ss))
    
21.    (entmod ssdata)
    
22. )

(defun c:ct () <br />    (princ "\n select text") <br />    (setq ss (ssget ":S" '((0 . "TEXT")))) <br />    (setq pt1 (getpoint "\n选择对齐对角线的第一个点：")) <br />    (setq pt2 (getpoint "\n选择对齐对角线的第二个点：")) <br />    (setq pt3 (polar pt1 (angle pt1 pt2) (* 0.5 (distance pt1 pt2)))) <br />    ;---------------------------------------------------------------------- <br />    (setq old_align (assoc 72 ss)) <br />    (setq new_align (cons 72 1)) <br />    (setq ssdata (subst new_align old_align ss)) <br />    (entmod ssdata) <br />    ;---------------------------------------------------------------------- <br />    (setq old_align2 (assoc 73 ss)) <br />    (setq new_align2 (cons 73 2)) <br />    (setq ssdata (subst new_align2 old_align2 ss)) <br />    (entmod ssdata) <br />    ;---------------------------------------------------------------------- <br />    (setq old_pt (assoc 10 ss)) <br />    (setq new_pt (cons 10 pt3)) <br />    (setq ssdata (subst new_pt old_pt ss)) <br />    (entmod ssdata) <br /> )

yshf

;请试用以下程序
(defun c:ct ()
   (setq cmd (getvar "cmdecho"))
   (setq osm (getvar "osmode"))
   (setvar "cmdecho" 0)
   (setvar "osmode" 33)
   (command "_undo" "be")
   (if (/= (getvar "WORLDUCS") 1)
       (command "_ucs" "")
   )
   (if (progn  (princ "\n 请选取单行文字<回车退出>")
                  (setq ss (ssget ":S" '((0 . "TEXT"))))
          )
       (if (and (setq pt1 (getpoint "\n选择对齐对角线的第一个点："))
                (setq pt2 (getpoint pt1 "\n选择对齐对角线的第二个点："))
           )
           (progn
                ;(setq num1 (vla-get-count (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object)))))
                (setq pt3 (mapcar '(lambda(a b)(* 0.5 (+ a b))) pt1 pt2))
                (setq dxf (entget (ssname ss 0)))
                ;(setq ptt3 (trans pt3 1 0))
                (setq Newdxf (vl-remove-if '(lambda(x)(member (car x) '(-1 5 330))) dxf))
                (setq Newdxf (subst (cons 10 pt3) (assoc 10 Newdxf) Newdxf))
                (setq Newdxf (subst (cons 11 pt3) (assoc 11 Newdxf) Newdxf))
                (setq Newdxf (subst (cons 72 1) (assoc 72 Newdxf) Newdxf))
                (setq Newdxf (subst (cons 73 2) (assoc 73 Newdxf) Newdxf))
                (entmake Newdxf)
                (setq num2 (vla-get-count (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object)))))
                ;(princ (strcat "\n执行前总个数为" (itoa num1) ", 执行后总个数为" (itoa num2)))
            )
       )
   )
   (command "_undo" "e")
   (setvar "osmode" osm)
   (setvar "cmdecho" cmd)
   (princ)
)

David_Webb

yshf 发表于 2019-5-31 11:36
;请试用以下程序
(defun c:ct ()
   (setq cmd (getvar "cmdecho"))

感谢回复！
加载代码后，在命令行输入ct可以运行，有以下两个问题：
1、中文提示全部显示乱码，改成英文没有问题
2、提示选择单行文字后，点击某单行文字，之后就没反应了
请高手再次帮助！

yshf

已上传了程序附件，下载了再试试

David_Webb

yshf 发表于 2019-5-31 12:06
已上传了程序附件，下载了再试试

已下载附件运行，按提示点了第二个点后没反应了，请再看看~

yshf

1、程序运行完，在刚才选取的单行文字上再次单击左键选取它，然后将它移开，看看下面是否还有一个，就会明白是怎么回事了。
2、在选取对齐对角线的点时候，将那两个点远离单行文字地选取，看一看结果，也许就会明白是怎么回事了。
3、要不将程序改为如下，让它显示每次运行前后图中的图元总数。
(defun c:ct ()
   (setq cmd (getvar "cmdecho"))
   (setq osm (getvar "osmode"))
   (setvar "cmdecho" 0)
   (setvar "osmode" 33)
   (command "_undo" "be")
   (while (progn  (princ "\n 请选取单行文字<回车退出>")
                  (setq ss (ssget ":S" '((0 . "TEXT"))))
          )
       (if (and (setq pt1 (getpoint "\n选择对齐对角线的第一个点："))
                (setq pt2 (getpoint pt1 "\n选择对齐对角线的第二个点："))
           )
           (progn
                (setq num1 (vla-get-count (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object)))))
                (setq pt3 (mapcar '(lambda(a b)(* 0.5 (+ a b))) pt1 pt2))
                (setq dxf (entget (ssname ss 0)))
                (setq Newdxf (vl-remove-if '(lambda(x)(member (car x) '(-1 5 330))) dxf))
                (setq Newdxf (subst (cons 10 pt3) (assoc 10 Newdxf) Newdxf))
                (setq Newdxf (subst (cons 11 pt3) (assoc 11 Newdxf) Newdxf))
                (setq Newdxf (subst (cons 72 1) (assoc 72 Newdxf) Newdxf))
                (setq Newdxf (subst (cons 73 2) (assoc 73 Newdxf) Newdxf))
                (entmake Newdxf)
                (setq num2 (vla-get-count (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object)))))
                (princ (strcat "\n执行前总个数为" (itoa num1) ", 执行后总个数为" (itoa num2)))
            )
       )
   )
   (command "_undo" "e")
   (setvar "osmode" osm)
   (setvar "cmdecho" cmd)
   (princ)
)

David_Webb

yshf 发表于 2019-5-31 15:39
1、程序运行完，在刚才选取的单行文字上再次单击左键选取它，然后将它移开，看看下面是否还有一个，就会明 ...

看到了新复制的文本，在好远的地方，我想新复制的文本在选取的两点中间的，为什么跑那么远去了？

yshf

“跑那么远去了”就是选取对齐对角线的点时候，有一个点或两个点被捕捉到很远的端点或交点上，将“(setvar "osmode" 33)”改为“(setvar "osmode" 0) ”,再试试看。

David_Webb

yshf 发表于 2019-5-31 16:26
“跑那么远去了”就是选取对齐对角线的点时候，有一个点或两个点被捕捉到很远的端点或交点上，将“(setvar  ...

改了也没用，为了排除捕捉的干扰，我直接输入了两点坐标，没有用鼠标点，还是飞到好远的地方去了，奇怪。
是不是对齐点的问题呢

yshf

那上传你的测试图