PDA

View Full Version : [SOLVED] Assigning password to all files



nachiketdp
06-21-2007, 02:55 AM
Hi all,
I have a directory containing several folders and sub-folders. I want to write a macro for assigning a common read-only and read-write password to all the files in the directory(regardless of the file types).

I already have a code for doing this for excel workbooks. I tried to modify it for all files,but in vain.
Can anyone help me on this? Following is the aforesaid code for excel workbooks.



Sub Password_assigner()
Dim strDirectory As String, bSubFolders As Boolean
Dim fs As FileSearch, i As Long, strPW As String, strPWRW As String
Dim wb As Files, wbFF As Files
Dim iSubs As Integer
Dim ws As Worksheet
pq = 1
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set wb = ThisWorkbook
bSubFolders = False
Set fs = Application.FileSearch
strDirectory = GetFolder()
iSubs = MsgBox("Include Workbooks in sub-folders?", vbYesNo, "Sub-Folders")
If iSubs = vbYes Then bSubFolders = True
With fs
.LookIn = strDirectory
.SearchSubFolders = bSubFolders
.FileType = msoFileTypeExcelWorkbooks
If .Execute > 0 Then
strPW = Application.InputBox("Enter read-only password to apply", "Read-only Password", Type:=2)
strPWRW = Application.InputBox("Enter read-write password to apply", "Read-write Password", Type:=2)
ThisWorkbook.Worksheets("Error").Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
For i = 1 To .FoundFiles.Count
nameoffile = .FoundFiles(i)
On Error GoTo errorhandler
Set wbFF = Workbooks.Open(.FoundFiles(i), UpdateLinks:=False, ReadOnly:=False, Password:="")
If gprs = 1004 Then gprs = 0: GoTo bnu9
wbFF.SaveAs .FoundFiles(i), , Password:=strPW, writerespassword:=strPWRW
wbFF.Close
Set wbFF = Nothing
bnu9:
Next i
Else: MsgBox "No Workbooks found": Exit Sub
End If
End With
ThisWorkbook.Worksheets("Error").Cells(1, 1).Value = "Files to which password could not be assigned"
If pq = 1 Then ThisWorkbook.Worksheets("Error").Cells(2, 1).Value = "Not a single file"
ThisWorkbook.Worksheets("Error").Cells(1, 1).Font.bold = True
Application.ScreenUpdating = True
MsgBox "Operation Completed"
Exit Sub
errorhandler:
If Err.Number = 1004 Then
pq = pq + 1
ThisWorkbook.Worksheets("Error").Cells(pq, 1).Value = nameoffile
gprs = 1004: Resume Next
Else: Resume
End If
End Sub

Function GetFolder() As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function

Thanks in advance,
Nachiket Pendharkar

Oorang
06-21-2007, 08:02 AM
Not all file types are going to be capable of being password protected.

nachiketdp
06-21-2007, 11:53 PM
Hi Aaron,

Thanks for your reply. I wasn't knowing that it cannot be done for all types of files. Atleast can I achieve it for all MS office files?

Regards,

Nachiket Pendharkar