vb\块\选择集

gb

怎样用vba实现以下内容：
1、在屏幕上选择一个块，得到块名
2、将所有同名块加入选择集
另一的问题：在电子表格excel中怎样定义块
谢谢

mccad

Sub SelBlkSet()
    Dim Blk As AcadBlockReference
    Dim Ent As AcadEntity
    Dim Pnt As Variant
    Dim SelBlk As Boolean
    Dim BlkName As String
   
    On Error Resume Next
   
    '选择对象并判断所选对象是否为图块
    SelBlk = True
    While SelBlk
    ThisDrawing.Utility.GetEntity Ent, Pnt, "选择图块"
    If Ent.ObjectName = "AcDbBlockReference" Then
       Set Blk = Ent
        BlkName = Blk.Name
        SelBlk = False
    End If
    Wend
   
    '创建空白选择集
    Dim BlkSet As AcadSelectionSet
    Set BlkSet = CreateSelectionSet
   
    '建立选择集过滤器
    Dim TypeArray As Variant
    Dim DateArray As Variant
    BuildFilter TypeArray, DateArray, 100, "AcDbBlockReference", 2, BlkName
   
    '过滤出所要选择的图块
    BlkSet.Select acSelectionSetAll, , , TypeArray, DateArray
   
    '显示选定的图块名称及数量
    Debug.Print "选定的图块名称为“" & BlkName & "”,数量为" & BlkSet.Count
   
End Sub

'创建空间选择集的函数
Public Function CreateSelectionSet(Optional ssName As String = "ss") As AcadSelectionSet

    Dim ss As AcadSelectionSet
   
    On Error Resume Next
    Set ss = ThisDrawing.SelectionSets(ssName)
    If Err Then Set ss = ThisDrawing.SelectionSets.Add(ssName)
    ss.Clear
    Set CreateSelectionSet = ss

End Function

'创建过滤器的函数
Public Sub BuildFilter(TypeArray, dataArray, ParamArray gCodes())
    Dim fType() As Integer, fData()
    Dim index As Long, i As Long
   
    index = LBound(gCodes) - 1
        
    For i = LBound(gCodes) To UBound(gCodes) Step 2
        index = index + 1
        ReDim Preserve fType(0 To index)
        ReDim Preserve fData(0 To index)
        fType(index) = CInt(gCodes(i))
        fData(index) = gCodes(i + 1)
    Next
    TypeArray = fType: dataArray = fData
End Sub

而对于在电子表格中定义块，道理和在ACAD的VBA中一样

gb

代码如下
    Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom,   SortMethod _
        :=xlPinYin

mccad

如：
Columns("F:F").Select

gb

请帮忙测试一下(cad vba)
  '排序
  Range("A2").Sort _
      key1:=Columns("A"), _
      Header:=xlGuess
    Set currentcell = Range("a2")
   '汇总
    Do While Not IsEmpty(currentcell)
        Set nextCell = currentcell.Offset(1, 0)
        If nextCell.Value = currentcell.Value Then
            Set TCell = currentcell.Offset(1, 3)
            TCell.Value = TCell.Value + currentcell.Offset(0, 3).Value
            currentcell.EntireRow.Delete
            
        End If
        Set currentcell = nextCell
    Loop

mccad

Dim CurrentCell As Range
Dim NextCell As Range
Dim TCell As Range

从你程序的汇总情况来看，可能要将TCell.Value改为1就行
TCell.Value = 1 + CurrentCell.Offset(0, 3).Value

gb

在excel下通过，在cad下不行（vba）

mccad

Sub ExcelSortAndGather()

On Error Resume Next
   
    ' 连接到Excel应用程序
    Dim ExcelApp As Excel.Application
    Set ExcelApp = GetObject _
                  (, "Excel.Application")
    If Err Then
        Err.Clear
        Set ExcelApp = CreateObject _
                  ("Excel.Application.")
        If Err Then
            MsgBox Err.Description
            Exit Sub
        End If
    End If
   
    ' 连接到Excel的活动工作表
    Dim ExcelBook As Workbook
    Set ExcelBook = ExcelApp.ActiveWorkbook
    Dim ExcelSheet As Worksheet
    Set ExcelSheet = ExcelApp.ActiveSheet

'排序
Dim CurrentCell As Range
Dim NextCell As Range
Dim TCell As Range

'你的Range,Columns都没有指定从属的对象，
'因为在ACAD中不能象Excel一样不指定
With ExcelSheet
    .Range("A2").Sort _
      key1:=.Columns("A"), _
      Header:=xlGuess
    Set CurrentCell = .Range("a2")
   '汇总
    Do While Not IsEmpty(CurrentCell)
        Set NextCell = CurrentCell.Offset(1, 0)
        If NextCell.Value = CurrentCell.Value Then
            Set TCell = CurrentCell.Offset(1, 3)
            TCell.Value = 1 + CurrentCell.Offset(0, 3).Value
            CurrentCell.EntireRow.Delete
            
        End If
        Set CurrentCell = NextCell
    Loop
End With
End Sub

gb

HQ_2003

我看了很多关于Cad与Excel相互连接的问题，大部分都是讲在Cad中提取块属性到Excel中，或者是把Excel表格提取到Cad中。
  
  我现在想做的就是手动选择Cad中的材料表内容动态或是按一定路径输出到Excel中或者是文本文件中，而且输出的内容能按一定规则排序。
   希望斑竹或其它高手能给出一些示例代码，谢了。