none
Macro to find and list non-protected files (non-password) RRS feed

  • General discussion

  • Hy people.

    I'm running a psychology clinic and I have lots (thousands) of files that should be password protected. Some of them are not and I need to find them quickly. I wrote this macro (collected from a bunch of stuff that I found) that basically opens up every document which is not password protected. However, I have some problems.

    1. When I get to really large directories the macro get stuck and I have to end the task.

    2. I actually don't need to open the file and just listing the files and their path will be sufficient for me.

    Will be glad if any of you could take a look at the code and share your thoughts with me or if you have suggestion to other approaches to achieve my goal.

    Here's my code: (Word 2007)

    Option Explicit
     
    Public Sub ProcessBatch()
     
    Dim FSO As Object
    Dim SourceFolder As Object
    Dim SubFolder As Object
    
    Dim strFileName As String
    Dim strFilePath As String
    Dim oDoc As Document
      
      ' Set Directory for Batch Process
      strFilePath = "c:\Test\"
      
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = FSO.GetFolder(strFilePath)
      
      
      ' Get Name of First .doc File from Directory
      strFileName = Dir$(strFilePath & "*.docx")
      
     
      While Len(strFileName) <> 0
      
        ' Set Error Handler
        On Error Resume Next
            
        ' Attempt to Open the Document
        Set oDoc = Documents.Open( _
              FileName:=strFilePath & strFileName, _
              PasswordDocument:="?#nonsense@$")
        
        Select Case Err.Number
          Case 0
            ' Document was Successfully Opened
            Debug.Print strFileName & " was processed."
    
          Case 5408
            ' Document is Password-protected and was NOT Opened
            Debug.Print strFileName & " is password-protected " & _
              "and was NOT processed."
            ' Clear Error Object and Disable Error Handler
            Err.Clear
            On Error GoTo 0
            ' Get Next Document
            GoTo GetNextDoc
    
          Case Else
            ' Another Error Occurred
            MsgBox Err.Number & ":" & Err.Description
        End Select
        
        ' Disable Error Handler
        On Error GoTo 0
        
        '-------------------------------------
        '-------------------------------------
        '---Perform Action on Document Here---
        '-------------------------------------
        '-------------------------------------
        
        Application.Documents.Add
        ActiveDocument.ActiveWindow.View = wdPrintView
        Selection.TypeText strFilePath & strFileName
    
     ' Close Document
        oDoc.Close
        
        ' Clear Object Variable
        Set oDoc = Nothing
        
    GetNextDoc:
        
        ' Get Next Document from Specified Directory
        strFileName = Dir$()
     
      Wend
       
        ' Work through all the other subdirectories
       
      For Each SubFolder In SourceFolder.SubFolders
    
      ' Get Name of First .doc File from Directory
      strFilePath = SubFolder & "\"
      strFileName = Dir$(strFilePath & "*.docx")
      
     
      While Len(strFileName) <> 0
      
        ' Set Error Handler
        On Error Resume Next
            
        ' Attempt to Open the Document
        Set oDoc = Documents.Open( _
              FileName:=strFilePath & strFileName, _
              PasswordDocument:="?#nonsense@$")
        
        Select Case Err.Number
          Case 0
            ' Document was Successfully Opened
            Debug.Print strFileName & " was processed."
    
          Case 5408
            ' Document is Password-protected and was NOT Opened
            Debug.Print strFileName & " is password-protected " & _
              "and was NOT processed."
            ' Clear Error Object and Disable Error Handler
            Err.Clear
            On Error GoTo 0
            ' Get Next Document
            GoTo GetNextDoc
    
          Case Else
            ' Another Error Occurred
            MsgBox Err.Number & ":" & Err.Description
        End Select
        
        ' Disable Error Handler
        On Error GoTo 0
        
        '-------------------------------------
        '-------------------------------------
        '---Perform Action on Document Here---
        '-------------------------------------
        '-------------------------------------
        
        ActiveDocument.Selection.TypeText strFilePath & strFileName
    
     ' Close Document
        oDoc.Close
        
        ' Clear Object Variable
        Set oDoc = Nothing
        
    GetNextDoc2:
        
        ' Get Next Document from Specified Directory
        strFileName = Dir$()
     
      Wend
      Next
      
    End Sub
    
    
    

    Tuesday, April 5, 2011 12:48 AM

All replies

  • Hi Kugel21,

     

    Maybe just simplifying it would help.

     

    Sub FindFiles()

        Dim ERct, OPct As Integer

        Dim sDir As String

        Dim oDoc As Document

        Dim sPath As String: sPath = "C:\MyDirectory\"

       

        sDir = Dir$(sPath & "*.docx", vbNormal)

        On Error Resume Next

        Do Until LenB(sDir) = 0

            Set oDoc = Documents.Open(FileName:=sPath &  sDir,  PasswordDocument:="ABC")

            If Err.Number <> 0 Then

                ERct = ERct + 1

               ‘write to your log here with the value of sDir & “ has a password”

            Else

                OPct = OPct + 1

                ‘write to your log here with the value of sDir & “ does not have a password”

                oDoc.Close

            End If

            sDir = Dir$

        Loop

        MsgBox "Failed to Open: " & ERct & " Opened: " & OPct

     

    End Sub

     

    Hope this helps


    Regards
    Tuesday, April 5, 2011 7:48 PM
  • Cross-posted at: http://www.techsupportforum.com/forums/f57/macro-to-find-and-list-non-protected-files-non-password-563635.html

    kugel21: For cross-posting etiquette, please see: http://www.excelguru.ca/node/7


    Cheers
    Paul Edstein
    [MS MVP - Word]
    Wednesday, April 6, 2011 8:21 AM