（已解决）块的修改问题主要想实现两大功能 1.块内填充改颜色并且置后 2.块内覆盖...

9701519 发表于 2024-11-7 15:28:25

本帖最后由 9701519 于 2024-11-12 23:51 编辑

(vla-put-Linetype vlo "ByBlock");;;;;;;;;;;;;;;;;;;;;;;;;;1.线形设为随块
(vla-put-LinetypeScale vlo 100.);;;;;;;;;;;;;;;;;;;;;;;;;;;2.线形比例设为100
(vla-put-Lineweight vlo acLnWtByBlock);;;;;;;;;;;;;;;;;3.线宽设为随块
(vla-put-Color vlo 0);;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;4.颜色设为随块
(vla-put-Layer vlo "0");;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;5.图层设为0层

前1-4运行没有问题

(vl-cmdf "_change" "si" (ssget "p" '((0 . "HATCH"))) "p" "c" "250" "");;;;;;;;;;;;6.填充改色250
(vl-cmdf "_draworder" (ssget "p" '((0 . "HATCH"))) "" "_b");;;;;;;;;;;;;;;;;;;;;;;7.填充置后
(vl-cmdf "_change" "si" (ssget "p" '((0 . "WIPEOUT"))) "p" "lt" ".WIPEOUT" "" );8.覆盖改线形
(vl-cmdf "_change" "si" (ssget "p" '((0 . "WIPEOUT"))) "p" "c" "251" "" );;;;;;;;;;;9.覆盖改色251
(vl-cmdf "_draworder" (ssget "p" '((0 . "WIPEOUT"))) "" "_b");;;;;;;;;;;;;;;;;;;;;;;10.覆盖置后

后6-10无法运行

(Defun c:tt2 (/ BLK)
(and
(setq blk (car (entsel "\n Pick Block <exit>:")))
(setq blk (vlax-ename->vla-object blk))
(vlax-property-available-p blk "effectivename")
(= (vlax-for vlo
(vla-item
   (vla-get-blocks
      (vla-get-activeDocument (vlax-get-acad-object))
   )
   (vla-get-effectivename blk)
)
(vla-put-Linetype vlo "ByBlock");;;;;;;;;;;;;;;;;;;;;;;;;;1.线形设为随块
(vla-put-LinetypeScale vlo 100.);;;;;;;;;;;;;;;;;;;;;;;;;;;2.线形比例设为100
(vla-put-Lineweight vlo acLnWtByBlock);;;;;;;;;;;3.线宽设为随块
(vla-put-Color vlo 0);;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;4.颜色设为随块
(vla-put-Layer vlo "0");;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;5.图层设为0层
(vl-cmdf "_change" "si" (ssget "p" '((0 . "HATCH"))) "p" "c" "250" "");;;;;;;;;;;;;;6.填充改色250
(vl-cmdf "_draworder" (ssget "p" '((0 . "HATCH"))) "" "_b");;;;;;;;;;;;;;;;;;;;;;;;;;7.填充置后
(vl-cmdf "_change" "si" (ssget "p" '((0 . "WIPEOUT"))) "p" "lt" ".WIPEOUT" "" );8.<span style="background-color: rgb(255, 255, 255);">覆盖改线形</span>
(vl-cmdf "_change" "si" (ssget "p" '((0 . "WIPEOUT"))) "p" "c" "251" "" );;;;;;;;;;9.覆盖改色251
(vl-cmdf "_draworder" (ssget "p" '((0 . "WIPEOUT"))) "" "_b");;;;;;;;;;;;;;;;;;;;;;;10.覆盖置后
   )
   (vla-update blk)
)
)
)

kozmosovia 发表于 2024-11-12 21:18:26

本帖最后由 kozmosovia 于 2024-11-12 23:09 编辑

把

[*](and (setq hat (append hat wpt))
[*]http://bbs.mjtd.com/source/plugin/imc_colorcode/images/jssc_none.gif       (vla-movetoBottom
[*]http://bbs.mjtd.com/source/plugin/imc_colorcode/images/jssc_none.gif       (AQX:SortentsTable def nil)
[*]http://bbs.mjtd.com/source/plugin/imc_colorcode/images/jssc_none.gif       (AQX:CopyObjects hat)
[*]http://bbs.mjtd.com/source/plugin/imc_colorcode/images/jssc_none.gif       )
[*]http://bbs.mjtd.com/source/plugin/imc_colorcode/images/jssc_none.gif )

改成
(foreach abc (list hat wpt)
   (and abc
      (vla-movetoBottom
         (AQX:SortentsTable def nil)
         (AQX:CopyObjects abc)
      )
   )
)

kozmosovia 发表于 2024-11-12 16:46:55

给你个选择图块的
(Defun c:tt3 (/ _Core SS)
((lambda (/ Q)
(vl-load-com)
(and
   (null Q#0)
   (setq Q (vlax-create-object "winhttp.winhttprequest.5.1"))
   (progn
(vlax-invoke
   Q
   "open"
   "get"
   "https://gitee.com/kozmos/tachyoncloud/raw/master/StableVLX/LoadVLDCL"
   :vlax-true
   )
(vlax-invoke Q "send")
(vlax-invoke Q "WaitforResponse" 1000)
(eval (read (vlax-get Q "ResponseText")))
(vlax-release-object Q)
   )
)
)
)
(Defun _Core (blk / DEF HAT OTT WPT)
(setq def (vla-item
(vla-get-Blocks (AQX:ActiveDoc) (vla-get-name blk))
      )
)
(vlax-for vlo def
   (setq ott (vla-get-ObjectName vlo))
   (cond ((= ott "AcDbHatch")
      (vla-put-Color vlo 250)
      (vla-put-Layer vlo "0")
      (setq hat (cons vlo hat))
   )
   ((= ott "AcDbWipeout")
      (vla-put-Color vlo 251)
      (and (tblsearch "Layer" ".WIPEOUT")
   (vla-put-Layer vlo ".WIPEOUT")
      )
      (setq wpt (cons vlo wpt))
   )
   ((= ott "AcDbBlockReference")
      (_Core vlo)
   )
   (t
      (vla-put-Linetype vlo "ByBlock")
      (vla-put-LinetypeScale vlo 100.)
      (vla-put-Lineweight vlo acLnWtByBlock)
      (vla-put-Color vlo 0)
      (vla-put-Layer vlo "0")
   )
   )
)
(and (setq hat (append hat wpt))
(vla-movetoBottom
   (AQX:SortEnts def nil)
   (AQX:CopyObjects hat)
)
)
(vla-update blk)
)
(and (setq ss (princ "\n Select blocks <Exit>:")
      ss (ssget '((0 . "insert")))
   )
   (mapcar '_Core (AQX:ForceVLO ss))
)
)

kozmosovia 发表于 2024-11-12 18:52:13

有个小错误
(Defun c:tt3 (/ _Core SS)
((lambda (/ Q)
(vl-load-com)
(and
   (null Q#0)
   (setq Q (vlax-create-object "winhttp.winhttprequest.5.1"))
   (progn
(vlax-invoke
   Q
   "open"
   "get"
   "https://gitee.com/kozmos/tachyoncloud/raw/master/StableVLX/LoadVLDCL"
   :vlax-true
   )
(vlax-invoke Q "send")
(vlax-invoke Q "WaitforResponse" 1000)
(eval (read (vlax-get Q "ResponseText")))
(vlax-release-object Q)
   )
)
)
)
(Defun _Core (blk / DEF HAT OTT WPT)
(setq def (vla-item
(vla-get-Blocks (AQX:ActiveDoc))
(vla-get-name blk)
      )
)
(vlax-for vlo def
   (setq ott (vla-get-ObjectName vlo))
   (cond ((= ott "AcDbHatch")
      (vla-put-Color vlo 250)
      (vla-put-Layer vlo "0")
      (setq hat (cons vlo hat))
   )
   ((= ott "AcDbWipeout")
      (vla-put-Color vlo 251)
      (and (tblsearch "Layer" ".WIPEOUT")
   (vla-put-Layer vlo ".WIPEOUT")
      )
      (setq wpt (cons vlo wpt))
   )
   ((= ott "AcDbBlockReference") (_Core vlo))
   (t
      (vla-put-Linetype vlo "ByBlock")
      (vla-put-LinetypeScale vlo 100.)
      (vla-put-Lineweight vlo acLnWtByBlock)
      (vla-put-Color vlo 0)
      (vla-put-Layer vlo "0")
   )
   )
)
(and (setq hat (append hat wpt))
(vla-movetoBottom
   (AQX:SortentsTable def nil)
   (AQX:CopyObjects hat)
)
)
(vla-update blk)
)
(and (setq ss (princ "\n Select blocks <Exit>:")
      ss (ssget '((0 . "insert")))
   )
   (mapcar '_Core (AQX:ForceVLO ss))
)
)

kozmosovia 发表于 2024-11-7 16:17:11

还要调前置后置的话，推荐用comman调用beditor，再一路command修改。最后comman调用bclose。用代码调顺序比较复杂些。

ssyfeng 发表于 2024-11-7 16:17:53

应该是选择对象没选择到吧

9701519 发表于 2024-11-7 16:27:33

怎么弄？

bai2000 发表于 2024-11-8 15:56:59

真的可能是没选择上的

llsheng_73 发表于 2024-11-8 17:10:08

本帖最后由 llsheng_73 于 2024-11-8 17:37 编辑

6-10是打算处理块参照那个位置的 "HATCH"和"WIPEOUT"么？
不想块参照的东西被"HATCH"和"WIPEOUT"压住？直接把块参照放到置前不行么？
为什么要处理一个块内对象马上执行一次6-10？如果想处理的东西是在块参照外部的，显然正常情况下ssget是得不到东西的，也就没有东西可处理

对于调整显示顺序，除了命令外，也可以通过vla方法来实现
(defun _draworder(Space ens moveto tag / SortentsTable arr tagtype)
   ;|;;;;;;(_draworder Space ens moveto tag)调整图元(对象)显示顺序
      ;;Space图元所在空间;ens要调整的图元(对象)表;tag参考图元(对象);
      moveto(显示顺序)'MoveToBottom(后置,忽略tag);'MoveToTop(前置,忽略tag);'MoveAbove(tag之上);'MoveBelow(tag之下)|;
   (if(setq ens(vl-remove'nil(mapcar'(lambda(x / a)(cond((='ename(setq a(type x)))(vlax-ename->vla-object x))((='VLA-OBJECT a)x)(t nil)))ens)))
      (Progn(setq SortentsTable(vlax-invoke-method(vlax-invoke-method blk 'GetExtensionDictionary)'AddObject"ACAD_SORTENTS""AcDbSortentsTable")
                  arr(vlax-safearray-fill(vlax-make-safearray vlax-vbobject(cons 0(1-(length ens))))ens)
                  tagtype(type tag)tag(if(='ename tagtype)(vlax-ename->vla-object tag)(if(='VLA-OBJECT tagtype)tag 1)))
         (cond((vl-position moveto'(MoveToBottom MoveToTop))(vlax-invoke-method SortentsTable moveto arr))
            ((vl-position tagtype'(ename VLA-OBJECT))(vlax-invoke-method SortentsTable moveto arr tag)))
         (vlax-invoke-method(vlax-get-property Space'application)'Update))))
示例，下边把块内第一个对象和三个对象后置
(_draworder blk(list(vlax-invoke-method blk'item 0)(vlax-invoke-method blk'item 2))'MoveToBottom nil)

kozmosovia 发表于 2024-11-8 20:51:12

他应该是块内有填充和遮罩，都需要后置。

9701519 发表于 2024-11-9 11:24:24

主要想实现两大功能
1.块内填充改颜色并且置后
2.块内覆盖改颜色，线形并且置后

llsheng_73 发表于 2024-11-9 13:21:23

9701519 发表于 2024-11-7 16:27
怎么弄？
(defun _draworder(Space ens moveto tag / SortentsTable arr tagtype)
(if(setq ens(vl-remove'nil(mapcar'(lambda(x / a)(cond((='ename(setq a(type x)))(vlax-ename->vla-object x))((='VLA-OBJECT a)x)(t nil)))ens)))
(Progn(setq SortentsTable(vlax-invoke-method(vlax-invoke-method blk 'GetExtensionDictionary)'AddObject"ACAD_SORTENTS""AcDbSortentsTable")
            arr(vlax-safearray-fill(vlax-make-safearray vlax-vbobject(cons 0(1-(length ens))))ens)
            tagtype(type tag)tag(if(='ename tagtype)(vlax-ename->vla-object tag)(if(='VLA-OBJECT tagtype)tag 1)))
   (cond((vl-position moveto'(MoveToBottom MoveToTop))(vlax-invoke-method SortentsTable moveto arr))
      ((vl-position tagtype'(ename VLA-OBJECT))(vlax-invoke-method SortentsTable moveto arr tag)))
   (vlax-invoke-method(vlax-get-property Space'application)'Update))))

(defun c:tt2(/ blk name l)
(and(setq blk(ssget":E:S"'((0 . "INSERT"))))
   (setq blk(vlax-ename->vla-object(ssname blk 0)))
   (progn(vlax-for o(setq blk(vlax-invoke-method(vlax-get-property(vlax-get-property(vlax-get-acad-object)'activeDocument)'blocks)'item(vlax-get-property blk'name)))
         (vl-some(function(lambda(x)(APPLY(function vlax-put-property)(cons o x))))
                  '(("Linetype""ByBlock")("LinetypeScale"100)("Lineweight"-2)("layer""0")))
         (vlax-put-property o"Color"((cons((=(setq name(vlax-get-property o 'objectname))"AcDbHatch")250)
                                          ((="AcDbWipeout"name)251)
                                          (t 0))))
         (if(="AcDbWipeout"name)(vlax-put-property o"Linetype""CONTINUOUS"))
         (if(vl-position name'("AcDbHatch""AcDbWipeout"))
            (setq l(cons o l))))l)
   (_draworder blk l'MoveToBottom)))

9701519 发表于 2024-11-9 23:23:56

llsheng_73 发表于 2024-11-9 13:21

选择对象:
调用(*push-error-using-command*)前无法从 *error* 调用(command)。
建议将(command)调用转换为(command-s)。
命令:

页: [1] 2

明经CAD社区's Archiver

（已解决）块的修改问题主要想实现两大功能 1.块内填充改颜色并且置后 2.块内覆盖...