Skip password protect files and open non protected files

[Boss]

Hi,

I am using the below code to password protect all the files in a folder and
its subfodlers.

The code opens all the files one by one and saves them with a password. If
any file is password protected macro gives me an error.

please help me solve this... I tried with a error handler which will move to
next file on a error but didnt worked properly.



Sub ExecuteListFiles()
Range("A20").Select
Application.ScreenUpdating = False
Application.StatusBar = "Processing... "

Dim strpathfile As String
strpathfile = Range("c6").Value 'sets path
Call ListFilesInFolder(strpathfile, True)

Application.ScreenUpdating = True
Application.StatusBar = ""
Range("A1").Select
MsgBox ("Done with all files"), vbExclamation
End Sub
Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As
Boolean)
Dim FSO As New FileSystemObject, SourceFolder As Folder, Subfolder As
Folder, FileItem As File
Dim lngCount As Long, strSQL As String
Dim pptfile As Object
Dim ws As Worksheet

Set SourceFolder = FSO.GetFolder(SourceFolderName)
For Each FileItem In SourceFolder.Files
ActiveCell.Value = FileItem
ActiveCell.Offset(1, 0).Select
Select Case Right(FileItem.Name, 3) ' finds extension of file


'******************************** Excel ************************************
Case "xls" ' finds excel file
Application.DisplayAlerts = False
Workbooks.Open (FileItem), Password:=""

For Each ws In ActiveWorkbook.Worksheets
With ws.PageSetup
.LeftFooter = "&BData Classification : Highly Confidential&B"
End With
Next ws
' password for excel
ActiveWorkbook.SaveAs FileName:=FileItem, FileFormat:=xlNormal,
Password:="test", _
WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Close savechanges:=True
Application.DisplayAlerts = True

End Select
' loop in folders and sub folders
lngCount = lngCount + 1
Next FileItem
If IncludeSubfolders Then
For Each Subfolder In SourceFolder.SubFolders
ListFilesInFolder Subfolder.path, True
Next Subfolder
End If
Set FileItem = Nothing
Set SourceFolder = Nothing

End Sub


Thx!

 

[Boss]

Thanks a lot for helping me on this.

But still i am unable to solve this... Please let me know what changes
should i do in the code so that it skips the file with password and open only
those file which does not have a password.

the error hander is passing an error in second file.

thx!

 

[Boss]

Thx for the reply...

The error handler catches the error on first file and goes to the next item.
In the second file it fails to catch the error and code debugs.

How do we reset the errr handler. Please help

Thx!

 

[Boss]

Thanks Joel,

But still i am stuck up.

when i initially posted the code it was working for first file and not for
the second file.
If clearing the err is not the issue what changes should i make in the code.
I have not added resume to the err handler. Please hlep.

Thx!

 

[Boss]

Hi,

Really stuck up with this now...

This code below protectes all the .doc, .xls, .ppt files in folder and its
subfolders.
If the files are already protected then it skips only first file and debugs
on second.


please help.. this is something very ungent for me...

Thx!


Sub ExecuteListFiles()
Range("A20").Select
Application.ScreenUpdating = False
Application.StatusBar = "Processing... "

Dim strpathfile As String
strpathfile = Range("c6").Value 'sets path
Call ListFilesInFolder(strpathfile, True)

Application.ScreenUpdating = True
Application.StatusBar = ""
lnggCount = Range("A1").Value
Range("A1").Select
Range("A1").ClearContents
MsgBox ("Password protected " & lnggCount & " files"), vbExclamation
End Sub
Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As
Boolean)
Dim FSO As New FileSystemObject, SourceFolder As Folder, Subfolder As
Folder, FileItem As File
Dim lngCount As Long, strSQL As String
Dim pptfile As Object
Dim ws As Worksheet
Set SourceFolder = FSO.GetFolder(SourceFolderName)
On Error GoTo err
For Each FileItem In SourceFolder.Files
ActiveCell.Value = FileItem
ActiveCell.Offset(1, 0).Select

Select Case Right(FileItem.Name, 3) ' finds extension of file

'******************************** Word ************************************
Case "doc" ' finds word file
Set docfile = CreateObject("Word.Application")
'docfile.Visible = True
docfile.Documents.Open (FileItem), Password:=""


With docfile.ActiveDocument
.Password = "test" ' word password
End With

docfile.ActiveDocument.Close
docfile.Quit

'******************************** power point
************************************
Case "ppt" ' finds powerpoint file
Set pptfile = CreateObject("powerpoint.application")
pptfile.Visible = True
Set pShow = pptfile.Presentations.Open(FileItem)

With pShow
.Password = "test" ' ppt password
.SaveAs FileItem
.Close
End With
pptfile.Quit

'******************************** Excel ************************************
Case "xls" ' finds excel file

'Application.DisplayAlerts = False
Workbooks.Open (FileItem), Password:=""

For Each ws In ActiveWorkbook.Worksheets
With ws.PageSetup
.LeftFooter = "&BData Classification : Highly Confidential&B"
End With
Next ws
' password for excel
ActiveWorkbook.SaveAs FileName:=FileItem, FileFormat:=xlNormal,
Password:="test", _
WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Close savechanges:=True
'Application.DisplayAlerts = True

End Select
' loop in folders and sub folders

lngCount = lngCount + 1
err:
Next FileItem
If IncludeSubfolders Then
For Each Subfolder In SourceFolder.SubFolders
ListFilesInFolder Subfolder.path, True
Next Subfolder
End If
Set FileItem = Nothing
Set SourceFolder = Nothing
Range("a1").Value = lngCount

End Sub


End Function

I just checked the Err.Clear help file and it says it is not needed
because the Resume will automatically clear the error. Try removing the
Err.Clear it may have negative side effects.


--
joel
------------------------------------------------------------------------
joel's Profile: http://www.thecodecage.com/forumz/member.php?userid=229
View this thread: http://www.thecodecage.com/forumz/showthread.php?t=157418

Microsoft Office Help

.

 

[Boss]

Thanks Joel... You helped me a lot... The code works fine now...