[求助]：请问如何将一选择集中的内容定义成块

chuan · 发表于 2003-5-15 16:07:58

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

一选择集中有许多图形，现要将他们定义成一个块，该如何操作（用VBA命令），请指点，谢谢。

前生 · 发表于 2003-5-15 17:55:32

我有一个问题是用Vlisp如何调用 wblock的函数
(vla-wblock "c:/ls.dwg" 选择集)
选择集用什么方法的呢?
(ssget)得到的不是object的集合,程序会报错

efan2000 · 发表于 2003-5-15 19:03:52

下面是一个例子，首先要了解块和选择集的用法，还有选择集中过滤机制的使用，接着是CopyObjects的用法，第一个参数是实体的数组集合，第二个参数是存放实体的对象，可以是块或者另一个文档对象。

[FONT=courier new]
Option Explicit
'本例创建一个块并向块定义中添加选中的实体。
Sub Test()
' 定义块
Dim blockObj As AcadBlock
Dim insertionPnt(0 To 2) As Double
insertionPnt(0) = 0
insertionPnt(1) = 0
insertionPnt(2) = 0
Set blockObj = ThisDrawing.Blocks.Add _
(insertionPnt, "CircleBlock")
' 创建新的选择集
Dim sstext As AcadSelectionSet
Dim FilterType(0) As Integer
Dim FilterData(0) As Variant
Set sstext = ThisDrawing.SelectionSets.Add("SS2")
FilterType(0) = 0
FilterData(0) = "Circle"
' 提示用户选择对象，并将其添加到选择集中。要完成选择，请按回车键。
sstext.SelectOnScreen FilterType, FilterData
' 将选择集中的对象存入数组
Dim Entarr() As AcadEntity
ReDim Entarr(0 To sstext.Count - 1)
Dim i As Integer
For i = 0 To sstext.Count - 1
Set Entarr(i) = sstext.Item(i)
Next
' 将数组中的对象拷贝到块中
ThisDrawing.CopyObjects Entarr, blockObj
End Sub
[/FONT]

[FONT=courier new] 
Option Explicit 
 
'本例创建一个块并向块定义中添加选中的实体。 
 
Sub Test() 
    ' 定义块 
    Dim blockObj As AcadBlock 
    Dim insertionPnt(0 To 2) As Double 
    insertionPnt(0) = 0 
    insertionPnt(1) = 0 
    insertionPnt(2) = 0 
    Set blockObj = ThisDrawing.Blocks.Add _ 
                     (insertionPnt, "CircleBlock") 
 
    ' 创建新的选择集 
    Dim sstext As AcadSelectionSet 
    Dim FilterType(0) As Integer 
    Dim FilterData(0) As Variant 
    Set sstext = ThisDrawing.SelectionSets.Add("SS2") 
    FilterType(0) = 0 
    FilterData(0) = "Circle" 
 
 
    ' 提示用户选择对象，并将其添加到选择集中。要完成选择，请按回车键。 
    sstext.SelectOnScreen FilterType, FilterData 
    
    ' 将选择集中的对象存入数组 
    Dim Entarr() As AcadEntity 
    ReDim Entarr(0 To sstext.Count - 1) 
    Dim i As Integer 
    For i = 0 To sstext.Count - 1 
        Set Entarr(i) = sstext.Item(i) 
    Next 
    
    ' 将数组中的对象拷贝到块中 
    ThisDrawing.CopyObjects Entarr, blockObj 
End Sub 
  [/FONT]

efan2000 · 发表于 2003-5-15 19:09:48

最初由前生发布
[B]我有一个问题是用Vlisp如何调用 wblock的函数
(vla-wblock "c:/ls.dwg" 选择集)
选择集用什么方法的呢?
(ssget)得到的不是object的集合,程序会报错 [/B]

这个是VBA的用法，在VLisp中具体怎么用也不太清楚。vla-wblock这个函数在VL中应该没有吧。

efan2000 · 发表于 2003-5-15 19:15:02

用CopyObjects仅是在打开的文档中操作，而如果要将选中的对象保存到外部文件，那么就要使用WBlock方法了。

[FONT=courier new]
Option Explicit
'本例创建一个选择集并将选中的实体输出到一个外部文件。
Sub Test()
' 创建新的选择集
Dim sstext As AcadSelectionSet
Dim FilterType(0) As Integer
Dim FilterData(0) As Variant
Set sstext = ThisDrawing.SelectionSets.Add("SS2")
FilterType(0) = 0
FilterData(0) = "Circle"
' 提示用户选择对象，并将其添加到选择集中。要完成选择，请按回车键。
sstext.SelectOnScreen FilterType, FilterData
' 将选择集中的对象输出到外部文件
ThisDrawing.Wblock "C:\AutoCAD\WBlock_example.dwg", sstext
End Sub
[/FONT]

lijiao · 发表于 2003-5-16 08:42:04

[FONT=courier new]
(defun cs_make_blk (cs_blkname cs_ss / cs_i cs_sslist cs_blk)
(cond
((and (= (type cs_blkname) 'STR)
(= (type cs_ss) 'PICKSET)
(> (sslength cs_ss) 0)
)
(setq cs_i 0 cs_sslist '())
(repeat (sslength cs_ss)
(setq cs_sslist (cons (vlax-ename->vla-object (ssname cs_ss cs_i)) cs_sslist))
(setq cs_i (1+ cs_i))
)
(setq cs_ss (vlax-make-safearray vlax-vbObject (cons 0 (1- (length cs_sslist)))))
(setq cs_ss (vlax-safearray-fill cs_ss cs_sslist))
(if (setq cs_blk (cadblk cs_blkname))
(vlax-for myent cs_blk (vla-delete myent))
(setq cs_blk (vla-add (vla-get-blocks (caddoc)) (vlax-3D-point '(0 0 0)) cs_blkname))
)
(vla-CopyObjects (caddoc) cs_ss cs_blk)
(mapcar 'vla-delete cs_sslist)
(setq cs_blk cs_blk)
)
(t (setq cs_blk nil))
)
)
[/FONT]

[FONT=courier new] 
(defun cs_make_blk (cs_blkname cs_ss / cs_i cs_sslist cs_blk) 
  (cond 
    ((and (= (type cs_blkname) 'STR) 
          (= (type cs_ss) 'PICKSET) 
          (> (sslength cs_ss) 0) 
          ) 
     (setq cs_i 0 cs_sslist '()) 
     (repeat (sslength cs_ss) 
       (setq cs_sslist (cons (vlax-ename->vla-object (ssname cs_ss cs_i)) cs_sslist)) 
       (setq cs_i (1+ cs_i)) 
       ) 
     (setq cs_ss (vlax-make-safearray vlax-vbObject (cons 0 (1- (length cs_sslist))))) 
     (setq cs_ss (vlax-safearray-fill cs_ss cs_sslist)) 
     (if (setq cs_blk (cadblk cs_blkname)) 
       (vlax-for myent cs_blk (vla-delete myent)) 
       (setq cs_blk (vla-add (vla-get-blocks (caddoc)) (vlax-3D-point '(0 0 0)) cs_blkname)) 
       ) 
     (vla-CopyObjects (caddoc) cs_ss cs_blk) 
     (mapcar 'vla-delete cs_sslist) 
     (setq cs_blk cs_blk) 
     ) 
    (t (setq cs_blk nil)) 
    ) 
  ) 
  [/FONT]

cs_blkname.............块名，为字符串。
cs_ss......................LSP选择集。

前生 · 发表于 2003-5-16 09:08:34

cadblk ？谢谢

lijiao · 发表于 2003-5-16 11:58:22

最初由前生发布
[B]cadblk ？谢谢 [/B]

这是我自己编的一个函数：

[FONT=courier new]
(defun CADAPP ( / ) (vlax-get-acad-object))
(defun caddoc ( / ) (vla-get-ActiveDocument (cadapp)))
(defun cadblk (blkname / myblk)
(setq myblk (vl-catch-all-apply 'vla-item (list (vla-get-blocks (caddoc)) blkname)))
(if (vl-catch-all-error-p myblk)
(setq myblk nil)
(setq myblk myblk)
)
)
[/FONT]

luln · 发表于 2003-5-17 11:34:27

就是把选中的所有图形实体以所有实体的最左最下点为基点做成块

[FONT=courier new]
Public Sub Create_Blk()
Dim entss As AcadSelectionSet
Dim i, snum As Integer '当前文档中选择集的个数
Dim existf As Boolean 'existf选择集存在与否的标志
Dim basept As Variant 'basept块的插入基点
Dim blk As AcadBlock
Dim length, width As Double
Dim blkname, blkDir As String 'blkname块名
Dim inpf As Boolean 'inpf为判断是否要重新输入块名的标志
Dim blkcollection() As Object
blkDir = InputBox("请输入保存块的目录", "输入存放块的目录", "d:")
Do
inpf = True
blkname = InputBox("请输入要建立的块的名字", "输入块的名字")
Dim fsox As New FileSystemObject
Set fsox = CreateObject("Scripting.FileSystemObject")
If fsox.FileExists(blkDir & blkname & ".dwg") = True Then
If MsgBox("块" & blkname & "已经存在，请重新输入块的名称", , "警告") = vbOK Then
inpf = False
End If
End If
Loop Until inpf = True
For snum = 0 To ThisDrawing.SelectionSets.Count - 1
If ThisDrawing.SelectionSets.Item(snum).name = "entss" Then
existf = True
Exit For
End If
Next
If existf = True Then
Set entss = ThisDrawing.SelectionSets.Item("entss")
entss.Clear
Else
Set entss = ThisDrawing.SelectionSets.Add("entss")
End If
entss.SelectOnScreen
'建立块blkname
basept = ThisDrawing.Get_minpt(entss) ‘所有实体的最左最下点为基点
Set blk = ThisDrawing.Blocks.Add(basept, blkname)
ReDim blkcollection(0 To entss.Count - 1) As Object
For i = 0 To entss.Count - 1
Set blkcollection(i) = entss.Item(i)
Next
ThisDrawing.CopyObjects blkcollection, blk '把所选的实体做成块
If ThisDrawing.GetVariable("filedia") <> 0 Then
ThisDrawing.SetVariable "filedia", 0
End If
ThisDrawing.SendCommand "-wblock" & vbCr & blkDir & blkname & vbCr & " = " & vbCr
End Sub
[/FONT]

[FONT=courier new] 
Public Sub Create_Blk() 
   Dim entss As AcadSelectionSet 
   Dim i, snum As Integer '当前文档中选择集的个数 
   Dim existf As Boolean 'existf选择集存在与否的标志 
   Dim basept As Variant 'basept块的插入基点 
   Dim blk As AcadBlock 
   Dim length, width As Double 
   Dim blkname, blkDir As String 'blkname块名 
   Dim inpf As Boolean  'inpf为判断是否要重新输入块名的标志 
   Dim blkcollection() As Object 
   blkDir = InputBox("请输入保存块的目录", "输入存放块的目录", "d:") 
   Do 
     inpf = True 
     blkname = InputBox("请输入要建立的块的名字", "输入块的名字") 
     Dim fsox As New FileSystemObject 
     Set fsox = CreateObject("Scripting.FileSystemObject") 
     If fsox.FileExists(blkDir & blkname & ".dwg") = True Then 
       If MsgBox("块" & blkname & "已经存在，请重新输入块的名称", , "警告") = vbOK Then 
       inpf = False 
       End If 
     End If 
   Loop Until inpf = True 
   For snum = 0 To ThisDrawing.SelectionSets.Count - 1 
        If ThisDrawing.SelectionSets.Item(snum).name = "entss" Then 
          existf = True 
    Exit For 
        End If 
    Next 
    If existf = True Then 
        Set entss = ThisDrawing.SelectionSets.Item("entss") 
        entss.Clear 
    Else 
        Set entss = ThisDrawing.SelectionSets.Add("entss") 
    End If 
   entss.SelectOnScreen 
   '建立块blkname 
    basept = ThisDrawing.Get_minpt(entss) ‘所有实体的最左最下点为基点 
    Set blk = ThisDrawing.Blocks.Add(basept, blkname) 
    ReDim blkcollection(0 To entss.Count - 1) As Object 
    For i = 0 To entss.Count - 1 
       Set blkcollection(i) = entss.Item(i) 
    Next 
    
ThisDrawing.CopyObjects blkcollection, blk '把所选的实体做成块 
If ThisDrawing.GetVariable("filedia") <> 0 Then 
  ThisDrawing.SetVariable "filedia", 0 
End If 
 
ThisDrawing.SendCommand "-wblock" & vbCr & blkDir & blkname & vbCr & " = " & vbCr 
 
End Sub 
  [/FONT]

efan2000 · 发表于 2003-5-17 15:18:24

Dim fsox As New FileSystemObject
Set fsox = CreateObject("Scripting.FileSystemObject")
关于这两句的用法，如果第一句用New关键字字义了FileSystemObject对象，那么第二句就没必要编写了。而如果第一句是声明为：Dim fsox As Object，那第二句就是正确的用法，使用后期绑定。而如果第一句是声明为：Dim fsox As FileSystemObject，那么第二句为Set fsox = New FileSystemObject会更好一点，这是前期绑定的用法。

前生 · 发表于 2003-8-25 14:29:46

(defun c:al-wblock ()
(vl-load-com)
(setq thisdrawing (vla-get-activedocument
(vlax-get-acad-object)))
(setq ssets (vla-get-selectionsets thisdrawing))
(if (vl-catch-all-error-p
(vl-catch-all-apply 'vla-item (list ssets "$Set")))
(setq newSet (vla-add ssets "$Set"))
(progn
(vla-delete (vla-item ssets "$Set"))
(setq newSet (vla-add ssets "$Set"))
);progn
);if
;select all objects in the drawing
(vla-Select newSet acSelectionSetAll)
(vla-WBlock thisdrawing "c:/test.dwg" newSet)
(princ)
);defun

账号		自动登录	找回密码
密码			立即注册

[求助]：请问如何将一选择集中的内容定义成块

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子

使用CopyObjects方法