Egg's Blog

動作条件として
ブロック名 "*_aTag" 属性文字があること
サンプル図面
_________________________________________

Sub Example_AttExcelOut()

' Start Excel
On Error Resume Next
  
Dim Excel As Object
Dim exBook As Workbook
Dim exSheet As Worksheet

Set Excel = GetObject(, "Excel.Application")
  
    If Err <> 0 Then
        Err.Clear
        Set Excel = CreateObject("Excel.Application")
          
        If Err <> 0 Then
            MsgBox "Could not load Excel.", vbExclamation
            End
        End If
    End If
  
    On Error GoTo 0
  
    Excel.Visible = True
  
    Set exBook = Excel.Workbooks.Add
    Set exSheet = exBook.Sheets("Sheet1")

'図形選択 /////////////////////////////////////////////////
    Dim SSet As AcadSelectionSet
    Dim GroupCode(1) As Integer
    Dim DataValue(1) As Variant
    Dim acBlObj As AcadBlockReference 'ブロック図形
On Error Resume Next
 If Not IsNull(ThisDrawing.SelectionSets.Item("SS1")) Then
    Set SSet = ThisDrawing.SelectionSets.Item("SS1")
    SSet.Delete
 End If
 
    Set SSet = ThisDrawing.SelectionSets.Add("SS1")
    '(2 . "*_aTag") ブロック名 , (0 . "INSERT") ブロック図形
    GroupCode(0) = 2
    DataValue(0) = "*_aTag"
    GroupCode(1) = 0
    DataValue(1) = "INSERT"
 
   SSet.Select acSelectionSetAll, , , GroupCode, DataValue
 
Dim ssCount As Integer
    ssCount = SSet.Count
  
    If ssCount = 0 Then
        MsgBox "書出すBlockがありません"
        Exit Sub 'プロシージャから抜ける
    End If
  
Dim attArray As Variant '属性のリスト
Dim blockHandle As String 'ブロック図形のハンドル番号
                          'Excelからアクセスする時に利用する番号
                          '（書出しのみであれば不要）
Dim rowNum As Integer
Dim colNum As Integer
    rowNum = 1 'Excel行番号
    colNum = 1 'Excel列番号

'選択したブロックの繰返し処理 +++++++++++++++++++++++++
For Each acBlObj In SSet
    If acBlObj.HasAttributes Then '属性を持っていたら
        attArray = acBlObj.GetAttributes '属性の取得
        blockHandle = acBlObj.Handle
      
        With exSheet.Cells(rowNum, colNum)
            .NumberFormatLocal = "@" '文字として書込み
            .Value = blockHandle
        End With
      
       For colNum = LBound(attArray) To UBound(attArray)
          exSheet.Cells(rowNum, colNum + 1).Value = attArray(colNum - 1).TextString
        Next
      
        rowNum = rowNum + 1
        colNum = 1
      
    End If '.HasAtt
Next
'++++++++++++++++++++++++++++++++++++++++++++++++++++++

'Excelファイルの保存
    Dim docName As String
    Dim acadFname As String
    Dim exFname As String
    Dim exSfname As String
  
    docName = ThisDrawing.FullName
        If docName = "" Then
            acadFname = ThisDrawing.Name
        Else
            acadFname = docName
        End If
  
    exFname = Left(acadFname, (Len(acadFname) - 4))

    Do ' wait until the user supplies a file name or cancels
        exSfname = Excel.GetSaveAsFilename(exFname, "Microsoft Excel Worksheet(*.xls), *.xls")
    Loop Until exSfname <> ""
  
    If exSfname <> "False" Then ' if they cancel, the file name is "False"
        exBook.SaveAs FileName:=exSfname
        'Error  1004-------------------------------------------------
        If Err.Number = 1004 Then
            Err.Clear
        End If
    End If
  
    Set exSheet = Nothing ' release memory
    Set exBook = Nothing
    Set Excel = Nothing

End Sub