Error when copying files to an existing folder - vba

I am writing some code that prompts the user to add a folder name, then copies all the files on the CD drive (D:) to C:\Example\ & FolderName if it doesn't already exist.
The code works until I try to copy files to a folder that already exists then I get a Run-time error 70: Permission Denied. Any help would be greatly appreciated.
Public Sub CopyFiles()
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim FileExt As String
Dim FNames As String
Dim FolderName As String
FolderName = InputBox(Prompt:="Your folder name", Title:="Folder Name", default:="Folder Name here")
If Dir("C:\Example\" & FolderName & "\", vbDirectory) = "" Then
MkDir "C:\Example\" & FolderName
Else
End If
FromPath = "D:\"
ToPath = "C:\Example\" & FolderName & "\"
FileExt = "*.flac*"
If Right(FromPath, 1) <> "\" Then
FromPath = FromPath & "\"
End If
FNames = Dir(FromPath & FileExt)
If Len(FNames) = 0 Then
MsgBox "No files in " & FromPath
Exit Sub
End If
Set FSO = CreateObject("scripting.filesystemobject")
FSO.CopyFile Source:=FromPath & FileExt, Destination:=ToPath
End Sub

The problem is not that the folder exists. The problem is that you are trying to copy files and overwrite them
Overwriting is usually not a problem but fails if the files in the destination folder have Read Only Attributes. You can read more about it in this MSDN Article
What happened was when you first copied the files from the CD Drive, the file which where copied retained the Read Only Property. You can check that by Right Clicking on the File and checking their properties.
To overcome this problem, you need to reset the file attributes or delete the files in that folder.
To delete, you can simply use
On Error Resume Next
Kill "C:\MyFolder\*.*"
On Error GoTo 0
To change the attributes, you have to loop through the file and check if their property is read only. You can do that by
If fso.GetFile(Dest_File).Attributes And 1 Then
and to reset it, you have to use
fso.GetFile(Dest_File).Attributes = fso.GetFile(Dest_File).Attributes - 1
Once you do that you will be able to copy the files across.

As Siddharth mentioned, the error occurs because the code is trying to overwrite existing files. So, if you don't want to overwrite the files, you can simply add a If Error Resume Next. The solution code I am using is below:
Public Sub CopyFiles()
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim FileExt As String
Dim FNames As String
Dim FolderName As String
FolderName = InputBox(Prompt:="Your folder name", Title:="Folder Name", default:="Folder Name here")
If Dir("C:\Example\" & FolderName & "\", vbDirectory) = "" Then
MkDir "C:\Example\" & FolderName
Else
End If
FromPath = "D:\"
ToPath = "C:\Example\" & FolderName & "\"
FileExt = "*.flac*"
If Right(FromPath, 1) <> "\" Then
FromPath = FromPath & "\"
End If
FNames = Dir(FromPath & FileExt)
If Len(FNames) = 0 Then
MsgBox "No files in " & FromPath
Exit Sub
End If
Set FSO = CreateObject("scripting.filesystemobject")
On Error Resume Next
FSO.CopyFile Source:=FromPath & FileExt, Destination:=ToPath
On Error GoTo 0
End Sub

Related

Extracting zip content without administrator privileges

Is there a way to extract 7z content using VBA without administrator privileges?
Using the function UnzipAFile described here I get an error at line:
ShellApp.Namespace(unzipToPath).CopyHere ShellApp.Namespace(zippedFileFullName).items
I think it is related to the create object command:
Set ShellApp = CreateObject("Shell.Application")
I do not and cannot have administrator privileges.
(Maybe its due to other reason?!?)
Thank you for your help.
See Ron de Bruin Example code-
Unzip file(s) with the default Windows zip program
Sub Unzip1()
Dim FSO As Object
Dim oApp As Object
Dim Fname As Variant
Dim FileNameFolder As Variant
Dim DefPath As String
Dim strDate As String
Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
MultiSelect:=False)
If Fname = False Then
'Do nothing
Else
'Root folder for the new folder.
'You can also use DefPath = "C:\Users\Ron\test\"
DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
'Create the folder name
strDate = Format(Now, " dd-mm-yy h-mm-ss")
FileNameFolder = DefPath & "MyUnzipFolder " & strDate & "\"
'Make the normal folder in DefPath
MkDir FileNameFolder
'Extract the files into the newly created folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items
'If you want to extract only one file you can use this:
'oApp.Namespace(FileNameFolder).CopyHere _
'oApp.Namespace(Fname).items.Item("test.txt")
MsgBox "You find the files here: " & FileNameFolder
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
End If
End Sub

Unzipping a password protected zip file and extracting files using Excel VBA

I am trying to automate unzipping a zip file and extracting the files to a new folder location. I have scoured a bunch of sources and found code that will unzip the folder but it won't actually remove the files inside and put them in the new location, it just copies the zip folder and pastes it to the new location with the password removed. I want it to extract the files inside, and place them in the new folder. Thanks in advance for any help. Here is my code:
Sub Unzip1()
Dim FSO As Object
Dim oApp As Object
Dim Fname As Variant
Dim FileNameFolder As Variant
Dim DefPath As String
Dim strDate As String
Dim sPathTo7ZipExe As String
Dim sZipPassword As String
sPathTo7ZipExe = "C:\Riley\7Zip\7za.exe" ' <-- change this to where you installed the 7zip command line program
sZipPassword = "password" ' <-- change this to your zip password
Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
MultiSelect:=False)
If Fname = False Then
'Do nothing
Else
'Root folder for the new folder.
'You can also use DefPath = "C:\Users\Ron\test\"
'DefPath = Application.DefaultFilePath
DefPath = "C:\Riley\Visual Basic\" ' <-- make sure your path here ends in a \. you were missing that before
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
'Create the folder name
strDate = Format(Now, " dd-mm-yy h-mm-ss")
FileNameFolder = DefPath & "MyUnzipFolder " & strDate & "\"
'Make the normal folder in DefPath
MkDir FileNameFolder
Shell sPathTo7ZipExe & " x -y -p" & sZipPassword & " -o""" & _
FileNameFolder & """ """ & Fname, vbHide
MsgBox "You find the files here: " & FileNameFolder
'On Error Resume Next
'Set FSO = CreateObject("scripting.filesystemobject")
'FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
End If
End Sub

Runtime Error 70 Permission Denied in moving files to another folder [duplicate]

This question already has answers here:
VBScript to move file with wildcard, if it exists
(3 answers)
Closed 6 years ago.
I'm trying to move ALL excel files from one folder path to another and I'm getting a permission denied error. Here's my code:
Sub Move_Certain_Files_To_New_Folder()
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim FileExt As String
Dim FNames As String
FromPath = "R:\FromPath\Files" '<< Change
ToPath = "R:\ToPath\Backup" & Format(Now, "yyyy-mm-dd h-mm-ss")
FileExt = "*.xl*"
If Right(FromPath, 1) <> "\" Then
FromPath = FromPath & "\"
End If
FNames = Dir(FromPath & FileExt)
If Len(FNames) = 0 Then
MsgBox "No files in " & FromPath
Exit Sub
End If
Set FSO = CreateObject("scripting.filesystemobject")
FSO.CreateFolder (ToPath)
FSO.MoveFile Source:=FromPath & FileExt, Destination:=ToPath
MsgBox "You can find the files from " & FromPath & " in " & ToPath
End Sub
The error is from this part: FSO.MoveFile Source:=FromPath & FileExt, Destination:=ToPath
Appreciate any help! :)
Moving a file can't be done without exclusive access to that file. If another process has it opened (which would cause that runtime error 70 you're getting), there's not much you can do, other than try moving the next file, and try that locked file again later.
Or you can copy it to destination instead. But then, whatever has the file opened probably means to make changes to it, and your copy won't have them.

VBA to unzip file in Outlook

Does any have VBA code for outlook that will automatically unzip a file? I have found several post that save a file to a locationm, but nothing that unzips a file.
Maybe this is what you are looking for. An example from the website (visit the link to find out more):
With this example you can browse to the zip file. After you select the zip file the macro will create a new folder in your DefaultFilePath and unzip the Zip file in that folder. You can run the code without any changes.
Sub Unzip1()
Dim FSO As Object
Dim oApp As Object
Dim Fname As Variant
Dim FileNameFolder As Variant
Dim DefPath As String
Dim strDate As String
Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
MultiSelect:=False)
If Fname = False Then
'Do nothing
Else
'Root folder for the new folder.
'You can also use DefPath = "C:\Users\Ron\test\"
DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
'Create the folder name
strDate = Format(Now, " dd-mm-yy h-mm-ss")
FileNameFolder = DefPath & "MyUnzipFolder " & strDate & "\"
'Make the normal folder in DefPath
MkDir FileNameFolder
'Extract the files into the newly created folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items
'If you want to extract only one file you can use this:
'oApp.Namespace(FileNameFolder).CopyHere _
'oApp.Namespace(Fname).items.Item("test.txt")
MsgBox "You find the files here: " & FileNameFolder
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
End If
End Sub

run time error 91 object variable not set

When I get to the line
oApp.Namespace(FileNameZip).CopyHere oApp.Namespace(FolderName).items
I get a:
run time error 91, object variable not set
The zip file is created and in the working folder as well as the files to be zipped. I've checked my variables and they are set and correct.
Sub Zip_genie()
Dim FileNameZip, FolderName, oFolder
Dim strDate As String, DefPath As String
Dim oApp As Object
DefPath = "c:\users\" & Environ("Username") & "\documents\Appraiser_Genie\working\"
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
ChDir DefPath
FileNameZip = "report.zip"
Set oApp = CreateObject("Shell.Application")
'Create empty Zip File
NewZip (FileNameZip)
FolderName = DefPath
Debug.Print (FolderName)
Debug.Print (FileNameZip)
'Copy the files to the compressed folder
oApp.Namespace(FileNameZip).CopyHere oApp.Namespace(FolderName).items
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(FileNameZip).items.count = _
oApp.Namespace(FolderName).items.count
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
'MsgBox "You find the zipfile here: " & FileNameZip
End Sub
Try specifying the full pathname of the zip file.
For example, instead of just:
FileNameZip = "report.zip"
Use:
FileNameZip = "c:\users\" & Environ("Username") & "\documents\Appraiser_Genie\target\report.zip"
...or wherever your report.zip file is