获取Attdef脚本的ObjectID 乐筑天下 - Powered by Discuz! Archiver

Lee Mac 发表于 2022-7-5 17:40:40

这将为每个字段创建单独的块-但我不知道您为什么要这样处理它。

(defun c:Fld ( / GetBlock GetObjectID PutAttValue InsertBlock AddBlock Itemp
            BLK BOBJ COLL DOC ENT FBLOCK FTAG OBJ PT RESULT SEED SPC TAG VALUE

            )
(vl-load-com)
;; Lee Mac~11.05.10

(setq fBlock "Block") ;; Block Name

(setq ftag"TAG1") ;; Tag Name

(defun GetObjectID ( obj doc )
;; Lee Mac
(if
(eq "X64"
   (strcase
      (getenv "PROCESSOR_ARCHITECTURE")
   )
)
(vlax-invoke-method
   (vla-get-Utility doc) 'GetObjectIdString obj :vlax-false
)
(itoa (vla-get-Objectid obj))
)
)

(defun PutAttValue ( object tag value )
;; Lee Mac~05.05.10
(mapcar
(function
   (lambda ( attrib )
      (and
      (eq tag (vla-get-TagString attrib))
      (vla-put-TextString attrib value)
      )
   )
)
(vlax-invoke object 'GetAttributes)
)
value
)

(defun InsertBlock ( Block Name Point )
(if
(not
   (vl-catch-all-error-p
      (setq result
      (vl-catch-all-apply (function vla-insertblock)
         (list Block (vlax-3D-point point) Name 1. 1. 1. 0.)
      )
      )
   )
)
result
)
)

(defun Itemp ( coll item )
(if
(not
   (vl-catch-all-error-p
      (setq item
      (vl-catch-all-apply
         (function vla-item) (list coll item)
      )
      )
   )
)
item
)
)

(defun AddBlock ( seed pt / coll name )
(setq coll
(vla-get-Blocks
   (vla-get-ActiveDocument
      (vlax-get-acad-object)
   )
)
)

(setq Name
(
   (lambda ( i )
      (while
      (Itemp coll
         (strcat seed
            (itoa
            (setq i (1+ i))
            )
         )
      )
      )
      (strcat seed (itoa i))
   )
   0
)
)

(list
(vla-Add coll
   (vlax-3D-point pt) name
)
name
)
)

(setq spc
(if
(or
   (eq AcModelSpace
      (vla-get-ActiveSpace
      (setq doc
         (vla-get-ActiveDocument
            (vlax-get-acad-object)
         )
      )
      )
   )
   (eq :vlax-true (vla-get-MSpace doc))
)
(vla-get-ModelSpace doc)
(vla-get-PaperSpace doc)
)
)

(while
(progn
(setq ent (car (entsel "\nSelect Object to Retrieve Area: ")))

(cond
   (
      (eq 'ENAME (type ent))

      (if
      (not
         (vlax-property-available-p
            (setq obj (vlax-ename->vla-object ent)) 'Area
         )
      )
      (princ "\n** Invalid Object Selected **")

      (if
         (and
            (setq pt (getpoint "\nPick Point for Block: "))
            (setq blk(AddBlock fBlock '(0. 0. 0.)))
            (vla-AddAttribute (car blk)
            (vla-get-height
               (Itemp
                  (vla-get-TextStyles doc) (getvar 'TEXTSTYLE)
               )
            )
            acAttributeModePreset
            "Enter Tag Value: "
            (vlax-3D-point '(0. 0. 0.))
            ftag
            ""
            )
            (setq bObj (InsertBlock spc (cadr blk) pt))
         )
         (progn
            (and ftag
            (PutAttValue bObj ftag
               (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                  (GetObjectID obj doc) ">%).Area \\f \"%lu6%qf1\">%"
               )
            )
            )
            (vla-regen doc acActiveViewport)
         )
      )
      )
   t
   )
)
)
)
(princ)
)

Rhincodon 发表于 2022-7-5 17:44:16

是否有可能修改此选项，使插入的块具有3个属性，而不仅仅是区域。即“房间名称”（由用户手动输入）、“面积”和“周长”？？

075 发表于 2022-7-5 17:48:32

很不错的！
这正是我想要的，但我的街区规模有问题。
我的方块以厘米为单位，我在一个米文件中播放lisp。
也许你能帮助我。

Jocker_Boy 发表于 2022-7-5 17:52:44

你好

很抱歉再次提出我关于这个主题的问题“http://www.cadtutor.net/forum/showthread.php?31029-插入-An-Attribute-Block-Then-Fill-In-w-Field/page2“
但这里的东西几乎就是我需要的。

例如，可以选择一个块并检索属性“TAG2”，而不是选择区域。

对不起我的英语。
我来自葡萄牙。

谢谢

BIGAL 发表于 2022-7-5 17:54:58

一点示例代码

(setq ss1 (ssget))
(foreach att (vlax-invoke (vlax-ename->vla-object (ssname SS1 0 )) 'getattributes)
(Princ(strcat "\n" (vla-get-tagstring att) " " (vla-get-textstring att)))
) ; end foreach

Jocker_Boy 发表于 2022-7-5 17:59:27

我是个编程新手。我必须用它替换原始代码的哪一部分？

谢谢

BIGAL 发表于 2022-7-5 18:00:20

我发布的示例显示了标记名和属性值，这是一种查找标记名的简单方法。

(princ "\nPick a attributed block ")
(setq ss1 (ssget))
(foreach att (vlax-invoke (vlax-ename->vla-object (ssname SS1 0 )) 'getattributes)
(if (=(vla-get-tagstring att) "TAG2") (alert (vla-get-textstring att)) )
; put rest of code here
)

Jocker_Boy 发表于 2022-7-5 18:04:58

谢谢你的回复。但我不知道剩下的代码是什么。
我正在尝试使用以下代码：

(defun c:Fld ( / GetBlock GetObjectID PutAttValue InsertBlock
            BOBJ DOC ENT FBLOCK FTAG OBJ PT RESULT SPC TAG VALUE)
(vl-load-com)
;; Lee Mac~11.05.10

(setq fBlock "Block") ;; Block Name or nil

(setq ftag"TAG1") ;; Tag Name

(defun GetBlock ( block )
;; Lee Mac~05.05.10
(cond
(
   (not
      (and
      (or block
         (setq block
            (getfiled "Select Block" "" "dwg" 16)
         )
      )
      (or
         (and
            (vl-position
            (vl-filename-extension block) '("" nil)
            )
            (or
            (tblsearch "BLOCK" block)
            (setq block
               (findfile
                  (strcat block ".dwg")
               )
            )
            )
         )
         (setq block (findfile block))
      )
      )
   )
   nil
)
( block )
)
)

(defun GetObjectID ( obj doc )
;; Lee Mac
(if
(eq "X64"
   (strcase
      (getenv "PROCESSOR_ARCHITECTURE")
   )
)
(vlax-invoke-method
   (vla-get-Utility doc) 'GetObjectIdString obj :vlax-false
)
(itoa (vla-get-Objectid obj))
)
)

(defun PutAttValue ( object tag value )
;; Lee Mac~05.05.10
(mapcar
(function
   (lambda ( attrib )
      (and
      (eq tag (vla-get-TagString attrib))
      (vla-put-TextString attrib value)
      )
   )
)
(vlax-invoke object 'GetAttributes)
)
value
)

(defun InsertBlock ( Block Name Point )
(if
(not
   (vl-catch-all-error-p
      (setq result
      (vl-catch-all-apply (function vla-insertblock)
         (list Block (vlax-3D-point point) Name 1. 1. 1. 0.)
      )
      )
   )
)
result
)
)

(setq spc
(if
(or
   (eq AcModelSpace
      (vla-get-ActiveSpace
      (setq doc
         (vla-get-ActiveDocument
            (vlax-get-acad-object)
         )
      )
      )
   )
   (eq :vlax-true (vla-get-MSpace doc))
)
(vla-get-ModelSpace doc)
(vla-get-PaperSpace doc)
)
)

(if (setq fBlock (GetBlock fBlock))

(while
(progn
   (setq ent (car (entsel "\nSelect Object to Retrieve Area: ")))

   (cond
      (
      (eq 'ENAME (type ent))

      (if
         (not
            (vlax-property-available-p
            (setq obj (vlax-ename->vla-object ent)) 'Area
            )
         )
         (princ "\n** Invalid Object Selected **")

         (if
            (and
            (setq pt (getpoint "\nPick Point for Block: "))
            (setq bObj (InsertBlock spc fBlock pt))
            )
            (progn
            (and ftag
               (PutAttValue bObj ftag
                  (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                  (GetObjectID obj doc) ">%).Area \\f \"%lu6%qf1\">%"
                  )
               )
            )
            (vla-regen doc acActiveViewport)
            )
         )
      )
      )
   )
)
)
(princ "\n** Block not Found **")
)
(princ)
)

它可以很好地选择区域，并将它们插入带有属性“TAG1”的“块”中，并带有选定区域的字段。
但我正在尝试合并你的代码，但我不知道如何合并
我认为“红色”部分是我需要用你的代码替换的部分，但我做错了什么。

对不起，我是新手。

Jocker_Boy 发表于 2022-7-5 18:08:54

在一些谷歌搜索之后，我尝试了以下方法：

(defun c:Fld ( / GetBlock GetObjectID PutAttValue InsertBlock
            BOBJ DOC ENT FBLOCK FTAG OBJ PT RESULT SPC TAG VALUE)
(vl-load-com)
;; Lee Mac~11.05.10

(setq fBlock "BAR2") ;; Block Name or nil

(setq ftag"N") ;; Tag Name

(defun GetBlock ( block )
;; Lee Mac~05.05.10
(cond
(
   (not
      (and
      (or block
         (setq block
            (getfiled "Select Block" "" "dwg" 16)
         )
      )
      (or
         (and
            (vl-position
            (vl-filename-extension block) '("" nil)
            )
            (or
            (tblsearch "BLOCK" block)
            (setq block
               (findfile
                  (strcat block ".dwg")
               )
            )
            )
         )
         (setq block (findfile block))
      )
      )
   )
   nil
)
( block )
)
)

(defun GetObjectID ( obj doc )
;; Lee Mac
(if
(eq "X64"
   (strcase
      (getenv "PROCESSOR_ARCHITECTURE")
   )
)
(vlax-invoke-method
   (vla-get-Utility doc) 'GetObjectIdString obj :vlax-false
)
(itoa (vla-get-Objectid obj))
)
)

(defun PutAttValue ( object tag value )
;; Lee Mac~05.05.10
(mapcar
(function
   (lambda ( attrib )
      (and
      (eq tag (vla-get-TagString attrib))
      (vla-put-TextString attrib value)
      )
   )
)
(vlax-invoke object 'GetAttributes)
)
value
)

(defun InsertBlock ( Block Name Point )
(if
(not
   (vl-catch-all-error-p
      (setq result
      (vl-catch-all-apply (function vla-insertblock)
         (list Block (vlax-3D-point point) Name 1. 1. 1. 0.)
      )
      )
   )
)
result
)
)

(setq spc
(if
(or
   (eq AcModelSpace
      (vla-get-ActiveSpace
      (setq doc
         (vla-get-ActiveDocument
            (vlax-get-acad-object)
         )
      )
      )
   )
   (eq :vlax-true (vla-get-MSpace doc))
)
(vla-get-ModelSpace doc)
(vla-get-PaperSpace doc)
)
)

(if (setq fBlock (GetBlock fBlock))

(while
(progn
   (princ "\nPick a attributed block ")

   (cond
      (

            (setq ss1 (ssget))
(foreach att (vlax-invoke (vlax-ename->vla-object (ssname SS1 0 )) 'getattributes)
(if (=(vla-get-tagstring att) "BAR") (alert (vla-get-textstring att)) ))

(and
            (setq pt (getpoint "\nPick Point for Block: "))
            (setq bObj (InsertBlock spc fBlock pt))
            )
            (progn
            (and ftag
               (PutAttValue bObj ftag
                  (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                  (GetObjectID obj doc) ">%).TextString >%"
                  )
               )
            )

            (vla-regen doc acActiveViewport)

      )
      )
   )
)
)
(princ "\n** Block not Found **")
)
(princ)
)

但我收到了这个错误：“错误：错误的参数类型：VLA-OBJECT nil”
块插入了一个文本为“否”的字段，但在检查过滤器后，问题似乎是ObjectId，它与所选块不对应。

解决方案可能很简单，但我不懂lisp。

谢谢

Jocker_Boy 发表于 2022-7-5 18:11:34

我是这方面的新手。昨天我做了更多的搜索，但我不断出错。

我有多重图形和多重块做，直到星期六，这个Lisp程序将是我的救赎。

有人能帮忙吗？

谢谢

页: 1 [2]

乐筑天下's Archiver