Trying to set this code found Here to work recursively down through my folders. at the minute I have this
Public Sub addPassword()
Dim FSO As Object
Dim strFileName As String
Dim strFilePath As String
Dim folder As Object, subfolder As Object
Dim doc As Object
Dim oDoc As Document
Dim PWD As String
Set FSO = CreateObject("Scripting.FileSystemObject")
folderPath = "G:\Test Data"
Set folder = FSO.GetFolder(folderPath)
PWD = "FooBar"
For Each doc In folder.Files
strFilePath = "G:\Test Data\"
strFileName = Dir$(strFilePath & "*.doc*")
Set oDoc = Documents.Open( _
FileName:=strFilePath & strFileName, _
PasswordDocument:="FooBar")
oDoc.Saved = False
oDoc.SaveAs2 FileName:=strFilePath & strFileName, _
Password:=PWD
oDoc.Close
Set oDoc = Nothing
Next
For Each subfolder In folder.SubFolders
For Each doc In subfolder.Files
strFilePath = "G:\Test Data\"
strFileName = Dir$(strFilePath & "*.doc*")
Set oDoc = Documents.Open( _
FileName:=strFilePath & strFileName, _
PasswordDocument:="FooBar")
oDoc.Saved = False
oDoc.SaveAs2 FileName:=strFilePath & strFileName, _
Password:=PWD
oDoc.Close
Set oDoc = Nothing
Next
Next
End Sub
Absolute Novice to vba so trying to use some limited python experience to set this up recursively. I can see every file open up in the side but when I go to check on them non of them have a password set
Any help would be appreciated thank you
Related
I have many .doc documents located in many subfolders and I would like to covert them to .docx
I was opening each file and saving it but there are too many of them, so I thought there must be a better and a faster way. I found online some VBA code but none seem to work.
First VBA code:
Sub TranslateDocIntoDocx()
Dim objWordApplication As New Word.Application
Dim objWordDocument As Word.Document
Dim strFile As String
Dim strFolder As String
strFolder = "H:\Vanhuspalvelut\Kotihoito\Tammelan_kotihoito\TURVALLISUUS\Pelastussuunnitelmaan_tuleva\TURVALLISUUS_SUUNNITELMA_2015"
strFile = Dir(strFolder & "*.doc", vbNormal)
While strFile <> ""
With objWordApplication
Set objWordDocument = .Documents.Open(FileName:=strFolder & strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
With objWordDocument
.SaveAs FileName:=strFolder & Replace(strFile, "doc", "docx"), FileFormat:=16
.Close
End With
End With
strFile = Dir()
Wend
Set objWordDocument = Nothing
Set objWordApplication = Nothing
End Sub
Second VBA code:
Sub ConvertBatchToDOCX()
Dim sSourcePath As String
Dim sTargetPath As String
Dim sDocName As String
Dim docCurDoc As Document
Dim sNewDocName As String
' Looking in this path
sSourcePath = "H:\Vanhuspalvelut\Kotihoito\Tammelan_kotihoito\TURVALLISUUS\Pelastussuunnitelmaan_tuleva\TURVALLISUUS_SUUNNITELMA_2015"
sTargetPath = "H:\Vanhuspalvelut\Kotihoito\Tammelan_kotihoito\TURVALLISUUS\Pelastussuunnitelmaan_tuleva\TURVALLISUUS_SUUNNITELMA_2015"
' Look for first DOC file
sDocName = Dir(sSourcePath & "*.doc")
Do While sDocName <> ""
' Repeat as long as there are source files
'Only work on files where right-most characters are ".doc"
If Right(sDocName, 4) = ".doc" Then
' Open file
Set docCurDoc = Documents.Open(FileName:=sSourcePath & sDocName)
sNewDocName = Replace(sDocName, ".doc", ".docx")
With docCurDoc
.SaveAs FileName:=sTargetPath & sNewDocName, _
FileFormat:=wdFormatDocumentDefault
.Close SaveChanges:=wdDoNotSaveChanges
End With
End If
' Get next source file name
sDocName = Dir
Loop
MsgBox "Finished"
End Sub
Any help would be much appreciated!
In both routines you have the same small mistake: You miss a Backslash between the path and the filename. Your Dir-Command will see the following command and therefore doesn't find anything:
Dir("H:\Vanhuspalvelut\Kotihoito\Tammelan_kotihoito\TURVALLISUUS\Pelastussuunnitelmaan_tuleva\TURVALLISUUS_SUUNNITELMA_2015*.doc", vbNormal
Either add the backslash at the end of the path definition:
strFolder = "H:\Vanhuspalvelut\Kotihoito\Tammelan_kotihoito\TURVALLISUUS\Pelastussuunnitelmaan_tuleva\TURVALLISUUS_SUUNNITELMA_2015\"
or put it into the Dir-command:
strFile = Dir(strFolder & "\*.doc", vbNormal)
I am creating a new database for where I work. It is creating quotes for jobs. When I click the save button its save the quote and opens a new folder which gets its name from three fields on the form. I want it to import or copy files from another folder in the directory to the newly created folder.
I have tried to use the copyfolder function and it does copy the files but to the main folder where all the quotes are held and not into the newly created folder.
On Error GoTo btnOK_Click_Error
Const strParent = "C:\Users\r.jones\Desktop\Quotes\ "
Dim Strquotenumber As String
Dim Strsite As String
Dim StrprojDesc As String
Dim strFolder As String
Dim Strspace As String
Strspace = Space(1) & "- "
Strquotenumber = Me.QuoteNumber
Strsite = Me.Txtsite
StrprojDesc = Me.Project_Description
strFolder = strParent & Strquotenumber & Strspace & Strsite & Strspace & StrprojDesc
If Dir(strFolder, vbDirectory) = "" Then MkDir strFolder
Shell "explorer.exe " & strFolder, vbNormalFocus
If Me.Dirty Then DoCmd.RunCommand acCmdSaveRecord
DoCmd.Close acForm, Me.Name
DoCmd.OpenForm "Frmquotebook"
btnOK_Click_Exit:
Exit Sub
btnOK_Click_Error:
MsgBox "Error" & " In Attempting To Create New Folder. All Fields Must Be Filled In." & vbCrLf_
Cancel = True
Resume btnOK_Click_Exit
Is it possible to do this as I have not been able to find anything on it.
Thanks for the help.
Here are some file system routines I use, wrapping the Scripting.FileSystemObject Object:
Public Function FileExists(FileName As String) As Boolean
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
FileExists = fso.FileExists(FileName)
End Function
Public Sub DeleteFile(FileName As String)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If FileExists(FileName) Then fso.DeleteFile FileName, True
End Sub
Public Sub CopyFile(Source As String, Destination As String, Optional force As Boolean = False)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If FileExists(Source) Then
fso.CopyFile Source, Destination, force
End If
End Sub
Public Sub CreateFolder(Folder As String)
Dim fso As Object
Dim Position As Integer
Dim TempFolder As String
Dim Folders As Object
Dim strArr() As String
Dim i As Integer
Position = 0
TempFolder = ""
strArr = Split(Folder, "\")
Set fso = CreateObject("Scripting.FileSystemObject")
For i = 0 To UBound(strArr)
If Not fso.FolderExists(TempFolder & strArr(i) & "\") Then
Set Folders = fso.GetFolder(TempFolder).subFolders
Folders.Add (strArr(i))
End If
TempFolder = TempFolder & strArr(i) & "\"
Next
End Sub
You will need to iterate over each file in the source directory and cop it over to the destination directory
Sub CopyFilesInDirectoryToFolder(SourceDirectory As String, DestinationDirectory As String)
Dim fileName As String
If Not Right(SourceDirectory, 1) = Application.PathSeparator Then SourceDirectory = SourceDirectory & Application.PathSeparator
If Not Right(DestinationDirectory, 1) = Application.PathSeparator Then DestinationDirectory = DestinationDirectory & Application.PathSeparator
fileName = Dir(SourceDirectory)
Do While Len(fileName) > 0
CopyFile SourceDirectory & fileName, DestinationDirectory & fileName
fileName = Dir()
Loop
End Sub
I have a directory that has 1000's of files. The filename string goes like: ManagerName_EmployeeName_First Assessment.xlsx
but I have a specific type of grouping I need to execute so that I have folders go by ManagerName > Employee Name and then the 5 types of Assessments in the employees folder.
How would I edit this to identify the first _ in the filename (ManagerName) and then make a folder by that ManagerName and then make a subfolder by EmployeeName and then house all five files under that employee in the employee subfolder?
I know you'd need to use a Left(fileName, InStrRev(fileName, "_") > 1) type function to identify the first text string to the left of the first _ but how would I go and create a second subfolder based on the employee under that manager?
Here's a shell of the code I was thinking:
Option Explicit
Sub MoveFiles()
Dim objFSO As Object
Dim objMyFolder As Object
Dim objMyFile As Object
Dim strSourceFolder As String
Dim strDestFolder As String
Application.ScreenUpdating = False
strSourceFolder = "C:\Users\CIB\"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objMyFolder = objFSO.GetFolder(strSourceFolder)
For Each objMyFile In objMyFolder.Files
Do While objMyFile <> ""
strDestFolder = Left(objMyFile.Name, InStrRev(objMyFile, "_") - 1)
If Len(Dir(strDestFolder, vbDirectory)) = 0 Then
MkDir strDestFolder
End If
FileCopy strSourceFolder & "\" & objMyFile.Name, strDestFolder & "\" & objMyFile.Name
Kill strSourceFolder & "\" & objMyFile.Name
Loop
Next objMyFile
Set objFSO = Nothing
Set objMyFolder = Nothing
Application.ScreenUpdating = True
End Sub
I've changed your code accordingly to TimWiliams suggestions:
Option Explicit
Sub MoveFiles()
Dim objFSO As Object
Dim objMyFolder As Object
Dim objMyFile As Object
Dim strSourceFolder As String
Dim strDestFolder As String
Dim parts() As String
Dim i As Integer
Application.ScreenUpdating = False
strSourceFolder = "C:\Users\CIB\"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objMyFolder = objFSO.GetFolder(strSourceFolder)
For Each objMyFile In objMyFolder.Files
If objMyFile Is Nothing Then GoTo SkipNext
parts = Split(objMyFile.Name, "_")
strDestFolder = strSourceFolder
For i = LBound(parts) To UBound(parts) - 1
strDestFolder = strDestFolder & parts(i) & "\"
'if path does not exists, create it
If Not objFSO.FolderExists(strDestFolder) Then objFSO.CreateFolder strDestFolder
FileCopy strSourceFolder & "\" & objMyFile.Name, strDestFolder & "\" & objMyFile.Name
Kill strSourceFolder & "\" & objMyFile.Name
strDestFolder = ""
SkipNext:
Next objMyFile
Set objFSO = Nothing
Set objMyFolder = Nothing
Application.ScreenUpdating = True
End Sub
i currently have 6 mail merge templates that i execute via the following vbs.
this opens each file in the root folder and runs the mailmerge,
VBS
Set fs = CreateObject("Scripting.FileSystemObject")
Set rootFolder = fs.GetFolder(fs.GetParentFolderName(wscript.ScriptFullName))
Set oWord = Createobject("Word.Application")
oWord.Visible = False
For Each file in rootFolder.Files
If LCase(fs.GetExtensionName(file.Name)) = "docx" Then
Set oDocument = oWord.Documents.Open(file.path)
oWord.Run "regular_mail"
oDocument.Close(False)
Set oDocument = Nothing
End If
Next
oWord.Quit
set oWord = nothing
the vba inside word, does the mailmerge puts it in the designated folder, what i get is an error when the datasource for that file has no data. since StrName = .DataFields("pk") wont have any values.
Where im stuck is how to go around that error, or check whether the data source is blank then move on to the next template.
each template should save to one file so my mailroom can print.
VBA in word:
Sub regular_mail()
Dim sDate As String, StrFolder As String, StrName As String, MainDoc As Document, i As Long, j As Long, fso As Object, StrMonthPath As String, StrDayPath As String, StrFileName As String
sDate = Format(Now(), "mmddyy")
Const StrFolderName As String = "C:\Test\Files\"
Set fso = CreateObject("Scripting.FileSystemObject")
With ActiveDocument.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
StrName = .DataFields("pk")
StrMonthPath = .DataFields("month_path")
StrDayPath = .DataFields("day_path")
StrSendDate = .DataFields("send_date")
StrFileName = sDate & "_" & fso.GetBaseName(ActiveDocument.Name)
End With
.Execute Pause:=False
'Creates directory if it doesnt exist
If Not fso.FolderExists(StrFolderName & StrMonthPath) Then
fso.CreateFolder (StrFolderName & StrMonthPath)
End If
If Not fso.FolderExists(StrFolderName & StrMonthPath & StrDayPath) Then
fso.CreateFolder (StrFolderName & StrMonthPath & StrDayPath)
End If
If Not fso.FolderExists(StrFolderName & StrMonthPath & StrDayPath & "letters\") Then
fso.CreateFolder (StrFolderName & StrMonthPath & StrDayPath & "letters\")
End If
End With
ActiveDocument.SaveAs2 FileName:=StrFolderName & StrMonthPath & StrDayPath & "letters\" & StrFileName, FileFormat:=16, AddToRecentFiles:=False
ActiveWindow.Close
End Sub
any and all help is appreciated, thank you in advance.
Without being able to test it myself right now, you could use both or one of these approaches:
You could check it DataSource is nothing (or if is not Nothing, as you need):
If .DataSource Is Nothing Then ...
You could check if there are records in the Datasource:
If .DataSource.RecordCount = 0 Then
Having difficulty getting multi unzip to work with a custom file name. Below is the code, any suggestions greatly appreciated. Have tried GetOpenFilename with no success. The point of where the error occurs is marked below:
Option Explicit
Sub UnzipSelectFiles()
Dim xFileSelect As Variant
Dim xSelectedItem As Variant
Dim xFilePath As String
Dim strDate As String
Dim xFileNameFolder As Variant
Dim xApp As Object
' Set xFileSelect = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
MultiSelect:=True)
Set xFileSelect = Application.FileDialog(msoFileDialogOpen)
With xFileSelect
.AllowMultiSelect = True
.Title = "Select ZIP Compressed Files"
.Filters.Clear
.Filters.Add "Zip Compressed Files", "*.zip"
.InitialView = msoFileDialogViewDetails
If xFileSelect.Show = -1 Then
For Each xSelectedItem In xFileSelect.SelectedItems
xFilePath = xSelectedItem
strDate = Format(Now, " mmm-dd-yyyy hh_mm_ss AMPM")
xFileNameFolder = xFilePath & strDate & "\"
Debug.Print xFileNameFolder
MkDir xFileNameFolder
Set xApp = CreateObject("Shell.Application")
'~~~~>
'Runtime error #91 Object variable or with block variable not set
xApp.Namespace(xFileNameFolder).CopyHere xApp.Namespace(xFileSelect).Items
'~~~~>
Next xSelectedItem
End If
End With
Set xApp = Nothing
End Sub