Hope my translations are right.
Option Explicit
Private ExcelApp As Excel.Application
Private Sub AcadDocument_EndSave(ByVal FileName As String)
Debug.Print FileName
Stop 'Put this in here so you can see how the code works
'Just press [F8] to step to the next line
DoExcelUpdate Replace(FileName, ".dwg", ".xlsx")
End Sub
Private Sub DoExcelUpdate(sFileName As String)
Dim objWorkBook As Workbook
Dim objSheet As Worksheet
Dim objUsedRange As Range
Dim lngRow As Long
Dim objSelSet As AcadSelectionSet
Dim intType(0) As Integer
Dim varData(0) As Variant
Dim objEnty As AcadEntity
Dim objBlkRef As AcadBlockReference
Dim varInsPnt As Variant
Dim strHandle As String
Dim lngCnt As Long
On Error GoTo Err_Control
'Open Excel
If ConnectToExcel = False Then
MsgBox "Ei voitu yhdistää Excel!" & vbCrLf & "Poistuminen nyt!"
End If
If FileExist(sFileName) = True Then
'Set objSheet
Set objWorkBook = ExcelApp.Workbooks.Open(sFileName)
Set objSheet = objWorkBook.Worksheets(1)
Set objUsedRange = objSheet.UsedRange
'Clear Excel Spread Sheet
objUsedRange.ClearContents
Else
'Create Sheet and return objSheet
Set objWorkBook = ExcelApp.Workbooks.Add
objWorkBook.SaveAs sFileName
Set objSheet = objWorkBook.Worksheets(1)
End If
'Set Column Headers
'Not sure of the Translation
objSheet.Cells(1, 1) = "blokkia nimi" 'lohkonimi Block Name
objSheet.Cells(1, 2) = "kahva" 'Handle
objSheet.Cells(1, 3) = "X"
objSheet.Cells(1, 4) = "Y"
objSheet.Cells(1, 5) = "Z"
lngRow = 2 'This is the next row after the header row
'Set the selection set
Set objSelSet = ThisDrawing.PickfirstSelectionSet
'Create a filter that gets only Block References
intType(0) = 0: varData(0) = "INSERT"
'Fill the Selection Set
objSelSet.Select Mode:=acSelectionSetAll, FilterType:=intType, FilterData:=varData
'Now step through the Selection Set for each Entity and apply the following code:
For Each objEnty In objSelSet 'Kinda like this
'Set objEnty = objSelSet.items(lngCnt)
If TypeOf objEnty Is AcadBlockReference Then 'It is a Block Ref
Set objBlkRef = objEnty 'Set it so the drop down works after typing a "."
varInsPnt = objBlkRef.InsertionPoint 'Get the insertion point
strHandle = objBlkRef.Handle 'Get the Handle
'If you want Attribute values you will need to do a Function that returns the Att Values
Debug.Print objBlkRef.Name & " Handle: " & strHandle & " Insertion Point: " & CStr(varInsPnt(0)) & ", " & CStr(varInsPnt(1)) & ", " & CStr(varInsPnt(2))
'Put in excel here
objSheet.Cells(lngRow, 1) = objBlkRef.Name
objSheet.Cells(lngRow, 2) = strHandle
objSheet.Cells(lngRow, 3) = CStr(varInsPnt(0))
objSheet.Cells(lngRow, 4) = CStr(varInsPnt(1))
objSheet.Cells(lngRow, 5) = CStr(varInsPnt(2))
'Row adder
lngRow = lngRow + 1
End If
Next 'Next entity in selection set
'Save sheet
objWorkBook.Save
objWorkBook.Close
Set ExcelApp = Nothing
Exit_Here:
Exit Sub
Err_Control:
Select Case Err.Number
Case Else
Debug.Print Err.Number & ": " & Err.Description
Resume Exit_Here
End Select
End Sub
Public Function FileExist(strFile As String) As Boolean
'ei tiedosto olemassa?
If Dir(strFile, vbNormal Or vbReadOnly Or vbHidden Or vbSystem Or vbArchive) = "" Then
FileExist = False
Else
FileExist = True
End If
End Function