[LISP程序]：把文字转为立体3D字

LUCAS · 发表于 2002-3-14 03:49:26

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

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

×

;;; 功能:把文字转为立体3D字
;;; 修改EXPRESSTOOL中的TXTEXP.LSP作子程序
;;; 虽安装EXPRESSTOOL 及配合XDRX_API
;;; 只能转TTF字型,非TTF字型转为"标楷体"
;;; 程序设计:赖云龙
;;; 注意:字型直线多的如"细明体系列"容易出错
;;; 我是用繁体字,简体字效果?????????未知!!!!!!!
;;;----------------------------------------------------------------
(defun TXTEXP (SS / GRPLST GETGNAME BLKNM GLST
GDICT VIEW UPLFT TMPFIL TBX TMPFIL CNT
PT1 PT2 ENT TXT TXTYP PTLST ZM
LOCKED GNAM
)
(ACET-ERROR-INIT
(list
(list "cmdecho" 0 "highlight" 1
"osmode" 0 "Mirrtext" 1 "limcheck"
0
)
t
)
)
(defun ACET-TXTEXP-GRPLST (/ GRP ITM NAM ENT GLST)
(setq GRP (dictsearch (namedobjdict) "ACAD_GROUP"))
(while (setq ITM (car GRP))
(if (= (car ITM) 3)
(setq NAM (cdr ITM)
GRP (cdr GRP)
ITM (car GRP)
ENT (cdr ITM)
GRP (cdr GRP)
GLST
(if GLST
(append GLST (list (cons ENT NAM)))
(list (cons ENT NAM))
)
)
(setq GRP (cdr GRP))
)
)
GLST
)
(defun ACET-TXTEXP-GETGNAME (ENT GLST / GRP GDATA NAM NLST)
(if (and GLST (listp GLST))
(progn
(foreach GRP GLST
(setq GDATA (entget (car GRP)))
(foreach ITM GDATA
(if (and
(= (car ITM) 340)
(eq (setq NAM (cdr ITM)) ENT)
)
(setq NLST
(if NLST
(append NLST (list (cons (car GRP) (cdr GRP))))
(list (cons (car GRP) (cdr GRP)))
)
)
)
)
)
)
)
NLST
)
(if (and
(equal (car (getvar "viewdir")) 0 0.00001)
(equal (cadr (getvar "viewdir")) 0 0.00001)
(> (caddr (getvar "viewdir")) 0)
)
(progn
(setq GLST (ACET-TXTEXP-GRPLST)
GDICT (if GLST
(dictsearch (namedobjdict) "ACAD_GROUP")
)
CNT 0
)
(if SS
(setq SS (car (BNS_SS_MOD SS 1 t)))
)
(if SS
(progn
(setq CNT 0)
(while (setq ENT (ssname SS CNT))
(and
GLST
(setq GNAM (ACET-TXTEXP-GETGNAME ENT GLST))
(foreach GRP GNAM
(command "_.-group"
"_r"
(cdr GRP)
ENT
""
)
)
)
(setq TBX (ACET-GEOM-TEXTBOX (entget ENT) 0))
(setq TBX (mapcar '(lambda (X)
(trans X 1 0)
)
TBX
)
)
(setq PTLST (append PTLST TBX))
(setq CNT (1+ CNT))
)
(setq PTLST (mapcar '(lambda (X)
(trans X 0 1)
)
PTLST
)
)
(if (setq ZM (ACET-GEOM-ZOOM-FOR-SELECT PTLST))
(progn
(setq ZM
(list
(list (- (caar ZM) (ACET-GEOM-PIXEL-UNIT))
(- (cadar ZM) (ACET-GEOM-PIXEL-UNIT))
(caddar ZM)
)
(list (+ (caadr ZM) (ACET-GEOM-PIXEL-UNIT))
(+ (cadadr ZM) (ACET-GEOM-PIXEL-UNIT))
(caddr (cadr ZM))
)
)
)
(command "_.zoom" "_w" (car ZM) (cadr ZM))
)
)
(setq VIEW (ACET-GEOM-VIEW-POINTS)
TMPFIL (strcat (getvar "tempprefix") "txtexp.wmf")
PT1 (ACET-GEOM-MIDPOINT (car VIEW) (cadr VIEW))
PT2 (list (car PT1) (cadadr VIEW))
)
(if (ACET-LAYER-LOCKED (getvar "clayer"))
(progn
(command "_.layer" "_unl" (getvar "clayer") "")
(setq LOCKED t)
)
)
(command "_.mirror" SS "" PT1
PT2 "_y" "_.WMFOUT" TMPFIL
SS ""
)
(if (findfile TMPFIL)
(progn
(command "_.ERASE" SS "")
(setq SS (ACET-WMFIN TMPFIL))
(command "_.mirror" SS "" PT1 PT2 "_y")
)
)
(if LOCKED
(command "_.layer" "_lock" (getvar "clayer") "")
)
(if ZM
(command "_.zoom" "_p")
)
(prompt (acet-str-format
"\n%1 text object(s) have been exploded to lines."
CNT
)
)
(prompt "\nThe line objects have been placed on layer 0.")
)
)
)
(prompt "\nView needs to be in plan (0 0 1).")
)
(ACET-ERROR-RESTORE)
(princ)
)
;;;以上为txtexp
(arxload "xdrx_api15" NIL)
(setq HOLDECHO (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(if (not ACET-ERROR-INIT)
(load "acetutil")
)
(if (not (tblsearch "style" "标楷体"))
(progn
(setq HOLDTEXTSTYLE (getvar "TEXTSTYLE"))
(command "style" "标楷体" "标楷体" "0" "1" "0" "n" "n")
(setvar "TEXTSTYLE" HOLDTEXTSTYLE)
(setq HOLDTEXTSTYLE NIL)
)
)
(setvar "CMDECHO" HOLDECHO)
(setq HOLDECHO NIL)
(defun C:3D_TEXT (/ N A S1 S2 S3 SS SSL SH LL LLL)
(setq SS (ssget '((-4 . "<AND")
(-4 . "<OR")
(0 . "MTEXT")
(0 . "TEXT")
(-4 . "OR>")
(-4 . "<NOT")
(102 . "{ACAD_REACTORS")
(-4 . "NOT>")
(-4 . "AND>")
)
)
)
(command "_.VIEW" "S" "3D_TEXT")
(command "_.VIEW" "TOP")
(setq SSL (sslength SS))
(setq N 0)
(repeat SSL
(setq A (entget (ssname SS N)))
(setq SH (cdr (assoc 3 (tblsearch "style" (cdr (assoc 7 A))))))
(if (/= "TTF" (strcase (substr SH (- (strlen SH) 2) 3)))
(progn
(setq A (subst (cons 7 "标楷体") (assoc 7 A) A))
(entmod A)
)
)
(setq N (1+ N))
)
(TXTEXP SS)
(command "_.VIEW" "R" "3D_TEXT")
(command "_.VIEW" "D" "3D_TEXT")
(c:xdrx_setmark)
(setq S2 (ssget "p"))
(command "_.region" S2 "")
(command "_.union" (c:xdrx_getss) "")
(setq S3 (ssget "P"))
(setq N 0)
(c:xdrx_setmark)
(command "_.select" S2 "")
(setq S2 (ssget "p" '((0 . "POLYLINE"))))
(if S2
(progn
(repeat (sslength S2)
(command "_.explode" (ssname S2 N))
(xdrx_curve_intersectbreak (ssget "p"))
(setq N (1+ N))
)
(setq S1 (c:xdrx_getss))
)
)
(c:xdrx_setmark)
(command "_.region" S1 "")
(setq S1 (c:xdrx_getss))
(if (ssget "p" '((0 . "LINE")))
(command "_.erase" (ssget "p" '((0 . "LINE"))) "")
)
(command "_.union" S1 S3 "")
(command "_.extrude" (ssget "p") "")
(princ)
)
(prompt "\nType 3d_text")
(princ)

;;;    功能:把文字转为立体3D字 
;;;    修改EXPRESSTOOL中的TXTEXP.LSP作子程序 
;;;    虽安装EXPRESSTOOL 及 配合XDRX_API 
;;;    只能转TTF字型,非TTF字型转为"标楷体" 
;;;    程序设计:赖云龙 
;;;    注意:字型直线多的如"细明体系列"容易出错 
;;;    我是用繁体字,简体字效果?????????未知!!!!!!! 
;;;---------------------------------------------------------------- 
(defun TXTEXP (SS      /       GRPLST  GETGNAME               BLKNM   GLST 
               GDICT   VIEW    UPLFT   TMPFIL  TBX     TMPFIL  CNT 
               PT1     PT2     ENT     TXT     TXTYP   PTLST   ZM 
               LOCKED  GNAM 
              ) 
  (ACET-ERROR-INIT 
    (list 
      (list "cmdecho"  0          "highlight"                1 
            "osmode"   0          "Mirrtext" 1                "limcheck" 
            0 
           ) 
      t 
    ) 
  ) 
  (defun ACET-TXTEXP-GRPLST (/ GRP ITM NAM ENT GLST) 
    (setq GRP (dictsearch (namedobjdict) "ACAD_GROUP")) 
    (while (setq ITM (car GRP)) 
      (if (= (car ITM) 3) 
        (setq NAM  (cdr ITM) 
              GRP  (cdr GRP) 
              ITM  (car GRP) 
              ENT  (cdr ITM) 
              GRP  (cdr GRP) 
              GLST 
                   (if GLST 
                     (append GLST (list (cons ENT NAM))) 
                     (list (cons ENT NAM)) 
                   ) 
        ) 
        (setq GRP (cdr GRP)) 
      ) 
    ) 
    GLST 
  ) 
  (defun ACET-TXTEXP-GETGNAME (ENT GLST / GRP GDATA NAM NLST) 
    (if        (and GLST (listp GLST)) 
      (progn 
        (foreach GRP GLST 
          (setq GDATA (entget (car GRP))) 
          (foreach ITM GDATA 
            (if        (and 
                  (= (car ITM) 340) 
                  (eq (setq NAM (cdr ITM)) ENT) 
                ) 
              (setq NLST 
                     (if NLST 
                       (append NLST (list (cons (car GRP) (cdr GRP)))) 
                       (list (cons (car GRP) (cdr GRP))) 
                     ) 
              ) 
            ) 
          ) 
        ) 
      ) 
    ) 
    NLST 
  ) 
  (if (and 
        (equal (car (getvar "viewdir")) 0 0.00001) 
        (equal (cadr (getvar "viewdir")) 0 0.00001) 
        (> (caddr (getvar "viewdir")) 0) 
      ) 
 
    (progn 
      (setq GLST  (ACET-TXTEXP-GRPLST) 
            GDICT (if GLST 
                    (dictsearch (namedobjdict) "ACAD_GROUP") 
                  ) 
            CNT          0 
      ) 
      (if SS 
        (setq SS (car (BNS_SS_MOD SS 1 t))) 
      ) 
      (if SS 
        (progn 
          (setq CNT 0) 
          (while (setq ENT (ssname SS CNT)) 
            (and 
              GLST 
              (setq GNAM (ACET-TXTEXP-GETGNAME ENT GLST)) 
              (foreach GRP GNAM 
                (command "_.-group" 
                         "_r" 
                         (cdr GRP) 
                         ENT 
                         "" 
                ) 
              ) 
            ) 
            (setq TBX (ACET-GEOM-TEXTBOX (entget ENT) 0)) 
            (setq TBX (mapcar '(lambda (X) 
                                 (trans X 1 0) 
                               ) 
                              TBX 
                      ) 
            ) 
            (setq PTLST (append PTLST TBX)) 
            (setq CNT (1+ CNT)) 
          ) 
          (setq        PTLST (mapcar '(lambda (X) 
                                 (trans X 0 1) 
                               ) 
                              PTLST 
                      ) 
          ) 
          (if (setq ZM (ACET-GEOM-ZOOM-FOR-SELECT PTLST)) 
            (progn 
              (setq ZM 
                     (list 
                       (list (- (caar ZM) (ACET-GEOM-PIXEL-UNIT)) 
                             (- (cadar ZM) (ACET-GEOM-PIXEL-UNIT)) 
                             (caddar ZM) 
                       ) 
                       (list (+ (caadr ZM) (ACET-GEOM-PIXEL-UNIT)) 
                             (+ (cadadr ZM) (ACET-GEOM-PIXEL-UNIT)) 
                             (caddr (cadr ZM)) 
                       ) 
                     ) 
              ) 
              (command "_.zoom" "_w" (car ZM) (cadr ZM)) 
 
            ) 
          ) 
          (setq        VIEW   (ACET-GEOM-VIEW-POINTS) 
                TMPFIL (strcat (getvar "tempprefix") "txtexp.wmf") 
                PT1    (ACET-GEOM-MIDPOINT (car VIEW) (cadr VIEW)) 
                PT2    (list (car PT1) (cadadr VIEW)) 
          ) 
          (if (ACET-LAYER-LOCKED (getvar "clayer")) 
            (progn 
              (command "_.layer" "_unl" (getvar "clayer") "") 
              (setq LOCKED t) 
            ) 
          ) 
          (command "_.mirror"             SS              ""       PT1 
                   PT2            "_y"     "_.WMFOUT"               TMPFIL 
                   SS            "" 
                  ) 
          (if (findfile TMPFIL) 
            (progn 
              (command "_.ERASE" SS "") 
              (setq SS (ACET-WMFIN TMPFIL)) 
              (command "_.mirror" SS "" PT1 PT2 "_y") 
            ) 
          ) 
          (if LOCKED 
            (command "_.layer" "_lock" (getvar "clayer") "") 
          ) 
          (if ZM 
            (command "_.zoom" "_p") 
          ) 
          (prompt (acet-str-format 
                    "\n%1 text object(s) have been exploded to lines." 
                    CNT 
                  ) 
          ) 
          (prompt "\nThe line objects have been placed on layer 0.") 
        ) 
      ) 
    ) 
    (prompt "\nView needs to be in plan (0 0 1).") 
  ) 
  (ACET-ERROR-RESTORE) 
  (princ) 
) 
 
;;;以上为txtexp 
 
(arxload "xdrx_api15" NIL) 
(setq HOLDECHO (getvar "CMDECHO")) 
(setvar "CMDECHO" 0) 
(if (not ACET-ERROR-INIT) 
  (load "acetutil") 
) 
(if (not (tblsearch "style" "标楷体")) 
  (progn 
    (setq HOLDTEXTSTYLE (getvar "TEXTSTYLE")) 
    (command "style" "标楷体" "标楷体" "0" "1" "0" "n" "n") 
    (setvar "TEXTSTYLE" HOLDTEXTSTYLE) 
    (setq HOLDTEXTSTYLE NIL) 
  ) 
) 
(setvar "CMDECHO" HOLDECHO) 
(setq HOLDECHO NIL) 
 
(defun C:3D_TEXT (/ N A S1 S2 S3 SS SSL SH LL LLL) 
  (setq        SS (ssget '((-4 . "<AND") 
                    (-4 . "<OR") 
                    (0 . "MTEXT") 
                    (0 . "TEXT") 
                    (-4 . "OR>") 
                    (-4 . "<NOT") 
                    (102 . "{ACAD_REACTORS") 
                    (-4 . "NOT>") 
                    (-4 . "AND>") 
                   ) 
           ) 
  ) 
  (command "_.VIEW" "S" "3D_TEXT") 
  (command "_.VIEW" "TOP") 
  (setq SSL (sslength SS)) 
  (setq N 0) 
  (repeat SSL 
    (setq A (entget (ssname SS N))) 
    (setq SH (cdr (assoc 3 (tblsearch "style" (cdr (assoc 7 A)))))) 
    (if        (/= "TTF" (strcase (substr SH (- (strlen SH) 2) 3))) 
      (progn 
        (setq A (subst (cons 7 "标楷体") (assoc 7 A) A)) 
        (entmod A) 
      ) 
    ) 
    (setq N (1+ N)) 
  ) 
  (TXTEXP SS) 
  (command "_.VIEW" "R" "3D_TEXT") 
  (command "_.VIEW" "D" "3D_TEXT") 
  (c:xdrx_setmark) 
  (setq S2 (ssget "p")) 
  (command "_.region" S2 "") 
  (command "_.union" (c:xdrx_getss) "") 
  (setq S3 (ssget "P")) 
  (setq N 0) 
  (c:xdrx_setmark) 
  (command "_.select" S2 "") 
  (setq S2 (ssget "p" '((0 . "POLYLINE")))) 
  (if S2 
    (progn 
      (repeat (sslength S2) 
        (command "_.explode" (ssname S2 N)) 
        (xdrx_curve_intersectbreak (ssget "p")) 
        (setq N (1+ N)) 
      ) 
      (setq S1 (c:xdrx_getss)) 
    ) 
  ) 
  (c:xdrx_setmark) 
  (command "_.region" S1 "") 
  (setq S1 (c:xdrx_getss)) 
  (if (ssget "p" '((0 . "LINE"))) 
    (command "_.erase" (ssget "p" '((0 . "LINE"))) "") 
  ) 
  (command "_.union" S1 S3 "") 
  (command "_.extrude" (ssget "p") "") 
  (princ) 
) 
(prompt "\nType 3d_text") 
(princ)

LUCAS · 发表于 2002-3-14 03:59:36

为何回复时才看到下半截程序

cy956 · 发表于 2002-3-14 10:47:52

没贴完，好像版面出错了。
最好用文件附件。

梦断江南 · 发表于 2003-5-4 18:52:39

把未贴完的也贴上来吧

LUCAS · 发表于 2003-5-5 14:29:10

档案太大不能贴完整,但第2贴不是有上传档案了吗?

SunLion · 发表于 2007-8-3 14:29:36

到底LISP完整吗？

jx2008 · 发表于 2008-11-9 14:06:38

贴上来的代码不完整，下在附件是繁体版本的

zcenc · 发表于 2009-9-4 11:01:11

转成3Ｄ的有什么用？

renande · 发表于 2009-10-7 15:54:43

贴上来的代码不完整,不过做三维立体字也不难哈

zhangzl · 发表于 2010-1-11 12:58:19

不知道效果怎么样？

jetm33 · 发表于 2010-1-24 14:49:07

3D是何样呢

杜流浪人 · 发表于 2014-7-5 18:27:51

好代码先看看

杜流浪人 · 发表于 2014-7-5 18:28:33

错误: LOAD 失败: "acetutil"

jenyooo · 发表于 2015-2-1 11:34:11

回复看下，谢谢楼主分享

jenyooo · 发表于 2017-10-13 09:26:08

；谢谢楼主好像不全

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

[LISP程序]：把文字转为立体3D字

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

相关帖子