Adding the ability to scan subfolders of the chosen parent folder ?

[gtalk7879]

I have tried but I can't figure it out. The below will remove passwords from Word documents in the chosen folder but will not continue through subfolders.
I have pasted the original code that I started with.


Option Explicit
Dim strFileName As String
Dim sCurPath As String

Function GetPath()
Dim sPath As FileDialog

Set sPath = Application.FileDialog(msoFileDialogFolderPicker)
GetPath = ""

With sPath
.Show
sCurPath = .SelectedItems(1) & "\"
End With

Set sPath = Nothing

End Function


Sub OpenFiles(sFN As String, sPN As String, sCurPwd As String)
Dim WordApp As Word.Application

On Error GoTo CheckErr
Set WordApp = CreateObject("Word.Application")

WordApp.Visible = True
WordApp.Documents.Open sFN & sPN, False, False, False, sCurPwd

WordApp.DisplayAlerts = wdAlertsNone
With WordApp.ActiveDocument
.ReadOnlyRecommended = False
.Password = ""
.WritePassword = ""
.RemovePersonalInformation = False
End With

With Options
.WarnBeforeSavingPrintingSendingMarkup = False
.StoreRSIDOnSave = True
End With

WordApp.Documents.Save
WordApp.Documents.Close
WordApp.Quit

Exit Sub
CheckErr:
'MsgBox Err.Description, vbCritical, "Error..."

WordApp.Quit
End Sub


Sub Starter()
Dim strFilePath As String
Dim sCurPwd As String
Dim strFileName As String

On Error GoTo CheckErr
'Start:
GetPath
sCurPwd = InputBox("Please, enter the current password...", "Password...")
strFilePath = sCurPath
strFileName = Dir$(strFilePath & "*.doc")

While Len(strFileName) <> 0
Call OpenFiles(sCurPath, strFileName, sCurPwd)
strFileName = Dir$()
Wend

Exit Sub

CheckErr:

End Sub

[snb]

Pleas use code tags around VBA code !


Sub M_snb()
With Application.FileDialog(4)
.Show
c00 = .SelectedItems(1)
End With

sp = Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & c00 & "\*.doc"" /b/s").stdout.readall, vbCrLf)

For j = 0 To UBound(sp)
With GetObject(sp(j))
' your changes
.Close -1
End With
Next
End Sub

[gtalk7879]

I'm not certain where this fits in. Can you show me further ?

Thank you

[gmaxey]

It happens to "fit" a pattern of concise yet cryptic code snippets which snb is fond of posting and often will cause a compile or run-time error. In this case, if you use a OptionExplicit statement it will cause both.

Regardless, his use of Split and scripting statements are, IMHO, quite neat and will loop though subfolders. Maybe this will help make it more meaningful.



Sub M_snb()
Dim oDoc As Document
Dim strFolder As String
Dim varFiles
Dim lngIndex As Long
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
strFolder = .SelectedItems(1)
End With
varFiles = Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & strFolder & "\*.doc"" /b/s").stdout.readall, vbCrLf)
For lngIndex = 0 To UBound(varFiles) - 1
Set oDoc = GetObject(varFiles(lngIndex))
Debug.Print oDoc.FullName
'Add your code to process the document.
oDoc.Close wdDoNotSaveChanges 'or wdSaveChanges
Next
End Sub

[gtalk7879]

I know I'm butchering this. I'm getting a message about no active document being found.


Sub M_snb()
Dim oDoc As Document
Dim strFolder As String
Dim varFiles
Dim lngIndex As Long
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
strFolder = .SelectedItems(1)
End With
sCurPwd = InputBox("Please, enter the current password...", "Password...")
varFiles = Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & strFolder & "\*.docx"" /b/s").stdout.readall, vbCrLf)
For lngIndex = 0 To UBound(varFiles) - 1
Set oDoc = GetObject(varFiles(lngIndex))
Debug.Print oDoc.FullName
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
WordApp.Documents.Open sFN & sPN, False, False, False, sCurPwd

WordApp.DisplayAlerts = wdAlertsNone
With WordApp.ActiveDocument
.ReadOnlyRecommended = False
.Password = ""
.WritePassword = ""
.RemovePersonalInformation = False
End With

With Options
.WarnBeforeSavingPrintingSendingMarkup = False
.StoreRSIDOnSave = True
End With
oDoc.Close wdSaveChanges
Next
End Sub

[gmaxey]

Sub M_snb()
Dim oDoc As Document
Dim strFolder As String
Dim varFiles
Dim lngIndex As Long
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
strFolder = .SelectedItems(1)
End With
sCurPwd = InputBox("Please, enter the current password...", "Password...")
varFiles = Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & strFolder & "\*.docx"" /b/s").stdout.readall, vbCrLf)
For lngIndex = 0 To UBound(varFiles) - 1
'This should be opening the document.
Set oDoc = GetObject(varFiles(lngIndex))
With oDoc
'Set WordApp = CreateObject("Word.Application")
'WordApp.Visible = True
'WordApp.Documents.Open sFN & sPN, False, False, False, sCurPwd
'WordApp.DisplayAlerts = wdAlertsNone
'With WordApp.ActiveDocument
.ReadOnlyRecommended = False
.Password = ""
.WritePassword = ""
.RemovePersonalInformation = False
.Close wdSaveChanges
End With
Next
End Sub

[gtalk7879]

It's working partially. sCurPwd is not being passed when opening the file/s so there is a prompt.

[gmaxey]

You might try:


Sub M_snb()
Dim oDoc As Document
Dim oObj
Dim strFolder As String
Dim varFiles
Dim lngIndex As Long
Dim sCurPwd
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
strFolder = .SelectedItems(1)
End With
sCurPwd = InputBox("Please, enter the current password...", "Password...")
varFiles = Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & strFolder & "\*.docx"" /b/s").stdout.readall, vbCrLf)
For lngIndex = 0 To UBound(varFiles) - 1
'This should be opening the document.
Set oObj = GetObject(varFiles(lngIndex))
Set oDoc = Documents.Open(oObj.FullName, False, False, False, sCurPwd)
With oDoc
'Set WordApp = CreateObject("Word.Application")
'WordApp.Visible = True
'WordApp.Documents.Open sFN & sPN, False, False, False, sCurPwd
'WordApp.DisplayAlerts = wdAlertsNone
'With WordApp.ActiveDocument
.ReadOnlyRecommended = False
.Password = ""
.WritePassword = ""
.RemovePersonalInformation = False
.Close wdSaveChanges
End With
Next
End Sub

[gtalk7879]

It appears that this line " Set oObj = GetObject(varFiles(lngIndex)) " is trying to open the first .docx file in the directory and not waiting until the next line.
I've attempted to figure it out but no luck.

[gmaxey]

Try:


Option Explicit
Sub ProcessDocFilesInFolderAndSubFolders()
Dim oDoc As Document
Dim strFolder As String
Dim varFiles
Dim lngIndex As Long
Dim strPassword As String
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
strFolder = .SelectedItems(1)
End With
strPassword = InputBox("Please, enter the current password...", "Password...")
varFiles = Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & strFolder & "\*.doc"" /b/s").stdout.readall, vbCrLf)
For lngIndex = 0 To UBound(varFiles) - 1
'This should be opening the document (not visible).
Set oDoc = Documents.Open(varFiles(lngIndex), False, False, False, strPassword, , , , , , , False)
With oDoc
.ReadOnlyRecommended = False
.Password = ""
.WritePassword = ""
.RemovePersonalInformation = False
.Close wdSaveChanges
End With
Next
Application.ScreenUpdating = True
End Sub

[gtalk7879]

Still not working. It doesn't seem to be opening anything, no passwords removed either. I tried stepping through but I don't see where it's failing.
It should also skip files that don't have a password and hopefully remove passwords from both .doc and .docx.

[gmaxey]

I ran the following on a simple folder on my desktop that contained a few files and subfolders with files. One of the files was password protected. I can't address your code for removing the password (I've never tried), but the following is definitely opening each document in the folder and sub-folders:


Sub ProcessDocFilesInFolderAndSubFolders()
Dim oDoc As Document
Dim strFolder As String
Dim varFiles
Dim lngIndex As Long
Dim strPassword As String
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
strFolder = .SelectedItems(1)
End With
strPassword = InputBox("Please, enter the current password...", "Password...")
varFiles = Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & strFolder & "\*.doc"" /b/s").stdout.readall, vbCrLf)
For lngIndex = 0 To UBound(varFiles) - 1
'This should be opening the document (not visible).
Set oDoc = Documents.Open(varFiles(lngIndex), False, False, False, strPassword, , , , , , , False)
With oDoc
MsgBox .FullName
.Close wdSaveChanges
End With
Next
Application.ScreenUpdating = True
End Sub