brianlois
03-12-2005, 02:30 PM
Hello,
I am using SendKeys in my script to password protect the VBA project in each Excel file that I open, however the script stops at "SendKeys "e", Wait: DoEvents". Any ideas why the script is stopping, or how I can modify it to password protect each VBA project that I open? Thank you
Sub FindClientExcelFiles()
Dim FS As Office.FileSearch
Dim vaFileName As Variant
Dim startdir
Dim enddir
Dim Foo As Object
Dim iCount As Long
Dim newname As Variant
Dim fsoObj As Object, TheDate As String
Dim strPassWord As String
Dim commandbars As CommandBar
TheDate = Format(Date, "YYYYMMDD")
startdir = "C:\Temp\1"
enddir = ("C:\Temp\" & TheDate & "\")
strPassWord = "123"
Set fsoObj = CreateObject("Scripting.FileSystemObject")
With fsoObj
If Not .FolderExists(enddir) Then
.CreateFolder (enddir)
End If
End With
Set FS = Application.FileSearch
With FS
'Clear old search criteria
.NewSearch
'Directory to search
.LookIn = startdir
'Include sub folders in search
.SearchSubFolders = True
'Look for Excel files
.FileType = msoFileTypeExcelWorkbooks
iCount = .Execute
For Each vaFileName In .FoundFiles
If FileDateTime(vaFileName) < Now() - 2 / (24 * 60) Then
Set Foo = Workbooks.Open(vaFileName)
With Foo.VBProject.VBE.MainWindow
'.Visible = True
.SetFocus
SendKeys "%t", Wait: DoEvents
SendKeys "e", Wait: DoEvents
SendKeys "^{TAB}", Wait: DoEvents
SendKeys "%v", Wait: DoEvents
SendKeys "{TAB}", Wait: DoEvents
SendKeys strPassWord, Wait: DoEvents
SendKeys "{TAB}", Wait: DoEvents
SendKeys strPassWord, Wait: DoEvents
SendKeys "{TAB}", Wait: DoEvents
SendKeys "~", Wait: DoEvents
End With
'.Close True
Application.DisplayAlerts = False
Foo.SaveAs enddir & Foo.Name
Foo.Close
Application.DisplayAlerts = True
Kill vaFileName
End If
Next vaFileName
End With
End Sub
I am using SendKeys in my script to password protect the VBA project in each Excel file that I open, however the script stops at "SendKeys "e", Wait: DoEvents". Any ideas why the script is stopping, or how I can modify it to password protect each VBA project that I open? Thank you
Sub FindClientExcelFiles()
Dim FS As Office.FileSearch
Dim vaFileName As Variant
Dim startdir
Dim enddir
Dim Foo As Object
Dim iCount As Long
Dim newname As Variant
Dim fsoObj As Object, TheDate As String
Dim strPassWord As String
Dim commandbars As CommandBar
TheDate = Format(Date, "YYYYMMDD")
startdir = "C:\Temp\1"
enddir = ("C:\Temp\" & TheDate & "\")
strPassWord = "123"
Set fsoObj = CreateObject("Scripting.FileSystemObject")
With fsoObj
If Not .FolderExists(enddir) Then
.CreateFolder (enddir)
End If
End With
Set FS = Application.FileSearch
With FS
'Clear old search criteria
.NewSearch
'Directory to search
.LookIn = startdir
'Include sub folders in search
.SearchSubFolders = True
'Look for Excel files
.FileType = msoFileTypeExcelWorkbooks
iCount = .Execute
For Each vaFileName In .FoundFiles
If FileDateTime(vaFileName) < Now() - 2 / (24 * 60) Then
Set Foo = Workbooks.Open(vaFileName)
With Foo.VBProject.VBE.MainWindow
'.Visible = True
.SetFocus
SendKeys "%t", Wait: DoEvents
SendKeys "e", Wait: DoEvents
SendKeys "^{TAB}", Wait: DoEvents
SendKeys "%v", Wait: DoEvents
SendKeys "{TAB}", Wait: DoEvents
SendKeys strPassWord, Wait: DoEvents
SendKeys "{TAB}", Wait: DoEvents
SendKeys strPassWord, Wait: DoEvents
SendKeys "{TAB}", Wait: DoEvents
SendKeys "~", Wait: DoEvents
End With
'.Close True
Application.DisplayAlerts = False
Foo.SaveAs enddir & Foo.Name
Foo.Close
Application.DisplayAlerts = True
Kill vaFileName
End If
Next vaFileName
End With
End Sub