I have created a sub that will unzip files from a zipped folder
Private Sub UnZipFile(Folder As String, FileName As String)
Dim oSHApp, oSHFolder ' as object
Dim sSrc, sDest ' as string
Dim fName As String
Set oSHApp = CreateObject("Shell.Application")
sSrc = Folder & FileName
sDest = Folder
Set oSHFolder = oSHApp.Namespace(sSrc)
oSHApp.Namespace(sDest).CopyHere oSHFolder.Items
End Sub
I would like to rename the oSHFolder.Items once it's extracted , what would be the most optimized way ?
EDIT : the file name is not static and I cannot know it names in advance
Thank you
Since you have only one file, it's just one line more:
Const FinalName As String = "YourFileName.txt"
<snip>
Set oSHFolder = oSHApp.Namespace(sSrc)
oSHApp.Namespace(sDest).CopyHere oSHFolder.Items
Name sDest & "\" & oSHFolder.Items.Item(0).Name As sDest & "\" & FinalName
Related
My question is about opening the document file.
I want to give the choice to my user to choose where he wants to save his file.
However, I may be wrong but I use a FileDialog (msoFileDialogFolderPicker)
which opens the file normally and afterwards sends me an error message !! I start in programming thank you for help.
this my code
Public Function ObtenirCheminFichier(path As String)
Dim fso As Object
Dim filePath As String
Set fso = CreateObject("scripting.filesystemobject")
ObtenirCheminFichier = path
If Not fso.FileExists(path) Then
Dim tmpPath As String
tmpPath = Replace(Replace(path, ".\", "", , 1), "\", "", 1, 0)
'ObtenirCheminFichier = Application.FileDialog(msoFileDialogFolderPicker).Show()
' ObtenirCheminFichier = CurrentProject.path & "\" & tmpPath
ObtenirCheminFichier = Application.FileDialog(msoFileDialogFolderPicker) & "\" & tmpPath
End If
End Function
and i doubt error this
DoCmd.OutputTo acOutputQuery, "Categorie_C2_req", acSpreadsheetTypeExcel12, spath, True
Add .SelectedItems(1) after the folder picker like this:
Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
For further details about FileDialog object you can check this API
As you want to open a single file I suggest you to add this line before opening the file dialog: Application.FileDialog(msoFileDialogFolderPicker).AllowMultiSelect = False
Essentially what I am trying to do is use vba to find and open a folder based on its name. I have looked everywhere and cannot find the solution. This is what
I have so far but nothing happens. I would like for the user to click a cmd button and it opens directly to a movie folder.
C:\Storage\Video\Video Folders\Genre\"Folder"\"movie title, Year"
the folder path after Video Folders can change depending on the "movie title, year"
Dim fso, Folder, subFlds, fld, s, showFolder as Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set Folder = fso.GetFolder(Path)
Set subFlds = Folder.SubFolders
s = "C:\Storage\Video\Video Folders"
For Each fld In subFlds
s = s & Me.FolderName
s = s & "<br />"
Next
showFolder = s
Application.FollowHyperlink showFolder
You can use the following code
to look for a folder by name in a path including subfolders of subfolders
and then open that path in the file explorer.
I created a separate function to be able to call it recursively (to look in subfolders of subfolders ...)
Use this to call the main function:
Sub openFolderIfFound()
Dim path As String
Dim folderName As String
Dim folderPath As String
path = "C:\Storage\Video\Video Folders"
folderName = Me.FolderName
' Example: folderName = "Seven Samurai - 1954"
' Example using wildcards: folderName = "*Samurai*"
folderPath = lookForFolderInPath(path, folderName)
If folderPath <> "" Then Application.FollowHyperlink folderPath
' Note: in Excel use ThisWorkbook.FollowHyperlink folderPath
End Sub
Main function to look for a folder:
' Look for folder by name in path (including subfolders of subfolders)
' and return the path of the folder if it was found.
'
' Args:
' path (String): Path to look in.
' folderName (String): Name of folder to look for. Uses LIKE operator for comparison to enable the use of wildcards:
' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/like-operator
' Returns:
' Path of folder if found else empty String ""
Function lookForFolderInPath(path As String, folderName As String, Optional ByRef fso As Object) As String
Dim topFolder As Object
Dim subfolders As Object
Dim folder As Object
Dim i As Long
If fso Is Nothing Then Set fso = CreateObject("Scripting.FileSystemObject")
Set topFolder = fso.GetFolder(path)
Set subfolders = topFolder.subfolders
' Check if permission to access subfolders
On Error Resume Next
i = subfolders.Count
On Error GoTo 0
If i <> 0 Then
' Loop through subfolders of folder (path)
For Each folder In subfolders
If folder.Name Like folderName Then
' Return folder path if folder name matched subfolder name
lookForFolderInPath = folder.path
Exit For
Else
' Recursively call function to check subfolders in subfolders
lookForFolderInPath = lookForFolderInPath(folder.path, folderName, fso)
' Exit loop if folder was found
If lookForFolderInPath <> "" Then Exit For
End If
Next
End If
Set fso = Nothing
Set folder = Nothing
End Function
I am not sure how you want to select the folder you want to open, but the key part is this one line that will solve your problem. Simply pass the path of the folder you want to open and it will do it and will activate the window for the user:
Sub OpenFolder(sPath)
Call Shell("explorer.exe" & " " & sPath, vbNormalFocus)
End Sub
Modifying the call shell that #Ibo recommended and this worked for me or rather its as close as I could get
Sub cmd_folder_Click()
Dim Folder As String, s As String, loc As String
s = "search-ms:query="
loc = "&crumb=location:C:\Storage\Video\Video Folders\"
Call Shell("explorer.exe " & Chr(34) & s & Me.Folder & loc & Chr(34), vbNormalFocus)
End Sub
I am looking for a way to copy multiple files from a single folder and copy this grouping of files to multiple folders using FileDialog in Access vba. Below is what I have so far - the problem with this code is that I can only copy multiple files from a single folder to another single folder. Can anyone help with this:
Public Function CopyFilesToFolders()
On Error GoTo Err_Copy
Dim sourcefiles As String
Dim destination As String
Dim source As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a folder that contains the desired files to copy."
If .Show = -1 Then source = .SelectedItems(1)
If Len(source) = 0 Then Exit Function
.AllowMultiSelect = True
.Title = "Select a folder location to copy the files."
If .Show = -1 Then destination = .SelectedItems(1)
If Len(destination) = 0 Then Exit Function
End With
sourcefiles = Dir$(source & "\*.*")
Do While Len(sourcefiles) > 0
FileCopy (source & "\" & sourcefiles), (destination & "\" & sourcefiles)
sourcefiles = Dir$
Loop
Exit_Copy:
Exit Function
Err_Copy:
CopyFilesToFolders = True
MsgBox Error$
Resume Exit_Copy
MsgBox "Task Complete!"
End Function
Thank you,
Al
So you want the function to automatically detect all the subfolders and copy the selected files to them? You can use FileSystemObject to detect all the subfolders, then copy the files to them. See this modified function:
Public Function CopyFilesToFolders()
On Error GoTo Exit_Copy
Dim sourcefiles As String
Dim destination As String
Dim source As String
Dim FileSystem As Object
Set FileSystem = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a folder that contains the desired files to copy."
If .Show = -1 Then source = .SelectedItems(1)
If Len(source) = 0 Then Exit Function
.AllowMultiSelect = True
.Title = "Select a folder location to copy the files."
If .Show = -1 Then destination = .SelectedItems(1)
If Len(destination) = 0 Then Exit Function
End With
sourcefiles = Dir$(source & "\*.*")
Dim SubFolder
Do While Len(sourcefiles) > 0
For Each SubFolder In FileSystem.GetFolder(destination).SubFolders
FileCopy (source & "\" & sourcefiles), (SubFolder.path & "\" & sourcefiles)
Next
sourcefiles = Dir$
Loop
Exit_Copy:
Exit Function
End Function
Sorry, for changing the topic a bit, but I think int would be a lot easier to do this in Excel, rather than in Access. See the example below.
Sub sbCopyingAFile()
'Declare Variables
Dim FSO
Dim sFile As String
Dim sSFolder As String
Dim sDFolder As String
'This is Your File Name which you want to Copy
sFile = "Sample.xls"
'Change to match the source folder path
sSFolder = "C:\Temp\"
'Change to match the destination folder path
sDFolder = "D:\Job\"
'Create Object
Set FSO = CreateObject("Scripting.FileSystemObject")
'Checking If File Is Located in the Source Folder
If Not FSO.FileExists(sSFolder & sFile) Then
MsgBox "Specified File Not Found", vbInformation, "Not Found"
'Copying If the Same File is Not Located in the Destination Folder
ElseIf Not FSO.FileExists(sDFolder & sFile) Then
FSO.CopyFile (sSFolder & sFile), sDFolder, True
MsgBox "Specified File Copied Successfully", vbInformation, "Done!"
Else
MsgBox "Specified File Already Exists In The Destination Folder", vbExclamation, "File Already Exists"
End If
End Sub
Now, if you want to dynamically list the files in a folder, each file path in an individual cell, and then specify exactly which files to copy from one folder to another, that is definitely doable. First, try the sample code above, and give me feedback for future enhancements.
I'm writing a VBA code to add files, which are into several folders, into a ZIP file.
This procedure should run automatically, by a scheduled job, and I try to add a parameter to force "yes to all".
In Microsoft support there are some constants but if I add to my code, I don't have the aspected result.
the code is the following
Public Sub ZipFolder(ZipFileName As Variant, _
FolderPath As Variant, _
Optional ByVal FileFilter As String, _
Optional ByVal Overwrite As Boolean = False)
Dim fso As Object, tf As Object
Dim strZIPHeader As String, sFile As String
On Error GoTo done
' create zip file header
strZIPHeader = Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(18, Chr(0))
With CreateObject("Shell.Application")
sFile = Dir(FolderPath, vbNormal)
Do Until sFile = vbNullString
.Namespace(ZipFileName).CopyHere FolderPath & sFile, **"&H10&"**
sFile = Dir
Loop
End With
Set fso = Nothing
Set tf = Nothing
done:
If Err.Number <> 0 Then MsgBox Err.Description, vbApplicationModal + vbInformation
End Sub
The parameter &H10& doesn't work. I have tried with "&0X14&" as well but same result.
Any idea?
Thank you
You can study the article and full code here on exactly this subject:
Zip and unzip files and folders with VBA the Windows Explorer way
You'll see, that shall the file be overwritten, it is simply deleted before proceeding:
If FileSystemObject.FileExists(ZipFile) Then
If Overwrite = True Then
' Delete an existing file.
FileSystemObject.DeleteFile ZipFile, True
' At this point either the file is deleted or an error is raised.
Else
ZipBase = FileSystemObject.GetBaseName(ZipFile)
' Modify name of the zip file to be created to preserve an existing file:
' "Example.zip" -> "Example (2).zip", etc.
Version = Version + 1
Do
Version = Version + 1
ZipFile = FileSystemObject.BuildPath(ZipPath, ZipBase & Format(Version, " \(0\)") & ZipExtension)
Loop Until FileSystemObject.FileExists(ZipFile) = False Or Version > MaxZipVersion
If Version > MaxZipVersion Then
' Give up.
Err.Raise ErrorPathFile, "Zip Create", "File could not be created."
End If
End If
End If
I have a large amount of csv files that I need in .xls format. Is it possible to run a batch conversion with a macro or best done with another language?
I have used this code http://www.ozgrid.com/forum/showthread.php?t=71409&p=369573#post369573 to reference my directory but I'm not sure of the command to open each file and save them. Here's what I have:
Sub batchconvertcsvxls()
Dim wb As Workbook
Dim CSVCount As Integer
Dim myVar As String
myVar = FileList("C:\Documents and Settings\alistairw\My Documents\csvxlstest")
For i = LBound(myVar) To UBound(myVar)
With wb
Application.Workbooks.OpenText 'How do I reference the myvar string ?
wb.SaveAs '....
End With
Next
End Sub
Function FileList(fldr As String, Optional fltr As String = "*.*") As Variant
Dim sTemp As String, sHldr As String
If Right$(fldr, 1) <> "\" Then fldr = fldr & "\"
sTemp = Dir(fldr & fltr)
If sTemp = "" Then
FileList = Split("No files found", "|") 'ensures an array is returned
Exit Function
End If
Do
sHldr = Dir
If sHldr = "" Then Exit Do
sTemp = sTemp & "|" & sHldr
Loop
FileList = Split(sTemp, "|")
End Function
Edit: The files are .txt files formatted as csv
By combining the code given by Scott Holtzman and 'ExcelFreak', the conversion works quite well. The final code looks something like this:
Sub CSV_to_XLS()
Dim wb As Workbook
Dim strFile As String, strDir As String
strDir = "U:\path\"
strFile = Dir(strDir & "*.csv")
Do While strFile <> ""
Set wb = Workbooks.Open(Filename:=strDir & strFile, Local:=True)
wb.SaveAs Replace(wb.FullName, ".csv", ".xls"), 50 'UPDATE:
wb.Close True
Set wb = Nothing
strFile = Dir
Loop
End Sub
Opening the converted .xls file throws a warning everytime:
"The file you are trying to open, 'filename', is in a different format than specified by the file extension. Verify that the file is not corrupted and is from a trusted source before opening the file. Do you want to open the file now?"
Clicking Yes then opens the .xls file.
Is there a way to get rid of this warning message? Excel throws a warning everytime the .xls file is opened.
In a lot less lines of code, this should get you what you want. However, I will say this may not be the fastest way to get it done, because you are opening, saving, and closing the workbook every time. I will look for a faster way, but I forget the method off the top of my head.
Sub batchconvertcsvxls()
Dim wb As Workbook
Dim strFile As String, strDir As String
strDir = "C:\"
strFile = Dir(strDir & "*.csv")
Do While strFile <> ""
Set wb = Workbooks.Open(strDir & strFile)
With wb
.SaveAs Replace(wb.FullName, ".csv", ".xls"), 50 'UPDATE:
.Close True
End With
Set wb = Nothing
Loop
End Sub
** UPDATE **
you need the proper fileformat enumeration for a .xls file. I think its 50, but you can check here Excel File Type Enumeration, if it's not.
The Code of Scott Holtzman nearly did it for me. I had to make two changes to get it to work:
He forgot to add the line that makes our loop continue with the next file. The last line before the Loop should read
strFile = Dir
The Workbooks.Open method did not read my CSV files as expected (the whole line ended up to be text in the first cell). When I added the parameter Local:=True it worked:
Set wb = Workbooks.Open(Filename:=strDir & strFile, Local:=True)
This works properly at least on Excel 2013. Using FileFormat:=xlExcel8 parameter instead of the filetype tag 50 creates files that open without security nags.
Sub CSV_to_XLS()
Dim wb As Workbook
Dim strFile As String, strDir As String
strDir = "C:\temp\"
strFile = Dir(strDir & "*.csv")
Do While strFile <> ""
Set wb = Workbooks.Open(Filename:=strDir & strFile, Local:=True)
wb.SaveAs Replace(wb.FullName, ".csv", ".xls"), FileFormat:=xlExcel8
wb.Close True
Set wb = Nothing
strFile = Dir
Loop
End Sub
This was a good question and I have found in the internet several answers. Just making very small changes (I couldn't edit any of the codes already published) I could make things work a bit better:
Sub CSV_to_XLSX()
Dim wb As Workbook
Dim strFile As String, strDir As String
strDir = "C:\Users\acer\OneDrive\Doctorado\Study 1\data\Retest Bkp\Day 1\Sart\"
strFile = Dir(strDir & "*.csv")
Do While strFile <> ""
Set wb = Workbooks.Open(Filename:=strDir & strFile, Local:=True)
With wb
.SaveAs Replace(wb.FullName, ".csv", ".xlsx"), 51
.Close True
End With
Set wb = Nothing
strFile = Dir
Loop
End Sub