I have a folder of ~20 *.potx files and I would like to convert all *.potx files to *.pptx, then delete the *.potx files.
The following will loop through all your templates, convert, and delete the template files.
Sub loopFiles()
Dim fso As New FileSystemObject
Dim fil As File
Dim fold As Folder
Set fold = fso.GetFolder(yourFolder)
For Each fil In fold.Files
If InStr(1, fil.Name, ".potx") > 0 Then
Application.Presentations.Open fil.Path
ActivePresentation.SaveAs Replace(fil.Path, ".potx", ".pptx"), ppSaveAsDefault
ActivePresentation.Close
'if you truly want to delete them, don't recommend since they are .potx
fil.Delete True
End If
Next fil
End Sub
You could try something like this: (replace YOUR FOLDER HERE with your folder name)
Public Sub ConvertPP()
Dim pApp As Object
Set pApp = CreateObject("Powerpoint.Application")
Dim sFile As String
Dim sFolder As String
sFolder = "YOUR FOLDER HERE"
sFile = Dir(sFolder & "\*.potx")
Do Until sFolder = ""
pApp.Presentations.Open sFolder & "\" & sFile
pApp.ActivePresentation.SaveAs sFolder & "\" & Replace(sFile, "potx", "pptx"), 11
pApp.ActivePresentation.Close
sFile = Dir()
Loop
pApp.Quit
Set pApp = Nothing
End Sub
Related
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 folder which has a bunch of .xls files, of which only those which have the KEY Word " CITIES " are of interest to me. I need to open those files and collect some information and I am facing some issues.
Sub getTheExecSummary()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
myPath = "C:\Users\Morpheus\Documents\Projects\Files"
myExtension = "*.xls" 'How to add the keyword?'
myFile = Dir(myPath & myExtension)
Do While Len(myFile) > 0
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
Debug.Print (myFile)
Debug.Print (wb.Name)
ActiveSheet.Range("A1").Value = wb.Name
'Get next file name
myFile = Dir
Loop
End Sub
I did write a few Debug.Print statements none of which seem to work. I want to for now print only those workbooks which have the keyword ' CITIES ' in their name.
I think that you want the Instr function.
If Instr(wb.Name, "CITIES") > 0 then .....
You might want to use "CITIES " or " CITIES " to exclude any unintentional uses of those letters, depending on how the filename is setup
Use the wildcard to identify the missing letters: *CITIES*.xls or *CITIES*.xls* if you're expecting xlsx, xlsm, etc.
Sub Test()
Dim colFiles As Collection
Dim vItem As Variant
Dim wrkBk As Workbook
Dim sPath As String
Set colFiles = New Collection
sPath = "C:\Users\Morpheus\Documents\Projects\Files\"
'you could use:
'sPath = Environ("UserProfile") & "\Documents\Projects\Files\"
EnumerateFiles sPath, "*CITIES*.xls", colFiles
For Each vItem In colFiles
Set wrkBk = Workbooks.Open(vItem)
wrkBk.Worksheets("Sheet1").Range("A1") = wrkBk.Name
Next vItem
End Sub
Sub EnumerateFiles(ByVal sDirectory As String, _
ByVal sFileSpec As String, _
ByRef cCollection As Collection)
Dim sTemp As String
sTemp = Dir$(sDirectory & sFileSpec)
Do While Len(sTemp) > 0
cCollection.Add sDirectory & sTemp
sTemp = Dir$
Loop
End Sub
On a monthly basis I have to aggregate daily files. The issue is I need the files to be in "TXT", but they are sent to me as "WRI".
I am able to do one file at a time if it is hardcoded with the following.
Name "C:\Users\John\Desktop\Folder1\SQLEXEC.WRI" As "C:\Users\John\Desktop\Folder1\SQLEXEC.TXT"
However, I want to be able to loop through the folder. But I am not sure how to change the code to allow it to loop.
Sub ConvertToTXT()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim strPath As String
Dim strFile As String
strPath = "C:\Users\John\Desktop\Folder1\" strFile = Dir(strPath & "*.wri")
Do While strFile <> ""
Name "C:\Users\John\Desktop\Folder1\SQLEXEC.WRI" As "C:\Users\John\Desktop\Folder1\SQLEXEC.TXT"
Loop
End Sub
I'd personally use the Scripting.FileSystemObject for this - it's much less prone to errors than manually building filepath strings. You'll need to add a reference to Microsoft Scripting Runtime:
Private Sub ConvertToTXT(filePath As String)
With New Scripting.FileSystemObject
Dim directory As Folder
Set directory = .GetFolder(filePath)
Dim target As File
For Each target In directory.Files
If LCase$(.GetExtensionName(target.Name)) = "wri" Then
Dim newName As String
newName = .BuildPath(filePath, .GetBaseName(target.Name)) & ".txt"
.MoveFile target.Path, newName
End If
Next
End With
End Sub
Call it by passing it the directory you want to perform the renaming in:
ConvertToTXT "C:\Users\John\Desktop\Folder1"
Note that is doesn't care if there's a trailing \ or not - this also works:
ConvertToTXT "C:\Users\John\Desktop\Folder1\"
Sub ConvertToTXT()
Const strPath As String = "C:\Users\John\Desktop\Folder1"
Dim strFile As String
Application.DisplayAlerts = False
Application.ScreenUpdating = False
strFile = Dir(strPath & "\" & "*.wri")
Do While strFile <> ""
Name strPath & "\" & strFile As strPath & "\" & Replace(strFile, ".wri", ".txt")
strFile = Dir
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub ReplaceEntireHdr()
Dim wrd As Word.Application
Set wrd = CreateObject("word.application")
wrd.Visible = True
AppActivate wrd.Name
'Change the directory to YOUR folder's path
fName = Dir("C:\Users\user1\Desktop\A\*.doc")
Do While (fName <> "")
With wrd
'Change the directory to YOUR folder's path
.Documents.Open ("C:\Users\user1\Desktop\A\" & fName)
If .ActiveWindow.View.SplitSpecial = wdPaneNone Then
.ActiveWindow.ActivePane.View.Type = wdPrintView
Else
.ActiveWindow.View.Type = wdPrintView
End If
.ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
.Selection.WholeStory
.Selection.Paste
.ActiveDocument.Save
.ActiveDocument.Close
End With
fName = Dir
Loop
Set wrd = Nothing
End Sub
I use this vba code to replace all the headers, of all the word documents in a folder 'A'. However if there is any subfolder in the parent folder 'A' with word documents, the vba code skips those documents. Could anyone please tell me how to include the word documents in the subfolders as well? Perhaps by making some changes in the code or any other vba code which can do the same job.
Thanks in advance.
In order to pick up the folders (directories) you need to specify the vbDirectory attribute. By default, Dir only "sees" things that match vbNormal.
Here's an example that picks up both files and sub-directories. The GetAttr function checks whether the file attribute is vbDirectory. If it's not, then it's a file.
What you can do is save the directory paths in an array, then loop that to get the files in the sub-directories.
Sub GetFilesandSubDir()
Dim sPath As String, sPattern As String
Dim sSearch As String, sFile As String
Dim sPathSub As String, sSearchSub As String
Dim aSubDirs As Variant, i As Long
sPattern = "*.*"
sPath = "C:\Test\"
sSearch = sPath & sPattern
sFile = Dir(sPath, vbNormal + vbDirectory)
aSubDirs = TestDirWithSubFolders(sPath, sPattern, sSearch, sFile)
For i = LBound(aSubDirs) To UBound(aSubDirs)
Debug.Print "Directory: " & aSubDirs(i)
sPathSub = sPath & aSubDirs(i) & "\"
sSearchSub = sPathSub & sPattern
sFile = Dir(sPathSub, vbNormal + vbDirectory)
TestDirWithSubFolders sPathSub, sPattern, sSearchSub, sFile
Next
End Sub
Function TestDirWithSubFolders(sPath As String, sPattern As String, _
sSearch As String, sFile As String) As Variant
Dim aSubDirs() As Variant, i As Long
i = 0
Do While sFile <> ""
If GetAttr(sPath & sFile) = vbDirectory Then
'Debug.Print "Directory: " & sFile
ReDim Preserve aSubDirs(i)
aSubDirs(i) = sFile
i = i + 1
Else
Debug.Print "File: " & sFile
End If
sFile = Dir
Loop
TestDirWithSubFolders = aSubDirs
End Function
I currently have coded how to open all files in a certain folder
Dim MyFolder As String
Dim MyFile As String
MyFolder = "K:\Data Directories\Acquisitions"
MyFile = Dir(MyFolder & "\*.xlsx")
Do While Len(MyFile) > 0
Workbooks.Open FileName:=MyFolder & "\" & MyFile
MyFile = Dir
Loop
Now I'm trying to open all files in multiple folders that have the same name.
For instance:
Dim MyFolder As String
Dim MyFile As String
Dim MyFolder2 As String
MyFolder = "K:\Data Directories\Acquisitions"
MyFolder2 = MyFolder & "*\June 2015"
MyFile = Dir(MyFolder2 & "\*.xlsx")
Do While Len(MyFile) > 0
Workbooks.Open FileName:=MyFolder2 & "\" & MyFile
MyFile = Dir
Loop
The problem is the * that I place before June 2015. It comes out as an actual "*" in the path code instead of a wildcard.
The code is meant to choose all folders in the Acquisition directory, and then look inside them for a June 2015 folder. From there, all the Excel files in these multiple June 2015 folders should be opened. What am I doing wrong?
I think this will do what you want. Give it a try and see what happens.
Sub DoFolderPart1()
Dim FileSystem As Object
Dim HostFolder As String
HostFolder = "K:\Data Directories\Acquisitions"
Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder FileSystem.GetFolder(HostFolder)
End Sub
Sub DoFolder(Folder)
Dim SubFolder
Dim strName As String
Dim pos As Integer
For Each SubFolder In Folder.SubFolders
DoFolder SubFolder
Next
Dim File
strName = Folder.name
pos = InStr(strName, "June 2015")
If pos > 0 Then
For Each File In Folder.Files
If Right(File, 4) = "xlsx" Then
Workbooks.Open Filename:=File
End If
Next
End If
End Sub
I based my answer on this loop-through-all-subfolders-using-vba