- 积分
- 15341
- 明经币
- 个
- 注册时间
- 2002-2-4
- 在线时间
- 小时
- 威望
-
- 金钱
- 个
- 贡献
-
- 激情
-
|
发表于 2003-6-27 12:46:00
|
显示全部楼层
;;; 这是很久前在xdcad中发表的,其中用到xdrx_api
;;; 功能:把字转为立体3D字
;;; 修改EXPRESSTOOL中的TXTEXP.LSP使用 By:龙龙仔
;;; 虽配合EXPRESSTOOL 及 XDRX_API15
;;; 注意:只能转TTF字型,非TTF字型转为"细明体"
;;; By Dominic Panholzer
;;;
;;; TXTEXP.LSP
;;; Copyright ?1999 by Autodesk, Inc.
;;;
;;; Your use of this software is governed by the terms and conditions of the
;;; License Agreement you accepted prior to installation of this software.
;;; Please note that pursuant to the License Agreement for this software,
;;; "[c]opying of this computer program or its documentation except as
;;; permitted by this License is copyright infringement under the laws of
;;; your country. If you copy this computer program without permission of
;;; Autodesk, you are violating the law."
;;;
;;; AUTODESK PROVIDES THIS PROGRAM "AS IS" AND WITH ALL FAULTS.
;;; AUTODESK SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY OF
;;; MERCHANTABILITY OR FITNESS FOR A PARTICULAR USE. AUTODESK, INC.
;;; DOES NOT WARRANT THAT THE OPERATION OF THE PROGRAM WILL BE
;;; UNINTERRUPTED OR ERROR FREE.
;;;
;;; Use, duplication, or disclosure by the U.S. Government is subject to
;;; restrictions set forth in FAR 52.227-19 (Commercial Computer
;;; Software - Restricted Rights) and DFAR 252.227-7013(c)(1)(ii)
;;; (Rights in Technical Data and Computer Software), as applicable.
;;;
;;; ----------------------------------------------------------------
;;;
;;; External Functions:
;;;
;;; ACET-ERROR-INIT --> ACETUTIL.FAS Intializes bonus error routine
;;; ACET-ERROR-RESTORE --> ACETUTIL.FAS Restores old error routine
;;; ACET-GEOM-ZOOM-FOR-SELECT --> ACETUTIL.FAS Zoom boundry to include points given
;;; ACET-LAYER-LOCKED --> ACETUTIL.FAS Checks to see if layer is locked
;;; ACET-GEOM-PIXEL-UNIT --> ACETUTIL.FAS Size of pixel in drawing units
;;; ACET-GEOM-TEXTBOX --> ACETUTIL.FAS Returns the textbox for any text
;;; ACET-GEOM-MIDPOINT --> ACETUTIL.FAS Returns midpoint between two points
;;; ACET-GEOM-VIEW-POINTS --> ACETUTIL.FAS Returns corner points of screen or viewport
;;; ACET-STR-FORMAT --> ACETUTIL.ARX String builder
;;; ACET-WMFIN --> ACETUTIL.FAS Brings in WMF file
;;;
(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
)
)
;;; --------------------- GROUP LIST FUNCTION ----------------------
;;; This function will return a list of all the group names in the
;;; drawing and their entity names in the form:
;;; ((<ename1> . <name1>) ... (<enamex> . <namex>))
;;; ----------------------------------------------------------------
(defun ACET-TXTEXP-GRPLST (/ GRP ITM NAM ENT GLST)
(setq GRP (dictsearch (namedobjdict) "ACAD_GROUP"))
(while (setq ITM (car GRP)) ; While edata item is available
(if (= (car ITM) 3) ; if the item is a group name
(setq NAM (cdr ITM) ; get the name
GRP (cdr GRP) ; shorten the edata
ITM (car GRP) ; get the next item
ENT (cdr ITM) ; which is the ename
GRP (cdr GRP) ; shorten the edata
GLST ; store the ename and name
(if GLST
(append GLST (list (cons ENT NAM)))
(list (cons ENT NAM))
)
)
(setq GRP (cdr GRP)) ; else shorten the edata
)
)
GLST ; return the list
)
;;; ------------------- GET GROUP NAME FUNCTION --------------------
;;; This function returns a list of all the group names in GLST
;;; where ENT is a member. The list has the same form as 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 ; step through the edata
(if (and
(= (car ITM) 340) ; if the item is a entity name
(eq (setq NAM (cdr ITM)) ENT)
; and the ename being looked for
)
(setq NLST ; store the ename and name
(if NLST
(append NLST (list (cons (car GRP) (cdr GRP))))
(list (cons (car GRP) (cdr GRP)))
)
)
)
)
)
)
)
NLST
)
;;; ----------------------------------------------------------------
;;; MAIN PROGRAM
;;; ----------------------------------------------------------------
(if (and ; Are we in plan view?
(equal (car (getvar "viewdir")) 0 0.00001)
(equal (cadr (getvar "viewdir")) 0 0.00001)
(> (caddr (getvar "viewdir")) 0)
)
(progn
(setq GLST (ACET-TXTEXP-GRPLST) ; Get all the groups in drawing
GDICT (if GLST
(dictsearch (namedobjdict) "ACAD_GROUP")
)
CNT 0
)
;; filter out the locked layers
(if SS
(setq SS (car (BNS_SS_MOD SS 1 t)))
) ;if
;; if we have anything left
(if SS
(progn
(setq CNT 0) ; Reset counter
(while (setq ENT (ssname SS CNT))
; step through each object in set
(and
GLST ; if groups are present in the drawing
(setq GNAM (ACET-TXTEXP-GETGNAME ENT GLST))
; and the text item is in one or more
(foreach GRP GNAM ; step through those groups
(command "_.-group"
"_r" ; and remove the text item
(cdr GRP)
ENT
""
)
)
)
(setq TBX (ACET-GEOM-TEXTBOX (entget ENT) 0))
;; get textbox points
(setq TBX (mapcar '(lambda (X)
(trans X 1 0)
;; convert the points to WCS
)
TBX
)
)
(setq PTLST (append PTLST TBX))
;; Build list of bounding box
;; points for text items selected
(setq CNT (1+ CNT)) ; get the next text item
) ; while
(setq PTLST (mapcar '(lambda (X)
(trans X 0 1) ; convert all the points
) ; to the current ucs
PTLST
)
)
(if (setq ZM (ACET-GEOM-ZOOM-FOR-SELECT PTLST))
;; If current view does not contain
(progn ; all bounding box points
(setq ZM
(list
(list (- (caar ZM) (ACET-GEOM-PIXEL-UNIT))
;; increase zoom area by
(- (cadar ZM) (ACET-GEOM-PIXEL-UNIT))
;; one pixel width to
(caddar ZM) ; sure nothing will be lost
)
(list (+ (caadr ZM) (ACET-GEOM-PIXEL-UNIT))
(+ (cadadr ZM) (ACET-GEOM-PIXEL-UNIT))
(caddr (cadr ZM))
)
)
)
(command "_.zoom" "_w" (car ZM) (cadr ZM))
;; zoom to include text objects
)
)
(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"))
;; if current layer is locked
(progn
(command "_.layer" "_unl" (getvar "clayer") "")
; unlock it
(setq LOCKED t)
)
)
(command "_.mirror" SS "" PT1
PT2 "_y" "_.WMFOUT" TMPFIL
SS ""
)
(if (findfile TMPFIL) ; Does WMF file exist?
(progn
(command "_.ERASE" SS "") ; erase the orignal text
(setq SS (ACET-WMFIN TMPFIL)) ; insert the WMF file
(command "_.mirror" SS "" PT1 PT2 "_y")
) ;progn
) ;if
(if LOCKED
(command "_.layer" "_lock" (getvar "clayer") "")
; relock if needed
) ;if
(if ZM
(command "_.zoom" "_p")
) ; Restore original view if needed
(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).")
) ;if equal
(ACET-ERROR-RESTORE) ; Retsore values
(princ)
)
;;end 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 SSS SSL SH LL LLL)
(defun SUM (SSS LL/)
(setq LLL (entnext LL))
(ssadd LLL SSS)
(ssadd (entlast) SSS)
(while (not (eq LLL (entlast)))
(ssadd LLL SSS)
(setq LLL (entnext 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")
(setq LL (entlast))
(setq S1 (ssget "p"))
(command "_.region" S1 "")
(SUM S1 LL)
(command "_.union" S1 "")
(setq S3 (ssget " "))
(setq S1 (ssget "p" '((0 . "REGION"))))
(command "_.select" S3 "")
(setq S2 (ssget "p" '((0 . "OLYLINE"))))
(setq N 0)
(setq LL (entlast))
(if S2
(progn
(repeat (sslength S2)
(command "_.explode" (ssname S2 N))
(xdrx_curve_intersectbreak (ssget "p"))
(setq N (1+ N))
)
(SUM S1 LL)
)
)
(setq LL (entlast))
(command "_.region" S1 "")
(if (not (equal (ssname S1 0) LL))
(progn
(SUM S1 LL)
(command "_.union" S1 "")
(command "_.select" S1 "")
(if (ssget "p" '((0 . "LINE")))
(command "_.erase" (ssget "p" '((0 . "LINE"))) "")
)
)
)
(command "_.extrude" S1 "")
(princ)
)
(prompt "\nType 3d_text")
(princ) |
|
发表于 2003-6-27 11:08:00
置顶卡
变色卡
显身卡
楼主