明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 2428|回复: 7

[函数] 标注.文字.的遮罩

[复制链接]
发表于 2015-8-16 20:54:18 | 显示全部楼层 |阅读模式
  1. ;;;是这里看到的 ,我英文很差。大家去这里http://www.theswamp.org 玩吧<img src="http://bbs.mjtd.com/static/image/smiley/qq/em01.gif" smilieid="271" alt="" border="0">。

  2. ;;;---------------------------
  3. ;;;文字遮罩
  4. (defun c:TBG () (textDimbackgroundfill) (princ))

  5. (defun textDimbackgroundfill (/ ent)
  6.   ;; codehimbelonga kdub@theSwamp 2008
  7.     (while (setq ENT (KDUB:OBJSEL "Select Dimension or Text to set BackgroundFill to Masked"
  8.                                   (list "DIMENSION" "MTEXT" "TEXT")
  9.                                   nil
  10.                      )
  11.            )
  12.         (if (= "DIMENSION" (cdr (assoc 0 (entget (car ent)))))
  13.             (vla-put-textfill (vlax-ename->vla-object (car ent)) :vlax-true)
  14.             ;; else
  15.             (vla-put-backgroundfill (vlax-ename->vla-object (car ent))
  16.                                     :vlax-true
  17.             )
  18.         )
  19.     )
  20.     (princ)
  21. )
  22. ;;;---------------------------
  23. ;;;------------------------------------------------------------------
  24. (defun kdub:objsel (promptmsg                ;
  25.                     typelist                 ; List of entity types allowed to be selected
  26.                     nentselflag              ; If true nentsel permitted , otherwise use entsel.
  27.                     /            pickok       returnvalue
  28.                     tmp
  29.                    )
  30.   ;; codehimbelonga kdub@theSwamp 2008
  31.   (setq promptmsg (strcat "\n"
  32.                           (cond (promptmsg)
  33.                                 ("Select object")
  34.                           )
  35.                           " : "
  36.                   )
  37.   )
  38.   (while (not pickok)
  39.     (setvar "ERRNO" 0)
  40.     (setq returnvalue (if nentselflag
  41.                         (nentsel promptmsg)
  42.                         (entsel promptmsg)
  43.                       )
  44.     )
  45.     (cond
  46.       ((= (getvar "ERRNO") 52)               ; enter
  47.        ;; skip out
  48.        (setq pickok t)
  49.       )
  50.       ((= (getvar "ERRNO") 7)
  51.        (princ "Nothing found at selectedpoint. ")
  52.       )
  53.       ((and
  54.          (setq tmp (entget (car returnvalue))) ; object type
  55.          typelist
  56.          (not (member (cdr (assoc 0 tmp)) (mapcar 'strcase typelist)))
  57.        )                                     ; wrong type
  58.        (alert
  59.          (strcat "Selected object is not"
  60.                  "\na "
  61.                  (apply 'strcat
  62.                         (cons (car typelist)
  63.                               (mapcar '(lambda (x) (strcat "\nor " x))
  64.                                       (cdr typelist)
  65.                               )
  66.                         )
  67.                  )
  68.                  ". "
  69.          )
  70.        )
  71.       )
  72.       ;; skip out
  73.       ((setq pickok t))
  74.     )
  75.   )
  76.   returnvalue
  77. )
  78. ;;;------------------------------------------------------------------
"觉得好,就打赏"
还没有人打赏,支持一下
发表于 2015-8-17 09:00:39 | 显示全部楼层
Select Dimension or Text to set BackgroundFill to Masked : ActiveX 服务器返回错误:
未知名称: BackgroundFill
 楼主| 发表于 2015-8-17 09:34:55 | 显示全部楼层
  1. ;;; ;BA.lsp  -BACKGROUND FILL ALL-
  2. ;;; ;Made for M3 Mexicana. Coding Selected by Paulo Gil Soto. December 2009
  3. ;;; ;This routine will set a background color fill to all selected text,
  4. ;;; ;mtext and dimensions, text objects will be converted to mtext with width=0
  5. ;;; ;and then will add their text box control points
  6. ;;; ;It will bring objects in layer 'Dims' to front at the end, as well as other
  7. ;;; ;Draworder operations according to M3 standards.
  8. ;;; ;Reviewed and modified by: Alan J. Thompson. 'alanjt@gmail.com'
  9. ;;; ;And Marco Antonio Jacinto Perez 'mcoan001@hotmail.com'
  10. ;;; ;December 2009
  11. ;;;
  12. ;;;文子避让
  13. (VL-LOAD-COM)
  14. (DEFUN c:BA (/ *error* ttm2 ss elist sel1 sel3 dimt)

  15. ;;; error handler
  16.   (DEFUN *error* (#Message)
  17.     (AND dimt (SETVAR "dimtfill" dimt))
  18.     (AND #Message
  19.         (NOT (WCMATCH (STRCASE #Message) "*BREAK*,*CANCEL*,*QUIT*"))
  20.         (PRINC (STRCAT "\nError: " #Message))
  21.     ) ;_ and
  22.   ) ;_ defun

  23. ;; Using code from Roberto Gonzalez -robierzogg- from HISPACAD
  24. ;; http://www.hispacad.com/foro/viewtopic.php?p=142823&sid=b23c3147d2a06a29d1dfd60078f79c08
  25. ;; This routine works only if Express tools are installed
  26. ;; Convert selected text into Mtext


  27.   (COMMAND "undo" "begin")                ;beginning of undo group
  28.   (DEFUN ttm2 (name_n / collect n name_n insertpt name_n1 newlist)
  29.     (SETQ insertpt (ASSOC 10 (ENTGET name_n)))
  30.                                         ; Convert Text to Mtext, using the
  31.                                         ; EXPRESS
  32.                                         ; command
  33.     (COMMAND "txt2mtxt" name_n "")
  34.                                         ; We set their original insertion point
  35.                                         ; here
  36. ;;;creo que esta parte mueve los nuevos mtextos de posicion hacia arriba
  37. ;;;no se por que lo pusieron?
  38.     (SETQ name_n1 (ENTLAST))
  39.     (SETQ newlist (SUBST insertpt
  40.                         (ASSOC 10 (ENTGET name_n1))
  41.                         (ENTGET name_n1)
  42.                  )
  43.     )
  44.     (ENTMOD newlist)
  45.     (SETQ newlist (SUBST '(71 . 7)
  46.                         (ASSOC 71 (ENTGET name_n1))
  47.                         (ENTGET name_n1)
  48.                  )
  49.     )
  50.     (ENTMOD newlist)
  51.     (SETQ newlist (SUBST '(46 . 0)
  52.                         (ASSOC 46 (ENTGET name_n1))
  53.                         (ENTGET name_n1)
  54.                  )
  55.     )
  56.     (ENTMOD newlist)
  57.     (SETQ newlist (SUBST '(41 . 0)
  58.                         (ASSOC 41 (ENTGET name_n1))
  59.                         (ENTGET name_n1)
  60.                  )
  61.     )
  62.     (ENTMOD newlist)
  63.   ) ;_ defun


  64. ;;; Aqui pongo la variable Mtexts como un parametro, el cual corresponde al ss
  65. ;;; que vas creando con los nuevos Mtextos
  66.   (DEFUN mw5 (mtexts / mtexts idx ename EntData dxf42 dxf43 EntData1)
  67.                                         ;Reset Width - Mtext
  68.     (IF        mtexts
  69. ;; Aqui se hace el cambio para que en lugar
  70. ;; de cambiar todos los mtextos, solo modifique los que recien creaste
  71. ;; (setq mtexts (ssget "_X" '((0 . "MTEXT"))))
  72. ;; Rogerio Brazil from an autodesk Discussion groups
  73. ;; http://discussion.autodesk.com/forums/thread.jspa?messageID=6339167&tstart=0
  74.       (PROGN
  75.         (SETQ idx 0)
  76.         (REPEAT        (SSLENGTH mtexts)
  77.          (SETQ ename (SSNAME mtexts idx))
  78.          (SETQ EntData (ENTGET ename '("*")))
  79.          (SETQ dxf42 (* (CDR (ASSOC 42 EntData))1.07))
  80.          (SETQ dxf43 (CDR (ASSOC 43 EntData)))
  81.          (SETQ        EntData1
  82.                 (ENTMOD (SUBST (CONS 41 dxf42) (ASSOC 41 EntData) EntData))
  83.          )
  84.          (ENTMOD (SUBST (CONS 46 dxf43) (ASSOC 46 EntData1) EntData1)
  85.          )
  86.          (SETQ idx (1+ idx))
  87.         )                                ;progn
  88.       )                                        ;repeat
  89.       (PRINC "\n Null Selection!")
  90.     )                                        ;if
  91.     (PRINC)
  92.   )


  93. ;;
  94. ;;
  95. ;;                                ; MAIN ROUTINE
  96. ;;
  97. ;;
  98. ;; Some part of code from Tom Beauford, from AUGI
  99. ;; http://forums.augi.com/showthread.php?t=77962
  100. ;; Set 'Border Offset Factor' to 1.15

  101.   (SETQ dimt (GETVAR "dimtfill"))
  102.   (SETVAR "dimtfill" 1)

  103.   (PRINC
  104.     "\nSelect Dimensions and text to apply the background fill and update...: "
  105.   )
  106.   (AND (SETQ ss (SSGET "_:L" '((0 . "MTEXT,*DIMENSION*,TEXT"))))
  107.        (FOREACH        x (VL-REMOVE-IF 'LISTP (MAPCAR 'CADR (SSNAMEX ss)))
  108.         (COND
  109.           ((EQ "DIMENSION" (CDR (ASSOC 0 (SETQ elist (ENTGET x)))))
  110.            (VLA-PUT-TEXTFILL
  111.              (VLAX-ENAME->VLA-OBJECT x)
  112.              :VLAX-TRUE
  113.            )
  114.            (ENTMOD elist)
  115.           )
  116.           ((EQ "MTEXT" (CDR (ASSOC 0 (SETQ elist (ENTGET x)))))
  117.            (VLA-PUT-BACKGROUNDFILL
  118.              (VLAX-ENAME->VLA-OBJECT x)
  119.              :VLAX-TRUE
  120.            )
  121.            (SETQ elist        (SUBST (CONS 41 0.0) (ASSOC 41 elist) elist)
  122.                  elist        (SUBST (CONS 46 0.0) (ASSOC 46 elist) elist)
  123.                  elist        (SUBST (CONS 45 1.15) (ASSOC 45 elist) elist)
  124.                  elist        (SUBST (CONS 421 256) (ASSOC 421 elist) elist)
  125.            ) ;_ setq
  126.            (ENTMOD elist)
  127.           )
  128.           ((EQ "TEXT" (CDR (ASSOC 0 (ENTGET x))))
  129.            (ttm2 x)
  130.            (SSDEL x ss)
  131.            (VLA-PUT-BACKGROUNDFILL
  132.              (VLAX-ENAME->VLA-OBJECT (SETQ elist (ENTLAST)))
  133.              :VLAX-TRUE
  134.            )
  135.            (SSADD elist ss)
  136.            (SETQ elist (ENTGET elist))
  137.            (SETQ elist        (SUBST (CONS 45 1.15) (ASSOC 45 elist) elist)
  138.                  elist        (SUBST (CONS 421 256) (ASSOC 421 elist) elist)
  139.            ) ;_ setq
  140.            (ENTMOD elist)
  141.           )

  142.           (T T)
  143.         ) ;_ cond
  144.        ) ;_ foreach
  145.        (VL-CMDF "_.-dimstyle" "_apply" ss "")
  146.        (VL-CMDF "_.draworder" ss "" "_f")
  147.   ) ;_ and

  148. (setq
  149.     BkLst
  150.            '("CENTER LINE2"   "COLUMN ROW BUBBLE2"  "DETAIL BUBBLE 12"
  151.              "DETAIL BUBBLE2"     "DUST PICK UP POINT2"     "EQUIPMENT TAG2"
  152.              "FULL SECTION LR2"     "FULL SECTION UD2"     "FULL SECTION2"  
  153.              "MATCH LINE SP2"     "MATCH LINE2"     "NORTH ARROW2"   
  154.              "NOTE BOX2"     "NOTE ENCL2"     "PARTIAL SECTION T2"   
  155.              "PARTIAL SECTION2"     "PLATE2"     "REVISION2"   
  156.              "SAMPLE NUMBER2"     "SECTION CUT UD2"     "SECTION CUT2"   
  157.              "STAMP BIG2"     "STAMP SMALL2"     "STREAM NUMBER2"   
  158.              "STREAM SEQUENCE2"     "TAG2"     "TITLE 12"   
  159.              "TITLE BUBBLE 12"     "TITLE BUBBLE2"     "TITLE2"   
  160.              "WORK POINT2"     "ROOMTAG"     "ROOMTAG2"     "DOORTAG"   
  161.              "WALLTAG"     "WINDOWTAG"     "MULTIPLE DETAIL"   
  162.              "IND WALL CEIL 1"     "IND WALL UP 1"     "IND WALL L 1"  
  163.              "IND WALL R 1"     "IND WALL DN 1"     "MULTIPLE DETAIL"
  164.         )
  165.     NomBloques (car BkLst)
  166.     BkName     (mapcar '(lambda    (x)
  167.               (setq NomBloques (strcat NomBloques "," x))
  168.             )
  169.                (cdr BkLst)
  170.            )
  171.   )
  172.   (if (setq sel5 (ssget "_X" (list '(-4 . "<OR")
  173.                     ; _Se seleccionan todos los bloques de
  174.                     ; usuario, despues se procesaran los
  175.                     ; nombres esto para poder procesar los
  176.                     ; bloques dinamicos
  177.                    '(-4 . "<AND")
  178.                    '(0 . "INSERT")
  179.                    (cons 2 (strcat NomBloques ",`*U*"))
  180.                    '(-4 . "AND>")
  181.                    '(-4 . "OR>")
  182.              )
  183.           )
  184.       )


  185.     (VL-CMDF "_.draworder" sel5 "" "_f")
  186.   ) ;_ if

  187.   (IF (SETQ sel4
  188.             (SSGET
  189.               "_X"
  190.               '((0
  191.                  .
  192.                  "line,lwpolyline,insert,polyline,arc,circle,spline,hatch,region"
  193.                 )
  194.                 )
  195.             )
  196.       )
  197.     (VL-CMDF "_.draworder" sel4 "" "_b")
  198.   ) ;_ if

  199.   (IF (SETQ sel1 (SSGET "_X" '((0 . "leader,*Dimension*"))))
  200.     (VL-CMDF "_.draworder" sel1 "" "_f")
  201.   ) ;_ if

  202.   (IF (SETQ sel3
  203.             (SSGET "_X"
  204.                    '((0 . "line,lwpolyline,polyline")
  205.                      (8 . "Dims,Ar-Dims,G-Dims,M-Dims,E-Dims,S-Dims,P-Dims")
  206.                     )
  207.             ) ;_ ssget
  208.       ) ;_ setq
  209.     (VL-CMDF "_.draworder" sel3 "" "_f")
  210.   ) ;_ if
  211.   (SETVAR "dimtfill" dimt)

  212.   (PRINC)
  213.   (COMMAND "undo" "end")                ;end of undo group

  214.   (mw5 ss)

  215. ) ;_ defun
  216. (PRINC
  217.   "\Type "BA" to mask all text, mtext and dimensions, adding mtext box"
  218. )


  219. ;|?Visual LISP? Format Options?
  220. (80 2 40 2 nil "end of " 60 9 2 0 0 T T T T)
  221. ;*** DO NOT add text below the comment! ***|;
 楼主| 发表于 2015-8-17 09:44:24 | 显示全部楼层
429014673 发表于 2015-8-17 09:00
Select Dimension or Text to set BackgroundFill to Masked : ActiveX 服务器返回错误:
未知名称: Backg ...

我在2013里面可以,底版本可能没有vla-put-backgroundfill这个函数

点评

64bit cad2010  发表于 2015-8-17 11:37
 楼主| 发表于 2015-8-17 10:00:04 | 显示全部楼层
2007里面标注和MTEXT都可以
发表于 2015-8-17 10:13:41 | 显示全部楼层
本帖最后由 waterchen 于 2015-8-17 10:28 编辑

我的2013也不可以哦。在ET工具里有个Text Mask也是这个功能的。

点评

2007里面标注和MTEXT都可以。(VL-LOAD-COM)  发表于 2015-8-17 10:24
发表于 2015-8-17 10:57:47 | 显示全部楼层
2016中试了还是正常运转的
只是感觉不能当时显示效果
要复制到别处后才有效果啊
移动到别处后也没效果的
发表于 2018-2-14 20:35:40 | 显示全部楼层
谢谢楼主分享
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2025-5-19 15:38 , Processed in 0.181333 second(s), 27 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表