Hi here attached a new version of procedure. execution time shall be little bit lower, because it have been made a selection set of all text, and only that inside TAG layer shall be selected for check of modification compared with excel file.
In this case we will have 340 items to replace and application need few minutes (with other tasks running, and I7 processor).
Again let me know.
Code:
Global MaxRowAdd As Variant
Global GetExcelAppl As Object
Global MySelection As AcadSelectionSet
Global ExRow
Global ExCol
Global WRKBS As Object
Global WKRS As Object
Sub RepText_From_Excel()
Dim GetExcelAppl As Object
Dim DWGSearchText As Object
'Open ("C:\Users\Utente\Downloads\Compressed\New folder\TagList.txt") For Output As #1
Count = 0
Set GetExcelAppl = GetObject(, "Excel.Application")
Set WRKBS = GetExcelAppl.ActiveWorkbook
Set WKRS = GetExcelAppl.ActiveSheet
GetExcelAppl.Visible = True
GetExcelAppl.Application.ScreenUpdating = False
MaxRow
ExRow = 2
ExCol = 1
SelectionSetFilterText
For Each DWGSearchText In MySelection ' ThisDrawing.ModelSpace ' Per ogni entità nello spazio modello
If DWGSearchText.Layer = "TAG" Then
If TypeOf DWGSearchText Is AcadText Then
Debug.Print DWGSearchText.TextString
'Print #1, DWGSearchText.TextString
For Each Cella In WKRS.CELLS.Range(MaxRowAdd)
If StrComp(DWGSearchText.TextString, Cella.Value, vbTextCompare) = 0 Then
MyRow = Cella.row
MyCol = Cella.column
DWGSearchText.TextString = WKRS.CELLS(MyRow, MyCol + 1).Value
Count = Count + 1
End If
Next
End If
End If
Next
ThisDrawing.Regen acAllViewports
MsgBox "Replaced " & Count & " Text Items"
End Sub
Sub MaxRow()
ExRow = 1
ExCol = 1
Do
ExRow = ExRow + 1
Loop Until WKRS.CELLS(ExRow, ExCol) = ""
MaxRowAdd = "A2:" & "A" & ExRow - 1
End Sub
Sub SelectionSetFilterText()
Dim filterType(1) As Integer
Dim filterData(1) As Variant
On Error Resume Next
On Error GoTo 0
For Each MySelection In ThisDrawing.SelectionSets
If MySelection.Name = "PP1" Then MySelection.Delete
Next MySelection
Set MySelection = ThisDrawing.SelectionSets.Add("PP1")
filterType(0) = 0
filterType(1) = 8
filterData(0) = "TEXT,MTEXT"
filterData(1) = "TAG"
MySelection.Select acSelectionSetAll, , , filterType, filterData
End Sub
AugiTextReplaceProject.dvb