Imports Microsoft.Office.Interop Imports System.Data.SqlClient Imports System.Data.OleDb Imports System.IO Imports Autodesk.AutoCAD.Interop Imports System Imports System.Runtime.InteropServices Imports Excel = Microsoft.Office.Interop.Excel Sub Import() xlsApp = New Excel.Application xlsApp.Visible = True xlsWB = xlsApp.Workbooks.Open(Frm_Main.LblFile1.Text) xlsSheetTwo = xlsWB.Worksheets("Import") Dim a As Integer a = 5 Dim dirInfo As New DirectoryInfo(Frm_Main.LblFolder1.Text) Dim fileInfo As FileInfo For Each fileInfo In dirInfo.GetFiles("*.dwg") 'dwg for Autocad xlsSheetTwo.Cells(a, 1) = fileInfo.Name a = a + 1 Next Dim AcadApp As AutoCAD.AcadApplication Dim SelSet As AutoCAD.AcadSelectionSet Dim Entity As AutoCAD.AcadEntity Dim BlocRef As AutoCAD.AcadBlockReference Dim filterType As Object Dim filterData As Object Dim p1(0 To 2) As Double Dim p2(0 To 2) As Double Dim grpCode(0 To 2) As Integer Dim grpValue(0 To 2) As String Dim i, Row, j, Column As Integer Dim Attributes As Object Dim ColumnExist As Boolean xlsSheetTwo.Select() ' Delete Excel records xlsSheetTwo.Range("B5:TZ65536").ClearContents() xlsApp.Application.Visible = True ' AutoCAD Connection On Error Resume Next AcadApp = GetObject(, "AutoCAD.Application") On Error GoTo 0 If AcadApp Is Nothing Then AcadApp = New AutoCAD.AcadApplication End If AcadApp.Visible = True 'Open the DWG Dim Opened As Boolean Opened = False Dim k As Integer k = 5 Row = 5 For k = 5 To xlsSheetTwo.Range("A65536").End(Excel.XlDirection.xlUp).Row AcadApp.Documents.Open(Frm_Main.LblFolder1.Text & "" & xlsSheetTwo.Cells(k, 1).Text) On Error Resume Next SelSet = AcadApp.ActiveDocument.SelectionSets.Add("SELSET") If ErrorToString() <> 0 Then SelSet = AcadApp.ActiveDocument.SelectionSets.Item("SELSET") SelSet.Clear() End If 'Creation of Filter grpCode(0) = 8 ' Layer grpCode(1) = 2 ' Block Name grpCode(2) = 410 ' Layout filtertype = grpCode ' Filter on Layout Name grpValue(2) = xlsSheetTwo.Cells(1, 3).text ' Filter on BLOCK Name grpValue(1) = xlsSheetTwo.Cells(2, 3).text ' Filter on LAYER Name grpValue(0) = xlsSheetTwo.Cells(3, 3).text filterData = grpValue SelSet.Select(AutoCAD.AcSelect.acSelectionSetAll, , , filterType, filterData) ' Go throuhg Selection For i = 0 To SelSet.Count - 1 Entity = SelSet.Item(i) If Entity.ObjectName = "AcDbBlockReference" Then BlocRef = Entity If BlocRef.HasAttributes Then Attributes = BlocRef.GetAttributes For j = LBound(Attributes) To UBound(Attributes) Column = 3 ColumnExist = False While Not String.IsNullOrEmpty(xlsSheetTwo.Cells(4, Column)) If xlsSheetTwo.Cells(4, Column).Text = Attributes(j).TagString Then xlsSheetTwo.Cells(Row, Column).Value = Attributes(j).TextString ColumnExist = True End If Column = Column + 1 ' On passe à la colonne suivante End While If Not ColumnExist Then xlsSheetTwo.Cells(4, Column).Value = Attributes(j).TagString xlsSheetTwo.Cells(Row, Column).Value = Attributes(j).TextString End If Next ' Next Attribut End If End If Next AcadApp.ActiveDocument.Close() Row = Row + 1 'Next Line Next k AcadApp.Quit() MsgBox("Attributs of " & xlsSheetTwo.Cells(2, 1).Text & " have been retreived.") End Sub End Module
置顶卡
