Password-protect multiple files at once in Word 2010

Topic

New Reply

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 DocumentsTestMerge”)
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

Reply | Quote

Replies

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.

Reply | Quote

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!

Reply | Quote

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
[Fmr MS MVP - Word]

Reply | Quote

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.

Reply | Quote

Romm,

Welcome to the Lounge as a new poster! :cheers:

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:TestWDpassTestRandPassWds.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:
43902-WSPassStartFiles

Processing Messages:
43903-WSPassImmediate

Ending Files: (see dates/times)
43904-WSPassEndFiles

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

HTH :cheers:

May the Forces of good computing be with you!

RG

PowerShell & VBA Rule!
Computer Specs

Reply | Quote

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.

Reply | Quote

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.

Reply | Quote

And what happens if the user changes the password?

Cheers,
Paul Edstein
[Fmr MS MVP - Word]

Reply | Quote

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.

Reply | Quote

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
[Fmr MS MVP - Word]

Reply | Quote

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:TestWDPassTestRandPassWds.txt"
   zPWDLogFile = "G:TestWDPassTestPWDLog.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:TestWDPassTestBuckwheat Flour Recipes.doc PW: Test1
G:TestWDPassTestDIY Pancake Mix.docx PW: Test2
G:TestWDPassTestEGGPLANT.doc PW: Test3
G:TestWDPassTestFrench Toast Bread Pudding with Spiced Pears.doc PW: Test4
G:TestWDPassTestFRENCHT.doc PW: Test5
G:TestWDPassTestBuckwheat Flour Recipes.doc PW: Test1
G:TestWDPassTestDIY Pancake Mix.docx PW: Test2
G:TestWDPassTestEGGPLANT.doc PW: Test3
G:TestWDPassTestFrench Toast Bread Pudding with Spiced Pears.doc PW: Test4
G:TestWDPassTestFRENCHT.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 :cheers:

May the Forces of good computing be with you!

RG

PowerShell & VBA Rule!
Computer Specs

Reply | Quote

Thank you! I really appreciate the help!

Reply | Quote

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:TestWDPassTestRandPassWds.txt"
   zPWDLogFile = "G:TestWDPassTestPWDLog.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:
43928-notenoughpws

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 :cheers:

May the Forces of good computing be with you!

RG

PowerShell & VBA Rule!
Computer Specs

Reply | Quote