thankyou bác Phan Tu Huong rất nhiều. bác vất cả vì anh em quá. đọc code của bác em đã chạy thử rất tốt nhưng các đối tượng chỉ xuất hiện cho biết vậy chứ có làm gì được các em nó đâu? với lại bọn chúng xuất hiện từ dưới lên nên cũng khó kiểm soát, bác quá bội làm cho chúng xuất hiện theo thứ tự từ trái qua phải,từ trên xuống dưới và có kiểm soát(ví dụ như chạy thẳng qua Excel và put vào từng ô tương ứng thì tuyệt cú mèo) Hay bác nghiên cứu và kết hợp với đoạn code này
Sub Ch12_Extract()
Dim Excel As Excel.Application
Dim ExcelSheet As Object
Dim ExcelWorkbook As Object
Dim RowNum As Integer
Dim Header As Boolean
Dim elem As AcadEntity
Dim Array1 As Variant
Dim Count As Integer
' Launch Excel.
Set Excel = New Excel.Application
' Create a new workbook and find the active sheet.
Set ExcelWorkbook = Excel.Workbooks.Add
Set ExcelSheet = Excel.ActiveSheet
ExcelWorkbook.SaveAs "Attribute.xls"
RowNum = 1
Header = False
' Iterate through model space finding
' all block references.
For Each elem In ThisDrawing.ModelSpace
With elem
' When a block reference has been found,
' check it for attributes
If StrComp(.EntityName, "AcDbBlockReference", 1) _
= 0 Then
If .HasAttributes Then
' Get the attributes
Array1 = .GetAttributes
' Copy the Tagstrings for the
' Attributes into Excel
For Count = LBound(Array1) To UBound(Array1)
If Header = False Then
If StrComp(Array1(Count).EntityName, _
"AcDbAttribute", 1) = 0 Then
ExcelSheet.Cells(RowNum, _
Count + 1).value = _
Array1(Count).TagString
End If
End If
Next Count
RowNum = RowNum + 1
For Count = LBound(Array1) To UBound(Array1)
ExcelSheet.Cells(RowNum, Count + 1).value _
= Array1(Count).textString
Next Count
Header = True
End If
End If
End With
Next elem
Excel.Application.Quit
End Sub
Đoạn này em có quét được nhưng trả kết quả sang Excel toàn kí tự từ 1 đến 19 trong một cột.
Nếu được thì cảm ơn bác nhiều lắm vì việc tách vật tư từ bản vẽ ra của bọn em rất nhiều.
