VBA TIPS
Deleting all procedures in the specific folder

This code would delete all procedures in xls files in the specific folder including the files in the sub folders.

As soon as you run this program, this program would ask you which folder do you would like to delete all procedures.



Please note, if you are using Excel 2002(XP) and the later, to run this program, you need to tick Trust access to Visual Basic Project from Tools > Macro > Security... from main menu.

Trust access to Visual Basic Project


Place the following in the standard module.

Option Explicit

' Need to reference 'MIcrosoft Visual Basic for Applications Extensibility'
' Need to reference 'Microsoft Scripting Runtime'
' If you get messgae from excel like this "Module Not Found" then just press [OK]

Public Sub DeleteAllProc()
    Const strMsg As String = "Please browse to the folder that contains xls files" _
                              & vbLf & "which you want to delete procedure."
    Const strCnf1 As String = "All procedures will be deleted in above path"
    Const strCnf2 As String = "Are you sure?"
    Dim fso As New Scripting.FileSystemObject

    Dim objFolder As Object
    Dim strPath As String
    Dim intCancelCnt As Integer
    Dim lngRet As Long

reSelect:
    Set objFolder = CreateObject("Shell.Application"). _
                    BrowseForFolder(0, strMsg, &H1)
    If Not objFolder Is Nothing Then
        strPath = objFolder.self.Path
    Else
        MsgBox strMsg, vbCritical
        Set objFolder = Nothing
        intCancelCnt = intCancelCnt + 1
        If intCancelCnt = 3 Then Exit Sub
        GoTo reSelect
    End If

    lngRet = MsgBox(strPath & vbLf & strCnf1 & vbLf & vbLf & strCnf2, 36)
    If lngRet = vbYes Then Call SeekFolder(objFolder.self.Path)
End Sub

Private Sub SeekFolder(ByVal strPath As String)
    Const strNotFound As String = "There is NO Excel files..."
    Dim ffTmp As FoundFiles
    Dim wb As Workbook
    Dim objVbc As Object
    Dim objFile As Variant
    Dim strLogFile As String
    Dim strErrFile As String
    Dim lngRet As Long
    Dim blnError As Boolean
    Dim FreeFile1 As Integer, FreeFile2 As Integer

    On Error GoTo Make_ErrorLog
    Application.DisplayAlerts = False

    strLogFile = ThisWorkbook.Path & "\DeleteProcLog.txt"
    strErrFile = ThisWorkbook.Path & "\ErrorLog.txt"

    'Search Excel files
    With Application.FileSearch
        .NewSearch
        .LookIn = strPath
        .SearchSubFolders = True
        .FileType = msoFileTypeExcelWorkbooks
        If .Execute > 0 Then
            Set ffTmp = .FoundFiles
        Else
            MsgBox strNotFound: Exit Sub
        End If
    End With

    For Each objFile In ffTmp
        Application.EnableEvents = False
        SetAttr objFile, vbNormal 'Just in case
        Set wb = Workbooks.Open(objFile)
        For Each objVbc In wb.VBProject.VBComponents
            If Workbooks(wb.Name).VBProject.Protection = vbext_pp_none Then

                Select Case objVbc.Type
                    Case 1, 3    'Std module and Userform
                        wb.VBProject.VBComponents.Remove objVbc
                    Case 100    'Sheet and Class and Thisworkbook module
                        With objVbc.CodeModule
                            .DeleteLines 1, .CountOfLines
                        End With
                End Select
                If Not blnError Then
                    FreeFile1 = FreeFile
                    Open strLogFile For Append As #FreeFile1
                    Print #FreeFile1, Now & " " & _
                                      wb.Name & ":" & _
                                      objVbc.Name & ":" & "Is Deleted"
                    Close #FreeFile1
                End If
            Else
                Open strLogFile For Append As #1
                Print #1, Now & " " & _
                          wb.Name & ":" & _
                          objVbc.Name & ":" & _
                          " Can't perform operation since the project is protected"
                Close #1
            End If
            blnError = False
        Next
        wb.Close True
        Application.EnableEvents = True
    Next

    lngRet = Shell("notepad.exe " & strLogFile, vbNormalFocus)
    lngRet = Shell("notepad.exe " & strErrFile, vbNormalFocus)
    Application.DisplayAlerts = True
    Exit Sub

Make_ErrorLog:
    FreeFile2 = FreeFile
    Open strErrFile For Append As #FreeFile2
    Print #FreeFile2, Now & " " & Err.Number & ":" & Err.Description
    Close #FreeFile2
    blnError = True
    Resume Next
End Sub





| HOME |
Copyright © cellmasters.net - colo's junk room All Right Reserved
ABOUT
WORKS
THE CELL MASTERS
CONTACT
LINKS
Tips and Information about Microsoft Excel|Masaru Kaji aka Colo