vb\块\选择集

mccad · 发表于 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中一样

mccad · 发表于 2003-3-11 18:53:00

代码如下
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

HQ_2003 · 发表于 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

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

mccad · 发表于 2003-3-12 20:10:00

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

HQ_2003 · 发表于 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

mccad · 发表于 2003-5-31 19:19:00

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

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

vb\块\选择集

发表回复

精选推荐