标注.文字.的遮罩
;;;是这里看到的 ,我英文很差。大家去这里http://www.theswamp.org 玩吧<img src="http://bbs.mjtd.com/static/image/smiley/qq/em01.gif" smilieid="271" alt="" border="0">。;;;---------------------------
;;;文字遮罩
(defun c:TBG () (textDimbackgroundfill) (princ))
(defun textDimbackgroundfill (/ ent)
;; codehimbelonga kdub@theSwamp 2008
(while (setq ENT (KDUB:OBJSEL "Select Dimension or Text to set BackgroundFill to Masked"
(list "DIMENSION" "MTEXT" "TEXT")
nil
)
)
(if (= "DIMENSION" (cdr (assoc 0 (entget (car ent)))))
(vla-put-textfill (vlax-ename->vla-object (car ent)) :vlax-true)
;; else
(vla-put-backgroundfill (vlax-ename->vla-object (car ent))
:vlax-true
)
)
)
(princ)
)
;;;---------------------------
;;;------------------------------------------------------------------
(defun kdub:objsel (promptmsg ;
typelist ; List of entity types allowed to be selected
nentselflag ; If true nentsel permitted , otherwise use entsel.
/ pickok returnvalue
tmp
)
;; codehimbelonga kdub@theSwamp 2008
(setq promptmsg (strcat "\n"
(cond (promptmsg)
("Select object")
)
" : "
)
)
(while (not pickok)
(setvar "ERRNO" 0)
(setq returnvalue (if nentselflag
(nentsel promptmsg)
(entsel promptmsg)
)
)
(cond
((= (getvar "ERRNO") 52) ; enter
;; skip out
(setq pickok t)
)
((= (getvar "ERRNO") 7)
(princ "Nothing found at selectedpoint. ")
)
((and
(setq tmp (entget (car returnvalue))) ; object type
typelist
(not (member (cdr (assoc 0 tmp)) (mapcar 'strcase typelist)))
) ; wrong type
(alert
(strcat "Selected object is not"
"\na "
(apply 'strcat
(cons (car typelist)
(mapcar '(lambda (x) (strcat "\nor " x))
(cdr typelist)
)
)
)
". "
)
)
)
;; skip out
((setq pickok t))
)
)
returnvalue
)
;;;------------------------------------------------------------------ Select Dimension or Text to set BackgroundFill to Masked : ActiveX 服务器返回错误:
未知名称: BackgroundFill ;;; ;BA.lsp-BACKGROUND FILL ALL-
;;; ;Made for M3 Mexicana. Coding Selected by Paulo Gil Soto. December 2009
;;; ;This routine will set a background color fill to all selected text,
;;; ;mtext and dimensions, text objects will be converted to mtext with width=0
;;; ;and then will add their text box control points
;;; ;It will bring objects in layer 'Dims' to front at the end, as well as other
;;; ;Draworder operations according to M3 standards.
;;; ;Reviewed and modified by: Alan J. Thompson. 'alanjt@gmail.com'
;;; ;And Marco Antonio Jacinto Perez 'mcoan001@hotmail.com'
;;; ;December 2009
;;;
;;;文子避让
(VL-LOAD-COM)
(DEFUN c:BA (/ *error* ttm2 ss elist sel1 sel3 dimt)
;;; error handler
(DEFUN *error* (#Message)
(AND dimt (SETVAR "dimtfill" dimt))
(AND #Message
(NOT (WCMATCH (STRCASE #Message) "*BREAK*,*CANCEL*,*QUIT*"))
(PRINC (STRCAT "\nError: " #Message))
) ;_ and
) ;_ defun
;; Using code from Roberto Gonzalez -robierzogg- from HISPACAD
;; http://www.hispacad.com/foro/viewtopic.php?p=142823&sid=b23c3147d2a06a29d1dfd60078f79c08
;; This routine works only if Express tools are installed
;; Convert selected text into Mtext
(COMMAND "undo" "begin") ;beginning of undo group
(DEFUN ttm2 (name_n / collect n name_n insertpt name_n1 newlist)
(SETQ insertpt (ASSOC 10 (ENTGET name_n)))
; Convert Text to Mtext, using the
; EXPRESS
; command
(COMMAND "txt2mtxt" name_n "")
; We set their original insertion point
; here
;;;creo que esta parte mueve los nuevos mtextos de posicion hacia arriba
;;;no se por que lo pusieron?
(SETQ name_n1 (ENTLAST))
(SETQ newlist (SUBST insertpt
(ASSOC 10 (ENTGET name_n1))
(ENTGET name_n1)
)
)
(ENTMOD newlist)
(SETQ newlist (SUBST '(71 . 7)
(ASSOC 71 (ENTGET name_n1))
(ENTGET name_n1)
)
)
(ENTMOD newlist)
(SETQ newlist (SUBST '(46 . 0)
(ASSOC 46 (ENTGET name_n1))
(ENTGET name_n1)
)
)
(ENTMOD newlist)
(SETQ newlist (SUBST '(41 . 0)
(ASSOC 41 (ENTGET name_n1))
(ENTGET name_n1)
)
)
(ENTMOD newlist)
) ;_ defun
;;; Aqui pongo la variable Mtexts como un parametro, el cual corresponde al ss
;;; que vas creando con los nuevos Mtextos
(DEFUN mw5 (mtexts / mtexts idx ename EntData dxf42 dxf43 EntData1)
;Reset Width - Mtext
(IF mtexts
;; Aqui se hace el cambio para que en lugar
;; de cambiar todos los mtextos, solo modifique los que recien creaste
;; (setq mtexts (ssget "_X" '((0 . "MTEXT"))))
;; Rogerio Brazil from an autodesk Discussion groups
;; http://discussion.autodesk.com/forums/thread.jspa?messageID=6339167&tstart=0
(PROGN
(SETQ idx 0)
(REPEAT (SSLENGTH mtexts)
(SETQ ename (SSNAME mtexts idx))
(SETQ EntData (ENTGET ename '("*")))
(SETQ dxf42 (* (CDR (ASSOC 42 EntData))1.07))
(SETQ dxf43 (CDR (ASSOC 43 EntData)))
(SETQ EntData1
(ENTMOD (SUBST (CONS 41 dxf42) (ASSOC 41 EntData) EntData))
)
(ENTMOD (SUBST (CONS 46 dxf43) (ASSOC 46 EntData1) EntData1)
)
(SETQ idx (1+ idx))
) ;progn
) ;repeat
(PRINC "\n Null Selection!")
) ;if
(PRINC)
)
;;
;;
;; ; MAIN ROUTINE
;;
;;
;; Some part of code from Tom Beauford, from AUGI
;; http://forums.augi.com/showthread.php?t=77962
;; Set 'Border Offset Factor' to 1.15
(SETQ dimt (GETVAR "dimtfill"))
(SETVAR "dimtfill" 1)
(PRINC
"\nSelect Dimensions and text to apply the background fill and update...: "
)
(AND (SETQ ss (SSGET "_:L" '((0 . "MTEXT,*DIMENSION*,TEXT"))))
(FOREACH x (VL-REMOVE-IF 'LISTP (MAPCAR 'CADR (SSNAMEX ss)))
(COND
((EQ "DIMENSION" (CDR (ASSOC 0 (SETQ elist (ENTGET x)))))
(VLA-PUT-TEXTFILL
(VLAX-ENAME->VLA-OBJECT x)
:VLAX-TRUE
)
(ENTMOD elist)
)
((EQ "MTEXT" (CDR (ASSOC 0 (SETQ elist (ENTGET x)))))
(VLA-PUT-BACKGROUNDFILL
(VLAX-ENAME->VLA-OBJECT x)
:VLAX-TRUE
)
(SETQ elist (SUBST (CONS 41 0.0) (ASSOC 41 elist) elist)
elist (SUBST (CONS 46 0.0) (ASSOC 46 elist) elist)
elist (SUBST (CONS 45 1.15) (ASSOC 45 elist) elist)
elist (SUBST (CONS 421 256) (ASSOC 421 elist) elist)
) ;_ setq
(ENTMOD elist)
)
((EQ "TEXT" (CDR (ASSOC 0 (ENTGET x))))
(ttm2 x)
(SSDEL x ss)
(VLA-PUT-BACKGROUNDFILL
(VLAX-ENAME->VLA-OBJECT (SETQ elist (ENTLAST)))
:VLAX-TRUE
)
(SSADD elist ss)
(SETQ elist (ENTGET elist))
(SETQ elist (SUBST (CONS 45 1.15) (ASSOC 45 elist) elist)
elist (SUBST (CONS 421 256) (ASSOC 421 elist) elist)
) ;_ setq
(ENTMOD elist)
)
(T T)
) ;_ cond
) ;_ foreach
(VL-CMDF "_.-dimstyle" "_apply" ss "")
(VL-CMDF "_.draworder" ss "" "_f")
) ;_ and
(setq
BkLst
'("CENTER LINE2" "COLUMN ROW BUBBLE2""DETAIL BUBBLE 12"
"DETAIL BUBBLE2" "DUST PICK UP POINT2" "EQUIPMENT TAG2"
"FULL SECTION LR2" "FULL SECTION UD2" "FULL SECTION2"
"MATCH LINE SP2" "MATCH LINE2" "NORTH ARROW2"
"NOTE BOX2" "NOTE ENCL2" "PARTIAL SECTION T2"
"PARTIAL SECTION2" "PLATE2" "REVISION2"
"SAMPLE NUMBER2" "SECTION CUT UD2" "SECTION CUT2"
"STAMP BIG2" "STAMP SMALL2" "STREAM NUMBER2"
"STREAM SEQUENCE2" "TAG2" "TITLE 12"
"TITLE BUBBLE 12" "TITLE BUBBLE2" "TITLE2"
"WORK POINT2" "ROOMTAG" "ROOMTAG2" "DOORTAG"
"WALLTAG" "WINDOWTAG" "MULTIPLE DETAIL"
"IND WALL CEIL 1" "IND WALL UP 1" "IND WALL L 1"
"IND WALL R 1" "IND WALL DN 1" "MULTIPLE DETAIL"
)
NomBloques (car BkLst)
BkName (mapcar '(lambda (x)
(setq NomBloques (strcat NomBloques "," x))
)
(cdr BkLst)
)
)
(if (setq sel5 (ssget "_X" (list '(-4 . "<OR")
; _Se seleccionan todos los bloques de
; usuario, despues se procesaran los
; nombres esto para poder procesar los
; bloques dinamicos
'(-4 . "<AND")
'(0 . "INSERT")
(cons 2 (strcat NomBloques ",`*U*"))
'(-4 . "AND>")
'(-4 . "OR>")
)
)
)
(VL-CMDF "_.draworder" sel5 "" "_f")
) ;_ if
(IF (SETQ sel4
(SSGET
"_X"
'((0
.
"line,lwpolyline,insert,polyline,arc,circle,spline,hatch,region"
)
)
)
)
(VL-CMDF "_.draworder" sel4 "" "_b")
) ;_ if
(IF (SETQ sel1 (SSGET "_X" '((0 . "leader,*Dimension*"))))
(VL-CMDF "_.draworder" sel1 "" "_f")
) ;_ if
(IF (SETQ sel3
(SSGET "_X"
'((0 . "line,lwpolyline,polyline")
(8 . "Dims,Ar-Dims,G-Dims,M-Dims,E-Dims,S-Dims,P-Dims")
)
) ;_ ssget
) ;_ setq
(VL-CMDF "_.draworder" sel3 "" "_f")
) ;_ if
(SETVAR "dimtfill" dimt)
(PRINC)
(COMMAND "undo" "end") ;end of undo group
(mw5 ss)
) ;_ defun
(PRINC
"\Type \"BA\" to mask all text, mtext and dimensions, adding mtext box"
)
;|?Visual LISP? Format Options?
(80 2 40 2 nil "end of " 60 9 2 0 0 T T T T)
;*** DO NOT add text below the comment! ***|; 429014673 发表于 2015-8-17 09:00 static/image/common/back.gif
Select Dimension or Text to set BackgroundFill to Masked : ActiveX 服务器返回错误:
未知名称: Backg ...
我在2013里面可以，底版本可能没有vla-put-backgroundfill这个函数 2007里面标注和MTEXT都可以 本帖最后由 waterchen 于 2015-8-17 10:28 编辑
我的2013也不可以哦。在ET工具里有个Text Mask也是这个功能的。 2016中试了还是正常运转的
只是感觉不能当时显示效果
要复制到别处后才有效果啊
移动到别处后也没效果的 谢谢楼主分享
页:
[1]