Hi guys,
switching to selections sets dropped the time from ~20sec/dwg to ~3sec/dwg!
Here's the old code:
Code:
Sub RecuperaTesti()
Dim FileSystem As Object
Dim SubFolder
Dim SubSubFolder
Dim currentPour As String
Dim modelfile As String
Dim acad As AcadApplication
Dim AcadDbx As Object
Dim AcadObj As AcadObject
Dim AcadML As AcadMLeader
Dim AcadTxt As AcadText
Dim AcadMTxt As AcadMText
Dim textListWS As Worksheet
Dim i As Long
Dim k As Long
Dim acadRunning As Boolean
Dim temp
Dim alreadyProcessedRange As Range
Dim lastProcessedCell As Range
Dim foundCell As Range
Application.DisplayStatusBar = True
Application.StatusBar = "Opening Autocad..."
Set acad = Nothing
On Error Resume Next
Set acad = GetObject(, "AutoCAD.Application.18")
If Err <> 0 Then
Set acad = CreateObject("AutoCAD.Application.18")
acad.Visible = False
acadRunning = False
Else
acadRunning = True
End If
On Error GoTo 0 'Error_Control
Set textListWS = ActiveWorkbook.Sheets("TextsList")
Set FileSystem = CreateObject("Scripting.FileSystemObject")
k = 2 'indice per segnare i pour non aperti
' necessita AxBDLib e Autocad con VBA abilitato
Set AcadDbx = acad.GetInterfaceObject("ObjectDBX.AxDbDocument.18")
Set lastProcessedCell = textListWS.Range("A" & textListWS.Rows.Count).End(xlUp)
Set alreadyProcessedRange = textListWS.Range("A2:" & lastProcessedCell.Address)
i = lastProcessedCell.Row + 1
For Each SubFolder In FileSystem.GetFolder(Application.ActiveWorkbook.Path).SubFolders
If SubFolder.Name <> "Xref" And SubFolder.Name <> "Xstamps" And SubFolder.Name <> "Publish" And SubFolder.Name <> "@ Superseded" And SubFolder.Name <> "0000_CM" And SubFolder.Name <> "1111_AR" Then
For Each SubSubFolder In SubFolder.SubFolders
currentPour = SubSubFolder.Name
modelfile = SubSubFolder.Path & "\" & "MDL_A-" & currentPour & "-CV-D50-001.dwg"
If Dir(modelfile) <> "" Then
Set foundCell = alreadyProcessedRange.Find(What:=currentPour, after:=lastProcessedCell)
If foundCell Is Nothing Then
' Open a drawing in ObjectDbx
On Error Resume Next
AcadDbx.Open (modelfile)
If Err.Number = 0 And AcadDbx.Name <> "" Then
On Error GoTo 0
Application.StatusBar = "Processing " & currentPour & "..."
For Each AcadObj In AcadDbx.ModelSpace
testo = ""
If TypeOf AcadObj Is AcadText Then
Set AcadTxt = AcadObj
......
ElseIf TypeOf AcadObj Is AcadMText Then
Set AcadMTxt = AcadObj
......
End If
ElseIf TypeOf AcadObj Is AcadMLeader Then
Set AcadML = AcadObj
.....
End If
Next AcadObj
' Clean up Variables
Set AcadObj = Nothing
Set AcadTxt = Nothing
Set AcadMTxt = Nothing
Set AcadML = Nothing
End If
End If
End If
On Error GoTo 0
Next SubSubFolder
End If
Next SubFolder
Application.StatusBar = "Closing Autocad..."
Set AcadDbx = Nothing
If acadRunning = False Then acad.Quit
Set acad = Nothing
Application.StatusBar = "Done."
Application.StatusBar = False
End Sub
and this is the modified part of the code (obviously I switched from axdblib to acaddocument):
Code:
If SelectObjectsOnLayer(acadDoc, acadSelection, "TEXT", "*") > 0 Then
For Each AcadTxt In acadSelection
....
Next AcadTxt
End If
If SelectObjectsOnLayer(acadDoc, acadSelection, "MTEXT", "*") > 0 Then
For Each AcadMTxt In acadSelection
....
Next AcadMTxt
End If
If SelectObjectsOnLayer(acadDoc, acadSelection, "MULTILEADER", "*") > 0 Then
For Each AcadML In acadSelection
.....
Next AcadML
End If
Using the SelectObjectsOnLayer function I found on the autodesk forum that I posted earlier.
I'm no .NET expert (my VB experience dates back to VB6 age), in fact I always tried to avoid everything microsoft after I discovered open source software :P
Obviously now I have to stick with company standards and tools, so I'll try to learn .NET to help speedup the workflow!