Results 1 to 14 of 14
  1. #1
    New Lounger
    Join Date
    Mar 2016
    Posts
    5
    Thanks
    2
    Thanked 0 Times in 0 Posts

    Password-protect multiple files at once in Word 2010

    I am trying to password protect a large quantity of word files using 2010. I have found several macros similar to the following, but none of them seem to work on 2010. To give credit where credit is do this particular macro was posted on several sites by Graham Mayor. Any ideas? Secondly is there any way to do this a have a different password set for each document? Thank you for any help with this!


    Public Sub PasswordAll()

    Dim FirstLoop As Boolean
    Dim myFile As String
    Dim sPassword As String
    Dim PathToUse As String
    Dim myDoc As Document
    Dim Response As Long

    PathToUse = InputBox("Path To Use?", "Path", "D:\My Documents\Test\Merge\")
    sPassword = InputBox("Enter Password")

    On Error Resume Next
    Documents.Close SaveChanges:=wdPromptToSaveChanges
    FirstLoop = True
    myFile = Dir$(PathToUse & "*.doc")
    While myFile <> ""
    Set myDoc = Documents.Open(PathToUse & myFile)
    If FirstLoop Then
    With ActiveDocument
    .Password = sPassword
    .WritePassword = sPassword
    End With
    FirstLoop = False

    Response = MsgBox("Do you want to process " & _
    "the rest of the files in this folder", vbYesNo)
    If Response = vbNo Then Exit Sub
    Else
    With ActiveDocument
    .Password = sPassword
    .WritePassword = sPassword
    End With
    End If
    myDoc.Close SaveChanges:=wdSaveChanges
    myFile = Dir$()
    Wend
    End Sub

  2. #2
    Silver Lounger Charles Kenyon's Avatar
    Join Date
    Jan 2001
    Location
    Sun Prairie, Wisconsin, Wisconsin, USA
    Posts
    2,049
    Thanks
    124
    Thanked 119 Times in 116 Posts
    Different password for each document? How are you going to correlate the password with the document once this is done? How are you figuring out which password you want to apply?

    I could fairly easily apply a different password to 1000 different documents, but how, after the macro is run, am I going to open any of them again? I have a habit of losing keys and the thought makes me anxious.
    Charles Kyle Kenyon
    Madison, Wisconsin

  3. #3
    New Lounger
    Join Date
    Mar 2016
    Posts
    5
    Thanks
    2
    Thanked 0 Times in 0 Posts
    Yes, that is what I have been asked to do. Is it possible to use a csv file that has predefined passwords? Or is it possible to have the macro generate and log what password has assigned to each file in the folder it is executing on? Those are the only ideas I had. If those are not viable is it possible to have the macro prompt from a password for each file to at least speed up the process? Thank you!

  4. #4
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,434
    Thanks
    372
    Thanked 1,457 Times in 1,326 Posts
    Romm,

    Welcome to the Lounge as a new poster!

    Here's a little code to get you started. This code will read passwords from a file one at a time as it loads a new word document and assigns that password to the file. The path to the password file is hard coded but you could easily prompt for it. The code will display a file picker for the user to select the source directory, a lot of the code is to support that function. It is also designed to output the Filespec and password to the Immediate window but this could easily be changed to a file or word document, etc. I've done some file checking but I'm sure it's not exhaustive (for instance I didn't check for running out of passwords!).

    I'd suggest placing the code in Normal in it's own Module so it is then always available.
    Code:
    Option Explicit
    
    '                        +--------------------------+            +----------+
    '------------------------|Windows Function Type Defs|------------| 08/11/05 |
    '                        +--------------------------+            +----------+
    Public Type BROWSEINFO
        hOwner         As Long
        pidlRoot       As Long
        pszDisplayName As String
        lpszTitle      As String
        ulFlags        As Long
        lpfn           As Long
        lParam         As Long
        iImage         As Long
    End Type
    
    '                     +-----------------------------+            +----------+
    '---------------------|Windows Function Declarations|------------| 08/11/05 |
    '                     +-----------------------------+            +----------+
    Declare Function SHGetPathFromIDList Lib "shell32.dll" _
      Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
                                    ByVal pszPath As String) As Long
                                    
    Declare Function SHBrowseForFolder Lib "shell32.dll" _
    Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
    
    
    Sub PWPDirectory()
    
       Dim zProcessDir  As String
       Dim zNextFile    As String
       Dim zPWD         As String
       Dim zPWDPassFile As String
       Dim oDocToPW     As Document
       
       zPWDPassFile = "G:\Test\WDpassTest\RandPassWds.txt"
       On Error GoTo NoPWDFile
         Open zPWDPassFile For Input As #1
       On Error GoTo 0  'Reset Error Trap
       
       zProcessDir = zGetDirectory()
       
       zNextFile = Dir(zProcessDir & "\*.doc*")
       
       If zNextFile = "" Then Exit Sub
       
       Application.ScreenUpdating = False
        
       Do
    
         Set oDocToPW = Documents.Open(zProcessDir & "\" & zNextFile)
         Line Input #1, zPWD
         With oDocToPW
             .Password = zPWD
             .WritePassword = zPWD
             .Save
             .Close
             Debug.Print zProcessDir & "\" & zNextFile & " PW: " & zPWD
         End With 'oDocToPw
         
         zNextFile = Dir()
         
       Loop Until zNextFile = ""
       
       GoTo Get_Out
       
    NoPWDFile:
    
      If Err = 53 Then
        MsgBox "The file: " & zPWDPassFile & " was not found!", _
                vbOKOnly + vbCritical, "Error: File Not Found"
       
      Else
        MsgBox "Error No: " & Err.Number & vbCrLf & _
               "Error Msg: " & Err.Description, _
               vbOKOnly, "Untrapped Error Encountered:"
      End If
      
    Get_Out:
    
      Close #1  'Close PWD File
      Application.ScreenUpdating = True
      
    End Sub
    
    '                         +-------------------------+            +----------+
    '-------------------------|     zGetDirectory()     |------------| 07/25/05 |
    '                         +-------------------------+            +----------+
    'Calls: N/A
    'Notes: This function will bring up a form to let the user select a directory
    
    Public Function zGetDirectory(Optional Msg) As String
    
        Dim bInfo As BROWSEINFO
        Dim zPath As String
        Dim lRetVal2 As Long, lRetVal As Long, iEndOfStr As Integer
    
        bInfo.pidlRoot = 0  '*** Root folder = Desktop ***
    
    '***   Title in the dialog ***
        If IsMissing(Msg) Then
            bInfo.lpszTitle = "Select a Drive/Directory."
        Else
            bInfo.lpszTitle = Msg
        End If
    
        bInfo.ulFlags = &H1  '*** Type of directory to return ***
        lRetVal = SHBrowseForFolder(bInfo)  '*** Display the dialog ***
        zPath = Space$(512)     '*** Parse the result ***
        lRetVal2 = SHGetPathFromIDList(ByVal lRetVal, ByVal zPath)
        If lRetVal2 Then
            iEndOfStr = InStr(zPath, Chr$(0))
            zGetDirectory = Left(zPath, iEndOfStr - 1)
        Else
            zGetDirectory = ""
        End If
        
    End Function             'zGetDirectory(Optional Msg)
    Starting Files:
    WSPassStartFiles.PNG

    Processing Messages:
    WSPassImmediate.PNG

    Ending Files: (see dates/times)
    WSPassEndFiles.PNG

    This should at least give you a start. Post back if you need more assistance.

    HTH
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  5. The Following User Says Thank You to RetiredGeek For This Useful Post:

    Romm (2016-03-17)

  6. #5
    Super Moderator
    Join Date
    May 2002
    Location
    Canberra, Australian Capital Territory, Australia
    Posts
    5,054
    Thanks
    2
    Thanked 417 Times in 346 Posts
    Quote Originally Posted by Romm View Post
    Yes, that is what I have been asked to do.
    Whoever tasked you with this might need a reality check. If all the files need to be secured, you could store them in a single password-protected zip file or folder. The only reason for not doing so is if the files need to be opened by different people and each one needs secure access to their own file (s).
    Cheers,

    Paul Edstein
    [MS MVP - Word]

  7. #6
    New Lounger
    Join Date
    Mar 2016
    Posts
    5
    Thanks
    2
    Thanked 0 Times in 0 Posts
    Thank you! This is exactly what I needed. How do I get the processing message to be put into word or csv file? I am struggling to make it work.

  8. #7
    New Lounger
    Join Date
    Mar 2016
    Posts
    5
    Thanks
    2
    Thanked 0 Times in 0 Posts
    Quote Originally Posted by macropod View Post
    Whoever tasked you with this might need a reality check. If all the files need to be secured, you could store them in a single password-protected zip file or folder. The only reason for not doing so is if the files need to be opened by different people and each one needs secure access to their own file (s).
    I agree completely. Unfortunately it is the scenario you pointed out.

  9. #8
    Super Moderator
    Join Date
    Jan 2001
    Location
    Melbourne, Victoria, Australia
    Posts
    3,852
    Thanks
    4
    Thanked 259 Times in 239 Posts
    The single biggest issue with the use of different passwords is that a file could become locked forever if someone innocently or maliciously renamed it.

    To reduce the likelihood of this, you might store the password/document pair using a document property that is readable when the file is closed. If your macro had a standard algorithm (not known by the users) that converted the string of that property into a password then you wouldn't even need a document to store the password/doc pairs at all.
    Andrew Lockton, Chrysalis Design, Melbourne Australia

  10. #9
    Super Moderator
    Join Date
    May 2002
    Location
    Canberra, Australian Capital Territory, Australia
    Posts
    5,054
    Thanks
    2
    Thanked 417 Times in 346 Posts
    And what happens if the user changes the password?
    Cheers,

    Paul Edstein
    [MS MVP - Word]

  11. #10
    Super Moderator
    Join Date
    Jan 2001
    Location
    Melbourne, Victoria, Australia
    Posts
    3,852
    Thanks
    4
    Thanked 259 Times in 239 Posts
    Paul, Is this a trick question? I would have thought, exactly the same thing as when they change a common password on one particular file.

    Do you have a solution that might resolve that scenario?

    I suppose 'locked forever' is a bit overly dramatic since there would be a finite number of passwords that could be tried to unlock the file. But if someone DID manually change the password then that list suddenly gets a whole lot larger.
    Andrew Lockton, Chrysalis Design, Melbourne Australia

  12. #11
    Super Moderator
    Join Date
    May 2002
    Location
    Canberra, Australian Capital Territory, Australia
    Posts
    5,054
    Thanks
    2
    Thanked 417 Times in 346 Posts
    The point of the question was to alert Romm to the potential limited utility of maintaining the list; once the recipient opens the file, usually they probably should change the password and, even if for some reason they shouldn't, they could.
    Cheers,

    Paul Edstein
    [MS MVP - Word]

  13. #12
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,434
    Thanks
    372
    Thanked 1,457 Times in 1,326 Posts
    Romm,

    Here's the revised code to write the file names and associated passwords to a file:
    Code:
    Sub PWPDirectory()
    
       Dim zProcessDir  As String
       Dim zNextFile    As String
       Dim zPWD         As String
       Dim zPWDPassFile As String
       Dim zPWDLogFile  As String
       Dim oDocToPW     As Document
       
       zPWDPassFile = "G:\Test\WDPassTest\RandPassWds.txt"
       zPWDLogFile = "G:\Test\WDPassTest\PWDLog.txt"
       
       On Error GoTo NoPWDFile
         Open zPWDPassFile For Input As #1
       On Error GoTo 0  'Reset Error Trap
       
       On Error GoTo LogFileNoAccess
         
    '*** Note the use of Append in the following code will append       ***
    '***      new log entries to the file each time the program is run. ***
    '***      To over write the file replace APPEND with OUTPUT         ***
    
         Open zPWDLogFile For Append As #2
       On Error GoTo 0
       
       zProcessDir = zGetDirectory()
       
       zNextFile = Dir(zProcessDir & "\*.doc*")
       
       If zNextFile = "" Then Exit Sub
       
       Application.ScreenUpdating = False
        
       Do
    
         Set oDocToPW = Documents.Open(zProcessDir & "\" & zNextFile)
         Line Input #1, zPWD
         With oDocToPW
             .Password = zPWD
             .WritePassword = zPWD
             .Save
             .Close
             Print #2, zProcessDir & "\" & zNextFile & " PW: " & zPWD
         End With 'oDocToPw
         
         zNextFile = Dir()
         
       Loop Until zNextFile = ""
       
       GoTo Get_Out
       
    LogFileNoAccess:
      If Err = 75 Then
        MsgBox "The file: " & zPWDLogFile & " could NOT be opened!" & vbCrLf & _
               vbCrLf & "Please correct the error and try again.", _
                vbOKOnly + vbCritical, "Error: File Access Error"
       
      Else
        MsgBox "Error No: " & Err.Number & vbCrLf & _
               "Error Msg: " & Err.Description, _
               vbOKOnly, "Untrapped Error Encountered:"
      End If
    
      GoTo Get_Out:
      
    NoPWDFile:
    
      If Err = 53 Then
        MsgBox "The file: " & zPWDPassFile & " was not found!", _
                vbOKOnly + vbCritical, "Error: File Not Found"
       
      Else
        MsgBox "Error No: " & Err.Number & vbCrLf & _
               "Error Msg: " & Err.Description, _
               vbOKOnly, "Untrapped Error Encountered:"
      End If
      
    Get_Out:
    
      Close #1  'Close PWD File
      Close #2  'Close Log File
      Application.ScreenUpdating = True
      
    End Sub   'PWPDirectory
    Sample file:
    Code:
    G:\Test\WDPassTest\Buckwheat Flour Recipes.doc PW: Test1
    G:\Test\WDPassTest\DIY Pancake Mix.docx PW: Test2
    G:\Test\WDPassTest\EGGPLANT.doc PW: Test3
    G:\Test\WDPassTest\French Toast Bread Pudding with Spiced Pears.doc PW: Test4
    G:\Test\WDPassTest\FRENCHT.doc PW: Test5
    G:\Test\WDPassTest\Buckwheat Flour Recipes.doc PW: Test1
    G:\Test\WDPassTest\DIY Pancake Mix.docx PW: Test2
    G:\Test\WDPassTest\EGGPLANT.doc PW: Test3
    G:\Test\WDPassTest\French Toast Bread Pudding with Spiced Pears.doc PW: Test4
    G:\Test\WDPassTest\FRENCHT.doc PW: Test5
    Note: the above was with the Append option (see code comment) after running against the list of files then deleting the PW protected files and running again against the original files.

    HTH
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  14. The Following User Says Thank You to RetiredGeek For This Useful Post:

    Romm (2016-03-18)

  15. #13
    New Lounger
    Join Date
    Mar 2016
    Posts
    5
    Thanks
    2
    Thanked 0 Times in 0 Posts
    Thank you! I really appreciate the help!

  16. #14
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,434
    Thanks
    372
    Thanked 1,457 Times in 1,326 Posts
    Romm,

    Here's an improved version that checks to make sure there are enough passwords in the file to handle all the .doc files in the directory!
    Code:
    Sub PWPDirectory()
    
       Dim lDocCnt      As Long
       Dim lPWDCnt      As Long
       Dim zProcessDir  As String
       Dim zNextFile    As String
       Dim zPWD         As String
       Dim zPWDPassFile As String
       Dim zPWDLogFile  As String
       Dim oDocToPW     As Document
       
       zPWDPassFile = "G:\Test\WDPassTest\RandPassWds.txt"
       zPWDLogFile = "G:\Test\WDPassTest\PWDLog.txt"
       
       On Error GoTo NoPWDFile
         Open zPWDPassFile For Input As #1
       On Error GoTo 0  'Reset Error Trap
       
       On Error GoTo LogFileNoAccess
         
    '*** Note the use of Append in the following code will append       ***
    '***      new log entries to the file each time the program is run. ***
    '***      To over write the file replace APPEND with OUTPUT         ***
    
         Open zPWDLogFile For Append As #2
       On Error GoTo 0
       
       zProcessDir = zGetDirectory()
       
    '*** Check that therer are enough Passwords for the number of files! ***
    
       zNextFile = Dir(zProcessDir & "\*.doc*")
       If zNextFile = "" Then Exit Sub
       
       Do
          lDocCnt = lDocCnt + 1
          zNextFile = Dir()
       Loop Until zNextFile = ""
       
       Line Input #1, zPWD   '*** Get Next Password
       
       Do
          lPWDCnt = lPWDCnt + 1
          Line Input #1, zPWD   '*** Get Next Password
        Loop While Not EOF(1)
        
       If lPWDCnt < lDocCnt Then
         MsgBox "There are " & Format(lDocCnt, "#") & " documents" & _
                " and only " & Format(lPWDCnt, "#") & " passwords!" & _
                vbCrLf & vbCrLf & "Please correct and try again.", _
                vbOKOnly & vbCritical, "Error: Insufficient Passwords"
         GoTo Get_Out
       Else
       '**** Close file and reopen to reset at first password ****
         Close #1
         Open zPWDPassFile For Input As #1
       End If
       
       zNextFile = Dir(zProcessDir & "\*.doc*")
       
       Application.ScreenUpdating = False
        
       Do
    
         Set oDocToPW = Documents.Open(zProcessDir & "\" & zNextFile)
         
         Line Input #1, zPWD   '*** Get Next Password
         
         With oDocToPW
             .Password = zPWD
             .WritePassword = zPWD
             .Save
             .Close
             Print #2, zProcessDir & "\" & zNextFile & " PW: " & zPWD
         End With 'oDocToPw
         
         zNextFile = Dir()
         
       Loop Until zNextFile = ""
       
       GoTo Get_Out
       
    LogFileNoAccess:
    
      If Err = 75 Then
        MsgBox "The file: " & zPWDLogFile & " could NOT be opened!" & vbCrLf & _
               vbCrLf & "Please correct the error and try again.", _
                vbOKOnly + vbCritical, "Error: File Access Error"
       
      Else
        MsgBox "Error No: " & Err.Number & vbCrLf & _
               "Error Msg: " & Err.Description, _
               vbOKOnly, "Untrapped Error Encountered:"
      End If
    
      GoTo Get_Out:
      
    NoPWDFile:
    
      If Err = 53 Then
        MsgBox "The file: " & zPWDPassFile & " was not found!", _
                vbOKOnly + vbCritical, "Error: File Not Found"
       
      Else
        MsgBox "Error No: " & Err.Number & vbCrLf & _
               "Error Msg: " & Err.Description, _
               vbOKOnly, "Untrapped Error Encountered:"
      End If
      
    Get_Out:
    
      Close #1  'Close PWD File
      Close #2  'Close Log File
      Application.ScreenUpdating = True
      
    End Sub   'PWPDirectory
    If there are not enough you'll get a message like this:
    notenoughpws.PNG

    Note: I fixed the missing space in the message in the code above.

    Pressing Ok will end the program w/o taking any action so you can fix the PW file.

    HTH
    Last edited by RetiredGeek; 2016-03-18 at 14:22.
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •