(SF)文字指定位置分割 V1.2

;;说明:文字分割 V1.2！作者：fangmin723-2020.5.7
(defun c:SF(/ ado btxt ent fontsty ftxt hig inpty locx n obj obtxtwid ppt pt spt tsyitm txt txtlong wid)
    (defun obtxtwid(txt pt hig wid fontsty n / ptlst)
        (setq ptlst (textbox (list '(0 . "TEXT") (cons 1 (substr txt 1 n)) (cons 10 pt) (cons 40 hig) (cons 41 wid) (cons 7 fontsty))))
        (abs (- (caadr ptlst) (caar ptlst)))
    )
    (setq ppt (getpoint "\n请选择放置点："))
    (while (setq ent (entsel))
        (setq
            obj (Vlax-Ename->Vla-Object (Car ent))
            txt (Vla-Get-TextString obj)
            fontsty (Vla-Get-StyleName obj)
            pt (vlax-safearray->list (vlax-variant-value (Vla-Get-InsertionPoint obj)))
            ado (vla-get-ActiveDocument (vlax-get-acad-object))
            tsyitm (vla-Item (vla-get-TextStyles ado) fontsty)
            hig (vla-get-Height obj)
            wid (vla-get-Width tsyitm)
            spt (getpoint "\n请选择分割点：")
            n 1
            inpty (cadr (vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint obj))))
            txtlong (abs (car (apply (function (lambda(x y) (mapcar '- y x))) (textbox (list '(0 . "TEXT") (cons 1 txt) (cons 10 pt) (cons 40 hig) (cons 41 wid) (cons 7 fontsty))))))
        )
        (cond
            ((= (vla-get-ObjectName obj) "AcDbText")
                (cond
                    ((>= (vl-position (vla-get-Alignment obj) '(1 4 7 10 13)) 0)
                        (setq locx (- (car pt) (* txtlong 0.5)))
                    )
                    ((>= (vl-position (vla-get-Alignment obj) '(2 8 11 14)) 0)
                        (setq locx (- (car pt) txtlong))
                    )
                    (T (setq locx (car pt)))
                )
            )
            (T 
                (cond
                    ((>= (vl-position (vla-get-AttachmentPoint obj) '(2 5 8)) 0)
                        (setq locx (- (car pt) (* txtlong 0.5)))
                    )
                    ((>= (vl-position (vla-get-AttachmentPoint obj) '(3 6 9)) 0)
                        (setq locx (- (car pt) txtlong))
                    )
                    (T (setq locx (car pt)))
                )
            )
        )
        (while (< (+ locx (obtxtwid txt pt hig wid fontsty n)) (car spt)) (setq n (1+ n)))
        (if (> n 1)
            (progn
                (setq ftxt (substr txt 1 (- n 1)) btxt (substr txt n))
                (entmakex (list '(0 . "MTEXT") '(100 . "AcDbEntity") '(100 . "AcDbMText") (cons 10 (list (+ (car ppt) 1) inpty)) '(7 . "宋 宽0.7 高3") (cons 40 hig) '(71 . 4) '(41 . 28) (cons 1 ftxt)))
                (vla-put-TextString obj btxt)
            )
            (princ "\n此处没有分割文字的必要！！！")
        )
    )
    (princ)
)