vb\块\选择集

gb 发表于 2003-3-10 13:14:00

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

mccad 发表于 2003-3-10 19:51:00

可以使用以下程序完成

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 发表于 2003-3-11 18:53:00

怎样让EXCEL数据排序，我的代码没反应

本帖最后由作者于 2003-3-11 18:53:27 编辑

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

mccad 发表于 2003-3-11 19:21:00

有没有先选定对象

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

gb 发表于 2003-3-12 08:13:00

有选择

请帮忙测试一下(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 发表于 2003-3-12 19:26:00

排序段CurrentCell没有定义为Range，而汇总段也是一样道理，但不知你要汇总些什么

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

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

gb 发表于 2003-3-12 20:10:00

将块的属性导出按序号分类汇总

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

mccad 发表于 2003-3-13 12:22:00

以下程序能运行并能得到你所要的结果

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 发表于 2003-3-13 12:31:00

问题解决，多谢版主

HQ_2003 发表于 2003-5-31 19:19:00

cad与excel

我看了很多关于Cad与Excel相互连接的问题，大部分都是讲在Cad中提取块属性到Excel中，或者是把Excel表格提取到Cad中。

我现在想做的就是手动选择Cad中的材料表内容动态或是按一定路径输出到Excel中或者是文本文件中，而且输出的内容能按一定规则排序。
希望斑竹或其它高手能给出一些示例代码，谢了。

页: [1] 2

明经CAD社区's Archiver