Automate applying a change to an event procedure

[mwperkins]

Hi,
I would like to update the comments field in the workbook properties of all the workbooks in a particular folder.

Ideally, I would like to add the following line to the Workbook_BeforePrint procedure:

ActiveWorkbook.BuiltinDocumentProperties("Comments").Value = "Based on a template developed by mwperkins"

How can I copy this line into the procedure?


Below is the code that I have so far....

Option Explicit
Sub ApplyDocumentComments()
On Error Resume Next
Dim File_Name, Msg, Style, Title, Response
Dim fs, I
Dim oFSO As Object
Dim MainWorkbook As Workbook


Set fs = Application.FileSearch
Set MainWorkbook = ActiveWorkbook
Set oFSO = CreateObject("Scripting.FileSystemObject")

'activate the Search - START
With fs
    .LookIn = Range("C2").Value
    .Filename = "*.xls"
    .SearchSubFolders = True
    
    If .Execute(SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending) > 0 Then
        'If more than 200 files have been found provide a chance to quit - START
            If .FoundFiles.Count > 200 Then
                Msg = " " & .FoundFiles.Count & " files found matching your search critieria." & vbCr _
                    & vbCr & "This activity may take some time." & vbCr _
                    & vbCr & "Are you sure you want to continue?"
                Style = vbYesNo + vbInformation + vbDefaultButton1
                Title = "... it would be rude to say No..."
                Response = MsgBox(Msg, Style, Title)
                    If Response = vbNo Then
                        Exit Sub
                    End If
            End If
        'If more than 200 files have been found provide a chance to quit - END
        'Process each file - START
            On Error Resume Next
            For I = 1 To .FoundFiles.Count
                'Set oFSO = CreateObject("Scripting.FileSystemObject")
                Set File_Name = oFSO.GetFile(.FoundFiles(I))
                Workbooks.Open File_Name
                
                'Ideally, I would prefer to copy the following line into the "Workbook_BeforePrint" procedure:
                ActiveWorkbook.BuiltinDocumentProperties("Comments").Value = "Based on a template developed by mwperkins"
                
                ActiveWorkbook.Close True
                MainWorkbook.Activate
            Next I
            On Error GoTo 0
        'Process each file - END
    Else
        MsgBox "There were no files found."
    End If
End With
    Range("B2").Select
End Sub

Many thanks in advance

 

[Andrew Poulsom]

This worked for me:

Sub Test()
    Dim Code As String
    Dim NextLine As Long
    Code = "Private Sub Workbook_BeforePrint(Cancel As Boolean)" & vbCrLf
    Code = Code & "ActiveWorkbook.BuiltinDocumentProperties(""Comments"").Value = ""Based on a template developed by mwperkins""" & vbCrLf
    Code = Code & "End Sub"
    With ActiveWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule
        NextLine = .CountOfLines + 1
        .InsertLines NextLine, Code
    End With
End Sub

 

[mwperkins]

Andrew,
Many thanks - this works perfectly if the procedure does not already exist, but causes an "ambiguous name" error otherwise.

Any ideas on how to check if the procedure already exists:
If it does - append code within procedure
If it does not - apply code as per your previous posting.


Many thanks,
Mark

 

[Andrew Poulsom]

Try this:

Sub Test()
    Dim Code As String
    Dim NextLine As Long
    With ActiveWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule
        If .Find("Workbook_BeforePrint", 1, 1, -1, -1) = False Then
            Code = "Private Sub Workbook_BeforePrint(Cancel As Boolean)" & vbCrLf
            Code = Code & "ActiveWorkbook.BuiltinDocumentProperties(""Comments"").Value = ""Based on a template developed by mwperkins""" & vbCrLf
            Code = Code & "End Sub"
            NextLine = .CountOfLines + 1
        Else
            Code = "ActiveWorkbook.BuiltinDocumentProperties(""Comments"").Value = ""Based on a template developed by mwperkins"""
            NextLine = .ProcBodyLine("Workbook_BeforePrint", 0) + 1
        End If
        .InsertLines NextLine, Code
    End With
End Sub

It adds your bit as the first line if the procedure already exists.

 

[mwperkins]

Automate applying a change to an event procedure (SOLVED)

Andrew,
Many thanks - just what I needed.

For those that are interested, here's the code I used in the end.....

Option Explicit
'---------------------------------------------------------------------------------------
' Procedure : ApplyDocumentComments
' DateTime  : 20/05/2003 11:27
' Author    : mwperkins, with considerable support from Andrew Poulsom (via www.mrexcel.com)
' Purpose   : To apply document comments and common footer info to multiple files
'---------------------------------------------------------------------------------------
'
Sub ApplyDocumentComments()
On Error Resume Next
Dim File_Name, Msg, Style, Title, Response
Dim fs, I
Dim oFSO As Object
Dim MainWorkbook As Workbook
Dim NewCode As String
Dim AmendCode As String
Dim NextLine As Long
Set fs = Application.FileSearch
Set MainWorkbook = ActiveWorkbook
Set oFSO = CreateObject("Scripting.FileSystemObject")

AmendCode = "Dim IndividualSheet" & vbCrLf
AmendCode = AmendCode & "ActiveWorkbook.BuiltinDocumentProperties(""Comments"").Value = ""Based on a template developed by UKNM PPI Team""" & vbCrLf
AmendCode = AmendCode & "For Each IndividualSheet In ActiveWorkbook.Worksheets" & vbCrLf
AmendCode = AmendCode & "IndividualSheet.PageSetup.RightFooter = ActiveWorkbook.BuiltinDocumentProperties(""Comments"").Value" & vbCrLf
AmendCode = AmendCode & "Next IndividualSheet" & vbCrLf

NewCode = "Private Sub Workbook_BeforePrint(Cancel As Boolean)" & vbCrLf
NewCode = NewCode & AmendCode
NewCode = NewCode & "End Sub" & vbCrLf


'activate the Search
With fs
    .LookIn = Range("C2").Value
    .Filename = "*.xls"
    .SearchSubFolders = True
    
    If .Execute(SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending) > 0 Then
        'If more than 200 files have been found provide a chance to quit - START
            If .FoundFiles.Count > 200 Then
                Msg = " " & .FoundFiles.Count & " files found matching your search critieria." & vbCr _
                    & vbCr & "This activity may take some time." & vbCr _
                    & vbCr & "Are you sure you want to continue?"
                Style = vbYesNo + vbInformation + vbDefaultButton1
                Title = "... it would be rude to say No..."
                Response = MsgBox(Msg, Style, Title)
                    If Response = vbNo Then
                        Exit Sub
                    End If
            End If
        'If more than 200 files have been found provide a chance to quit - END
        'Process each file - START
            On Error Resume Next
            For I = 1 To .FoundFiles.Count
                Set File_Name = oFSO.GetFile(.FoundFiles(I))
                Workbooks.Open File_Name
                With ActiveWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule
                    If .Find("Workbook_BeforePrint", 1, 1, -1, -1) = False Then
                        NextLine = .CountOfLines + 1
                        .InsertLines NextLine, NewCode
                    Else
                        If .Find("Dim IndividualSheet", 1, 1, -1, -1) = False Then
                            NextLine = .ProcBodyLine("Workbook_BeforePrint", 0) + 1
                            .InsertLines NextLine, AmendCode
                        Else
                            MsgBox File_Name & " will need to be altered manually"
                        End If
                    End If
                End With
                ActiveWorkbook.Close True
                MainWorkbook.Activate
            Next I
            On Error GoTo 0
        'Process each file - END
    Else
        MsgBox "There were no files found."
    End If
End With
    Range("B2").Select
End Sub