반응형
AutoCAD의 dwg 파일을 검색해서 파일내의 Text만 추출하는 매크로 입니다.
AutoCAD LT 버전은 매크로를 지원하지 않기 때문에 사용할 수 없습니다.
1. excel을 실행시킨다.
2. 폴더를 선택한다.
-> 폴더내의 dwg 파일을 검색해서 파일내의 Text를 Excel 파일로 옮긴다.
#Macro Code
Dim acadApp As Object
Dim acadDoc As Object
Dim acadCircle As Object
Dim LastRow As Long
Dim i As Long
Dim Point(0 To 2) As Double
'Check if AutoCAD application is open.
On Error Resume Next
Set acadApp = GetObject(, "AutoCAD.Application")
'If AutoCAD is not opened create a new instance and make it visible.
If acadApp Is Nothing Then
Set acadApp = CreateObject("AutoCAD.Application")
acadApp.Visible = False
End If
'Check (again) if there is an AutoCAD object.
If acadApp Is Nothing Then
MsgBox "Sorry, it was impossible to start AutoCAD!", vbCritical, "AutoCAD Error"
error = 1
Exit Sub
End If
On Error GoTo 0
AngBracDwg = filename
acadApp.Documents.Open (AngBracDwg)
'////////////////////////////////////////////////////////
'Dim myText As AcadText
For i = 0 To acadApp.Documents.Count - 1
Set doc = acadApp.Documents(i)
Set mspace = doc.ModelSpace
RowNum = 1
Dim Header As Boolean
Header = False
For Each elem In mspace
DoEvents
With elem
If StrComp(.EntityName, "AcDbBlockReference", 1) = 0 Then
If .HasAttributes Then
Array1 = .GetAttributes
Sheets(1).Cells(index, 3) = i 'Document Number
For Count = LBound(Array1) To UBound(Array1)
If Header = False Then
If StrComp(Array1(Count).EntityName, "AcDbAttribute", 1) = 0 Then
Sheets(1).Cells(index, Count + 4).Value = Array1(Count).TagString
End If
End If
Next Count
index = index + 1
For Count = LBound(Array1) To UBound(Array1)
Sheets(1).Cells(index, Count + 4).Value = Array1(Count).TextString
Next Count
index = index + 1
Header = True
End If
ElseIf StrComp(.EntityName, "AcDbMText", 1) = 0 Then
Sheets(1).Cells(index, 3) = i
Sheets(1).Cells(index, 4) = .TextString
index = index + 1
ElseIf StrComp(.EntityName, "AcDbText", 1) = 0 Then
Sheets(1).Cells(index, 3) = i
Sheets(1).Cells(index, 4) = .TextString
index = index + 1
End If
End With
Next elem
Next i
Set acad = Nothing
acadApp.Documents.Close
'Release the objects.
Set acadCircle = Nothing
Set acadDoc = Nothing
반응형
'Office' 카테고리의 다른 글
| [Excel] 셀 TEXT 합치기 (0) | 2023.05.02 |
|---|---|
| [Excel] Registry 읽고 쓰고 삭제하기 (0) | 2023.05.02 |
| [Excel]엑셀 연결 끊기가 안될때 해결방법 (0) | 2023.05.02 |
| [Excel] UART HEX 통신 VBA Serial 통신 (0) | 2023.05.02 |
| [Excel] vba cell 현재 위치 알아내기 (0) | 2023.05.02 |
