普通文本完美转换到多重文本

kozmosovia · 发表于 2016-1-27 20:42

本帖最后由 kozmosovia 于 2016-1-30 13:05 编辑

普通文本有%%U、%%O和%%K的控制符，分别对应多重文本的\\O 、\\L和\\K控制符。
一般的文本转多重文本命令，包括ET的命令，均没有考虑这些控制符，在转换带有控制符的普通文本时，生成的多重文本内容面目全非。
本函数充分考虑了普通文本内的控制符并将其正确的转换到多重文本，实现完美的转换。

可使用普通文本内容 d%%Pfd%%O%%Kfhgs%%Ktdfd\%%Unsf%%Kns%%Odg%%Cg%%%%%O{}ad%%D%%Us%%O%%Kff
做个验证

;;; Name: _TEXT2MTEXT(2)
;;; Descryption: Convert a text into a mtext at very same position
;;; Argu(1): Text object
;;; Argu(2): Erase text object flag
;;; ------------------------------------------------------------------------------------------- ;;;
;;; RetValue(OK) MTEXT object ename
;;; RetValue(FAIL) NIL
(Defun _TEXT2MTEXT (obj flg / _STR2LIST LL MT P0 P1 PX0 PX1 REG STR UR)
(Defun _STR2LIST (str sep / POS RTN)
(setq rtn str)
(cond ((and (= (type str) (type sep) 'str)
(> (strlen sep) 0)
)
(if (setq pos (vl-string-search sep str))
(setq rtn (cons (substr str 1 pos)
(_STR2LIST
(substr str (+ (strlen sep) pos 1))
sep
)
)
)
(setq rtn (list str))
)
)
((= (type str) 'list)
(setq rtn (car str))
(foreach xxx (cdr str)
(setq rtn (strcat rtn sep xxx))
)
)
)
(if (= (type rtn) (type str) 'str)
(setq rtn (list rtn))
)
rtn
)
(setq obj (entget obj)
str (cdr (assoc 1 obj))
reg (vlax-create-object "Vbscript.RegExp")
px0 1e99
px1 0
)
(foreach abc '("%%U" "%%K" "%%O" "%%u" "%%k" "%%o")
(setq abc (_STR2LIST str abc)
px0 (fix (min px0 (strlen (car abc))))
)
(if (= (length abc) 2)
(setq px1 (fix (max px1 (strlen str))))
(setq px1 (fix (max px1 (- (strlen str) (strlen (last abc))))))
)
)
(if (< px0 px1)
(setq str (strcat
(substr str 1 px0)
(chr 1)
(substr str (1+ px0) (- px1 px0))
(chr 2)
(substr str (1+ px1))
)
)
)
(vlax-put-property reg "IgnoreCase" 0)
(vlax-put-property reg "Global" 1)
(foreach el (list (cons "%%%" (chr 3))
(cons "\\\" (chr 4))
(cons "{" (chr 5))
(cons "}" (chr 6))
(cons "%%(U|u)" "\\L")
(cons "%%(K|k)" "\\K")
(cons "%%(O|o)" "\\O")
(cons "\n" "\\P")
(cons (chr 1) "{")
(cons (chr 2) "}")
(cons (chr 3) "%")
(cons (chr 4) "\\\")
(cons (chr 5) "\\{")
(cons (chr 6) "\\}")
)
(vlax-put-property reg "Pattern" (car el))
(setq str (vlax-invoke-method reg "Replace" str (cdr el)))
)
(foreach abc '("\\k" "\\l" "\\o")
(setq px0 0
px1 ""
)
(foreach acc (_STR2LIST str (strcase abc))
(cond ((= px0 0)
(if (= px1 "")
(setq px1 acc)
(setq px1 (strcat px1 abc acc))
)
)
((= px0 1)
(setq px1 (strcat px1 (strcase abc) acc))
)
)
(setq px0 (abs (1- px0)))
)
(setq str px1)
)
(vlax-release-object reg)
(entmake (list (cons 0 "MTEXT")
(cons 8 (cdr (assoc 8 obj)))
(cons 100 "AcDbEntity")
(cons 100 "AcDbMText")
(cons 10 (cdr (assoc 10 obj)))
(cons 40 (cdr (assoc 40 obj)))
(cons 41 0)
(cons 71 1)
(cons 72 5)
(cons 1 str)
(cons 7 (cdr (assoc 7 obj)))
(list 11 1.0 0.0 0.0)
(cons 50 (cdr (assoc 50 obj)))
)
)
(setq obj (cdr (assoc -1 obj))
mt (entlast)
)
(vla-getboundingbox (vlax-ename->vla-object obj) 'll 'ur)
(setq ll (vlax-safearray->list ll)
ur (vlax-safearray->list ur)
p1 (vlax-3d-point (list (car ll) (cadr ur)))
)
(vla-getboundingbox (vlax-ename->vla-object mt) 'll 'ur)
(setq ll (vlax-safearray->list ll)
ur (vlax-safearray->list ur)
p0 (vlax-3d-point (list (car ll) (cadr ur)))
)
(vla-move (vlax-ename->vla-object mt) p0 p1)
(if flg
(entdel obj)
)
mt
)

;;; Name:                _TEXT2MTEXT(2) 
;;; Descryption:        Convert a text into a mtext at very same position 
;;; Argu(1):                Text object 
;;; Argu(2):                Erase text object flag 
;;; ------------------------------------------------------------------------------------------- ;;; 
;;; RetValue(OK)        MTEXT object ename 
;;; RetValue(FAIL)        NIL 
(Defun _TEXT2MTEXT (obj flg / _STR2LIST LL MT P0 P1 PX0 PX1 REG STR UR) 
  (Defun _STR2LIST (str sep / POS RTN) 
    (setq rtn str) 
    (cond ((and        (= (type str) (type sep) 'str) 
                (> (strlen sep) 0) 
           ) 
           (if (setq pos (vl-string-search sep str)) 
             (setq rtn (cons (substr str 1 pos) 
                             (_STR2LIST 
                               (substr str (+ (strlen sep) pos 1)) 
                               sep 
                             ) 
                       ) 
             ) 
             (setq rtn (list str)) 
           ) 
          ) 
          ((= (type str) 'list) 
           (setq rtn (car str)) 
           (foreach xxx        (cdr str) 
             (setq rtn (strcat rtn sep xxx)) 
           ) 
          ) 
    ) 
    (if        (= (type rtn) (type str) 'str) 
      (setq rtn (list rtn)) 
    ) 
    rtn 
  ) 
  (setq        obj (entget obj) 
        str (cdr (assoc 1 obj)) 
        reg (vlax-create-object "Vbscript.RegExp") 
        px0 1e99 
        px1 0 
  ) 
  (foreach abc '("%%U" "%%K" "%%O" "%%u" "%%k" "%%o") 
    (setq abc (_STR2LIST str abc) 
          px0 (fix (min px0 (strlen (car abc)))) 
    ) 
    (if        (= (length abc) 2) 
      (setq px1 (fix (max px1 (strlen str)))) 
      (setq px1 (fix (max px1 (- (strlen str) (strlen (last abc)))))) 
    ) 
  ) 
  (if (< px0 px1) 
    (setq str (strcat 
                (substr str 1 px0) 
                (chr 1) 
                (substr str (1+ px0) (- px1 px0)) 
                (chr 2) 
                (substr str (1+ px1)) 
              ) 
    ) 
  ) 
  (vlax-put-property reg "IgnoreCase" 0) 
  (vlax-put-property reg "Global" 1) 
  (foreach el (list (cons "%%%" (chr 3)) 
                    (cons "\\\" (chr 4)) 
                    (cons "{" (chr 5)) 
                    (cons "}" (chr 6)) 
                    (cons "%%(U|u)" "\\L") 
                    (cons "%%(K|k)" "\\K") 
                    (cons "%%(O|o)" "\\O") 
                    (cons "\n" "\\P") 
                    (cons (chr 1) "{") 
                    (cons (chr 2) "}") 
                    (cons (chr 3) "%") 
                    (cons (chr 4) "\\\") 
                    (cons (chr 5) "\\{") 
                    (cons (chr 6) "\\}") 
              ) 
    (vlax-put-property reg "Pattern" (car el)) 
    (setq str (vlax-invoke-method reg "Replace" str (cdr el))) 
  ) 
  (foreach abc '("\\k" "\\l" "\\o") 
    (setq px0 0 
          px1 "" 
    ) 
    (foreach acc (_STR2LIST str (strcase abc)) 
      (cond ((= px0 0) 
             (if (= px1 "") 
               (setq px1 acc) 
               (setq px1 (strcat px1 abc acc)) 
             ) 
            ) 
            ((= px0 1) 
             (setq px1 (strcat px1 (strcase abc) acc)) 
            ) 
      ) 
      (setq px0 (abs (1- px0))) 
    ) 
    (setq str px1) 
  ) 
  (vlax-release-object reg) 
  (entmake (list (cons 0 "MTEXT") 
                 (cons 8 (cdr (assoc 8 obj))) 
                 (cons 100 "AcDbEntity") 
                 (cons 100 "AcDbMText") 
                 (cons 10 (cdr (assoc 10 obj))) 
                 (cons 40 (cdr (assoc 40 obj))) 
                 (cons 41 0) 
                 (cons 71 1) 
                 (cons 72 5) 
                 (cons 1 str) 
                 (cons 7 (cdr (assoc 7 obj))) 
                 (list 11 1.0 0.0 0.0) 
                 (cons 50 (cdr (assoc 50 obj))) 
           ) 
  ) 
  (setq        obj (cdr (assoc -1 obj)) 
        mt  (entlast) 
  ) 
  (vla-getboundingbox (vlax-ename->vla-object obj) 'll 'ur) 
  (setq        ll (vlax-safearray->list ll) 
        ur (vlax-safearray->list ur) 
        p1 (vlax-3d-point (list (car ll) (cadr ur))) 
  ) 
  (vla-getboundingbox (vlax-ename->vla-object mt) 'll 'ur) 
  (setq        ll (vlax-safearray->list ll) 
        ur (vlax-safearray->list ur) 
        p0 (vlax-3d-point (list (car ll) (cadr ur))) 
  ) 
  (vla-move (vlax-ename->vla-object mt) p0 p1) 
  (if flg 
    (entdel obj) 
  ) 
  mt 
)

zzyong00 · 发表于 2016-1-27 21:09

赞一个

伪书虫86 · 发表于 2016-1-28 14:55

还好我普通文本没控制符

非诚勿扰续集 · 发表于 2016-1-30 08:10

普通文本变成多重文本，一般问题都可以解决，控制符不太好弄啊！

，不知道这个怎么做的

liuyj · 发表于 2016-1-30 12:24

代码没贴全啊，怎么验证？

kozmosovia · 发表于 2016-1-30 13:06

网站代码系统有问题，修改代码后，后面的代码被砍掉了。
已经补回来

fl202 · 发表于 2016-2-1 08:47

我读书少，是不是普通文本转多重文本的情况比较少？更多的情况是从多重文本转普通文本？

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

[源码] 普通文本完美转换到多重文本

评分

本帖被以下淘专辑推荐: