The below mentioned VBA code works perfectly when i run it on Local Hard disk however when i run and move files saved on google drive and if number of files are more than 50 it shows runtime error (only on Google Drive) can someone help.
Run-time Error 75:
Path/file Access error
Below mentioned is the code
Sub moveAllFilesInDateFolder()
Dim DateFold As String, fileName As String
Const sFolderPath As String = "G:\My Drive\Source"
Const dFolderPath As String = "G:\My Drive\Destination\07102022"
DateFold = dFolderPath & "\" & Format(Date, "ddmmyyyy") ' create the folder if it does not exist
If Dir(DateFold, vbDirectory) = "" Then MkDir DateFold
fileName = Dir(sFolderPath & "\*.*")
Do While fileName <> ""
Name sFolderPath & "\" & fileName As DateFold & "\" & fileName
fileName = Dir
Loop
End Sub
Related
I used below code to save outlook emails in folders and subfolder to local drive and preserve original directory.
Private objFileSystem As Object
Private Sub ExportFolderWithAllItems()
Dim objFolder As Outlook.Folder
Dim strPath As String
'Specify the local folder where to save the emails
strPath = "C:\Users\qiaoqiao\"
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
'Select a Outlook PST file or Outlook folder
Set objFolder = Outlook.Application.Session.PickFolder
Call ProcessFolders(objFolder, strPath)
MsgBox "Email saving is completed", vbExclamation
End Sub
Private Sub ProcessFolders(objCurrentFolder As Outlook.Folder, strCurrentPath As String)
Dim objItem As Object
Dim strSubject, strFileName, strFilePath As String
Dim objSubfolder As Outlook.Folder
'Create local folder based on Outlook mailbox folder directory
strCurrentPath = strCurrentPath & ModifyName(objCurrentFolder.Name)
objFileSystem.CreateFolder strCurrentPath
For Each objItem In objCurrentFolder.Items
strSubject = ModifyName(objItem.Subject)
strFileName = strSubject & ".msg"
strFilePath = strCurrentPath & "\" & strFileName
i = 0
Do Until False
strFilePath = strCurrentPath & "\" & strFileName
'Check if there exist emails with the same subject
If objFileSystem.FileExists(strFilePath) Then
'Add order number to the end of the subject
i = i + 1
strFileName = strSubject & " (" & i & ").msg"
Else
Exit Do
End If
Loop
'Save as MSG file
'On Error Resume Next
'Debug.Print Len(strFilePath)
objItem.SaveAs strFilePath, olMSG
Next
'Process subfolders recursively
If objCurrentFolder.Folders.Count > 0 Then
For Each objSubfolder In objCurrentFolder.Folders
Call ProcessFolders(objSubfolder, strCurrentPath & "\")
Next
End If
End Sub
Function ModifyName(folderName As String) As String
'Dim folderName As String
'In order to save emails in the same directory as in Outlook,
'when creating the folders in local drive,
'the folder name must not contain some special characters
folderName = Replace(folderName, ":", "")
folderName = Replace(folderName, "|", "")
folderName = Replace(folderName, ",", "")
folderName = Replace(folderName, "'", "")
folderName = Replace(folderName, "(", "")
folderName = Replace(folderName, ")", "")
folderName = Replace(folderName, "~", "")
folderName = Replace(folderName, "*", "")
folderName = Replace(folderName, "?", "")
folderName = Replace(folderName, "/", "")
folderName = Replace(folderName, "\", "")
folderName = Replace(folderName, """", "")
folderName = Trim(folderName)
'folderName = Replace(folderName, Chr(34), "")
ModifyName = folderName
End Function
However, since there are many layers of folders, so the strFilePath become very long, and it gave me a runtime error saying Operation failed.
Can anyone please advise me how to solve this issue? thank you in advance!!!
In Office products there is a limit to the number of characters in the file path. This error message occurs when you save or open a file if the path to the file (including the file name) exceeds 218 characters. This limitation includes three characters representing the drive, the characters in folder names, the backslash character between folders, and the characters in the file name.
Make sure that the path to the file contains fewer than 219 characters. To do this, use one of the following methods:
Rename the file so that it has a shorter name.
Rename one or more folders that contain the file so that they have shorter names.
Move the file to a folder with a shorter path name.
Note that if you enter 255 characters in the File Name box in the
Save As dialog box, and click OK, you will receive the following error message:
The path you entered, "<path>", is too long. Enter a shorter path.
Also, if you attempt to save a file and the path exceeds 255 characters, you will receive the following error message:
The file could not be accessed. Try one of the following:
- Make sure the specified folder exists.
- Make sure the folder that contains the file is not read-only.
- Make sure the file name does not contain any of the following characters: < > ? [ ] : | *.
- Make sure the file/path name doesn't contain more than 218 characters.
I have facing an error while executing this code. If a file already exists in a destination folder it gives error. If a file does not exists it smoothly moves the files into the updated Date folder.
Can anyone please help so that in case if a file already exists in the destination folder the code does not give error. It can either replace the file with the new one or it can remain in the Source folder.
Sub moveAllFilesInDateFolder()
Dim DateFold As String, fileName As String
Const sFolderPath As String = "E:\Uploading\Source"
Const dFolderPath As String = "E:\Uploading\Archive"
DateFold = dFolderPath & "\" & Format(Date, "ddmmyyyy") ' create the folder if it does not exist
If Dir(DateFold, vbDirectory) = "" Then MkDir DateFold
fileName = Dir(sFolderPath & "\*.*")
Do While fileName <> ""
Name sFolderPath & "\" & fileName As DateFold & "\" & fileName
fileName = Dir
Loop
End Sub
This will be much appreciated.
Please, use this updated code. You cannot use Dir (once more) to check the file existence, because it will perturbate the existing loop. So, a VBScript object should be used. And naming will not be done, anymore. Name method is not able to overwrite an existing file:
Sub moveAllFilesInDateFolderIfNotExist()
Dim DateFold As String, fileName As String, objFSO As Object
Const sFolderPath As String = "E:\Uploading\Source"
Const dFolderPath As String = "E:\Uploading\Archive"
DateFold = dFolderPath & "\" & Format(Date, "ddmmyyyy") ' create the folder if it does not exist
If Dir(DateFold, vbDirectory) = "" Then MkDir DateFold
fileName = Dir(sFolderPath & "\*.*")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Do While fileName <> ""
If Not objFSO.FileExists(DateFold & "\" & fileName) Then
Name sFolderPath & "\" & fileName As DateFold & "\" & fileName
End If
fileName = Dir
Loop
End Sub
Dears I have this piece of code that checks if a file .xls in a target folder is already saved under format .xlsb in the ActiveWorkbook folder. this works properly for the first file but the loop stops after that and doesn't checks the remaining ones.
myFile = Dir(myPath & myExtension)
'check if the file .xls is in the current folder in format .xlsb
Do While myFile <> ""
If Dir(Application.ActiveWorkbook.Path & "\" & Replace(myFile, ".xls", ".xlsb")) <> "" Then
Debug.Print myFile & " is in the folder"
Else
Debug.Print myFile & " is not in the folder"
End If
'next file
myFile = Dir
Loop
You haven't created an array for looping the files from. Below is the code for checking file existance
Sub checkExistance()
'setup
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("Your Folder Path Here")
'file
Dim myFile As String
Dim FileName As String
Dim FileExtension As String
FileName = "Your File Name"
FileExtension = ".xls"
myFile = FileName & FileExtension
'Loop through each file in folder
For Each objFile In objFolder.Files
If objFile.Name = Replace(myFile, ".xls", ".xlsb") Then
MsgBox objFile.Name & " Ci sta"
Else
MsgBox objFile.Name & " Nun Ci sta"
End If
Next
End Sub
There is a function on another answer HERE that returns an array of files within a folder. If you grab that, you can get what you need with:
Dim myFile As Variant
Dim folder_containing_xls As String
Dim folder_containing_xlsb As String
folder_containing_xls = "FOLDER PATH HERE"
folder_containing_xlsb = Application.ActiveWorkbook.Path 'or "OTHER OR SAME FOLDER PATH HERE"
If Right(folder_containing_xls, 1) <> "\" Then folder_containing_xls = folder_containing_xls & "\"
If Right(folder_containing_xlsb, 1) <> "\" Then folder_containing_xlsb = folder_containing_xlsb & "\"
For Each myFile In listfiles(folder_containing_xls)
If myFile Like "*.xls" Then
If Dir(folder_containing_xlsb & Replace(myFile, ".xls", ".xlsb")) <> "" Then
Debug.Print myFile & " is in the folder"
Else
Debug.Print myFile & " is not in the folder"
End If
End If
Next
I couldn't work out if you were looking for both files to be in the same folder, or if they were in different folders, so I've built it to cope with either.
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
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