Needed: VBA code to change one line of text in 450 files

[michael407]

Needed: VBA source code what would open, search for specifiic text in either MTEXT or DTEXT format and replace it with new text, in 450 files.

 

The text may also reside with in a simple block (not one with attributes) in 200 drawings.

 

I am currently running AutoCAD 2004 on Windows 6.002

[fixo]

Needed: VBA source code what would open, search for specifiic text in either MTEXT or DTEXT format and replace it with new text, in 450 files.

 

The text may also reside with in a simple block (not one with attributes) in 200 drawings.

Here is not mine, so I don't tested it at all

Give this a try

Option Explicit

'' Requires:
'' AutoCAD/ObjectDBX Common 17.0 Type Library (or 16.0 for A2004-2005)
'' Microsoft Scripting Runtime

'' |||||||||||||||||||||||''
'' |Tested on A2007 only |''
'' |||||||||||||||||||||||''

'' written by LeonidSN 

Dim OldText As String
Dim NewText As String
Dim DirName As String


Sub vMain()

   OldText = InputBox("Enter text for replace:", "Batch Job")
   NewText = InputBox("Enter new text:", "Batch Job")
   DirName = InputBox("Enter full name of folder:", "Batch Job")
   Dim fName As String
   Dim FullName As String

   fName = DirName & "*.dwg"
   fName = Dir(fName)
   FullName = DirName & fName
   Call FileAccess(FullName)

   Do While fName <> ""
       fName = Dir()
       FullName = DirName & fName
       Call FileAccess(FullName)
   Loop

End Sub

Private Sub FileAccess(FullName As String)
   Dim MainDoc As AxDbDocument

   On Error Resume Next
   Set MainDoc = New AXDBLib.AxDbDocument
   MainDoc.Open (FullName)

   Call FileProcessing(MainDoc)

   MainDoc.SaveAs (MainDoc.Name)
   Set MainDoc = Nothing
End Sub

Private Sub FileProcessing(MainDoc As AxDbDocument)
   Dim MS As AcadModelSpace
   Set MS = MainDoc.ModelSpace
   Dim vEntity As AcadEntity
   Dim i As Integer
   Dim entObjectID As Long
   Dim tempObj As AcadObject

On Error Resume Next
For i = 0 To MS.Count
    entObjectID = MS.Item(i).ObjectID
    Set tempObj = MainDoc.ObjectIdToObject(entObjectID)
    If (TypeOf tempObj Is AcadText) Then
       If (tempObj.textString = OldText) Then
           tempObj.textString = NewText
       End If
    End If
Next i

End Sub

 

~J'~