ReplaceProjectCodeInLayoutsAndBlocks.vba

' ReplaceProjectCodeInLayoutsAndBlocks, sgrodnik, v1, 2024/10/22
' Source and descripcion: https://gist.github.com/sgrodnik/35b1b8655986ea9684e458a364e0acd9

Sub ProcessFilesFromFile()
    Dim fileList As Variant
    Dim filePath As String
    Dim doc As AcadDocument
    Dim fileNum As Integer
    Dim line As String
    Dim filePaths As Collection
    Dim filePathTextFile As String

    filePathTextFile = CreateObject("WScript.Shell").specialfolders("Desktop") & "\del\cadsToProcess.txt"
    Set filePaths = New Collection

    fileNum = FreeFile
    Open filePathTextFile For Input As #fileNum
    Do While Not EOF(fileNum)
        Line Input #fileNum, line
        filePaths.Add line
    Loop
    Close #fileNum

    For Each filePath1 In filePaths
        Log "file " & filePath1
        Set doc = Application.Documents.Open(filePath1)
        ReplaceProjectCodeInLayoutsAndBlocks doc
        doc.Save
        doc.Close
    Next filePath1
End Sub

Sub ReplaceProjectCodeInLayoutsAndBlocks(doc As AcadDocument)
    ' For Each layout In ThisDrawing.Layouts
    For Each Layout In doc.Layouts

        If Layout.Name = "Model" Then
            GoTo ContinueLoopLayout
        End If

        For Each entity In Layout.Block

            If Not TypeOf entity Is AcadBlockReference Then
                GoTo ContinueLoopEntity
            End If
            'If entity.Name <> "DP513 - Title Block" Then
            '    GoTo ContinueLoopEntity
            'End If
            If entity.HasAttributes <> True Then
                GoTo ContinueLoopEntity
            End If

            atts = entity.GetAttributes
            For attCount = LBound(atts) To UBound(atts)
                Log "attr " & attCount & ": " & atts(attCount).TagString & ": (oldVal) " & atts(attCount).TextString
                atts(attCount).TextString = Replace(atts(attCount).TextString, "DP513", "CP515")
                Log "attr " & attCount & ": " & atts(attCount).TagString & ": (newVal) " & atts(attCount).TextString
            Next attCount

ContinueLoopEntity:
        Next entity

        Log "layout: " & Layout.Name
        Layout.Name = Replace(Layout.Name, "DP513", "CP515")

ContinueLoopLayout:
    Next Layout

End Sub

Function Log(logMessage As String)
    Dim filePath As String
    Dim fileNum As Integer

    filePath = CreateObject("WScript.Shell").specialfolders("Desktop") & "\vbaLog.txt"
    fileNum = FreeFile

    Open filePath For Append As #fileNum
    Print #fileNum, Now & " - " & logMessage
    Close #fileNum

    Debug.Print ":" & logMessage
End Function

Description

This VBA script is designed for batch processing of AutoCAD drawings. It performs the replacement of project codes on drawing layouts and within blocks in the specified AutoCAD files. The script reads a list of files from a text file and performs the following actions:

1. Opens each AutoCAD file.
2. Iterates through all layouts and blocks in each drawing, replacing the old project code with the new one.
3. Saves and closes each processed file.