Here is one I 've collected from this NG
Tested on A2005 only but I am sure
that it will works for you too
Make sure to reference on current
version ObjectDBX Library
Option Explicit
'' Requires: (include usual DLLs)
'' AutoCAD/ObjectDBX Common 17.0 Type Library
'' Microsoft Scripting Runtime
'' |||||||||||||||||||||||''
'' |Tested on A2005 only |''
'' |||||||||||||||||||||||''
Public Function BrowseForFolderF(ByVal msg As String) As String
Dim oBrowser, folderObj, folderAcpt As Object
Dim folderStr As String
Set oBrowser = ThisDrawing.Application.GetInterfaceObject("Shell.Application")
Set folderAcpt = oBrowser.BrowseForFolder(vbOKOnly, msg, vbDefaultButton3, 0)
With folderAcpt
Set folderObj = .Self
folderStr = folderObj.path
End With
Set folderObj = Nothing
Set folderAcpt = Nothing
Set oBrowser = Nothing
BrowseForFolderF = folderStr
End Function
Public Function CheckFolder(ByVal strPath As String) As Variant
Dim objFolder ''As Scripting.Folder
Dim objFile ''As Scripting.File
Dim objSubdirs ''As Scripting.Folders
Dim objLoopFolder ''As Scripting.Folder
Dim varFs() As Variant
Dim m_objFSO, n, m_lngFileCount
Debug.Print "Checking directory " & strPath
Set m_objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = m_objFSO.GetFolder(strPath)
'
' Check files in this directory
'
n = -1
For Each objFile In objFolder.Files
If UCase$(Right$(objFile.ShortPath, 4)) = ".DWG" Then
m_lngFileCount = m_lngFileCount + 1
n = n + 1
ReDim Preserve varFs(n)
varFs(n) = objFile.path
End If
Next objFile
' Loop through all subdirectories and
' do the same thing.
'
Set objSubdirs = objFolder.SubFolders
For Each objLoopFolder In objSubdirs
CheckFolder objLoopFolder.path
Next objLoopFolder
Set objSubdirs = Nothing
Set objFolder = Nothing
CheckFolder = varFs
End Function
Sub BatchReplace()
Dim oText As AcadText
Dim objFnd As Object
Dim indx As Integer
Dim iFiles() As Variant
Dim m_objFSO
Dim fold, DwgName, a, b, c, d, e, nm As String
fold = BrowseForFolderF("Where are my dwg files?")
Set m_objFSO = CreateObject("Scripting.FileSystemObject")
iFiles = CheckFolder(fold)
a = InputBox(vbCrLf & "Enter a string to search:", "String to search")
b = InputBox(vbCrLf & "Enter an old string" & vbNewLine & _
"(must be the same as previous) :", "String to find")
c = InputBox(vbCrLf & "Enter a new string:", "String to find")
Dim oDbx As New AxDbDocument
Set oDbx = GetInterfaceObject("ObjectDBX.AxDbDocument.17") '' or 16 for A2005-6
On Error Resume Next
For indx = LBound(iFiles) To UBound(iFiles)
DwgName = iFiles(indx)
oDbx.Open DwgName
For Each objFnd In oDbx.ModelSpace
nm = objFnd.ObjectName
If nm = "AcDbText" Then
Set oText = objFnd
d = oText.TextString
If StrComp(d, a, 1) = 0 Then
e = replaceStr(a, b, c, False)
oText.TextString = e
oText.Update
End If
End If
Next objFnd
oDbx.SaveAs DwgName
Debug.Print Err.Number & Err.Description
Set oDbx = Nothing
Next indx
End Sub
' borrowed by www.ActiveDWG.com
Public Function replaceStr(ByVal searchStr As String, ByVal oldStr As String, ByVal newStr As String, ByVal firstOnly As Boolean) As String
If searchStr = "" Then Exit Function
If oldStr = "" Then Exit Function
replaceStr = ""
Dim i As Integer, oldStrLen As Integer, holdStr As String, StrLoc As Integer
oldStrLen = Len(oldStr)
StrLoc = InStr(searchStr, oldStr)
While StrLoc > 0
holdStr = holdStr & Left(searchStr, StrLoc - 1) & newStr
searchStr = Mid(searchStr, StrLoc + oldStrLen)
StrLoc = InStr(searchStr, oldStr)
If firstOnly Then replaceStr = holdStr & searchStr: Exit Function
Wend
replaceStr = holdStr & searchStr
End Function
~'J'~
