I have created a VBA macro that pulls files from folder/subfolders based on a number of parameters. This includes finding zip folders that meet those parameters and copying them to a new directory so that each file can be searched through also. The problem that I'm having is that many of the files in those zips are duplicates, and as the project is to be automated, I cannot sit there and push the don't copy button every time it pops up. Is there a way to search through zip files and ignore the duplicate files? What I have for this part of my code is:
Sub Unzip(fileName As String, mainSubfolder As String)
Dim sourceDir As String, fileString As String
Dim FileNameFolder As Variant
Dim oApp As Object
sourceDir = "\\Filesrv02\depts\AR\EDIfiles\Remits"
fileString = mainSubfolder + fileName
If Right(sourceDir, 1) <> "\" Then
sourceDir = sourceDir & "\"
End If
FileNameFolder = sourceDir & "Unzipped"
If Dir(FileNameFolder, vbDirectory) = vbNullString Then
MkDir FileNameFolder
End If
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(fileString).Items
End Sub
The last two lines are where I copy files from the zip folder into a new folder called "Unzipped". However, I'm not sure how to get at each individual file in the zip folder to say if it already exists, ignore it. Any suggestions would be greatly appreciated!
Maybe this helps:
(taken from: https://stackoverflow.com/a/14987890/3883521)
With oApp.NameSpace(ZipFile & "\")
If OverwriteFile Then
For Each fil In .Items
If FSO.FileExists(DefPath & fil.Name) Then
Kill DefPath & fil.Name
End If
Next
End If
oApp.NameSpace(CVar(DefPath)).CopyHere .Items
End With
Related
I am stuck in a situation where I would like to create an automatic date-wise folder on the FTP account. Also, it requires moving one to two files in an updated folder every day. i.e. If it is 28-Dec-22 then the automatic folder with the mentioned format below should be created and the file then should be moved to the updated date folder.
the format of the date will be like this
2023/01/01
This means on the FTP and on the root directory there will be a year folder then in the year folder there will be a month folder and in the month folder, there will be date-wise folders (month and date will folder will be two digits only.
At the start of next month, it requires creating an automatic month folder (within the year folder) and then the normal date folders will be created. that will be 2023/02/01 and so on.
I am using the code mentioned below to move the file from source to destination and it also creates the date-wise folder but in this code, it can only send the file to one selected destination and this cannot be moved into the updated date-wise folder.
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\Destination"
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
Can anyone please help me in this situation?
I'm trying to open all MS Project files in a specific folder to extract some information of each one and transfer to excel.
Sub OpenProjectFiles()
Dim myMpp As MSProject.Application
Dim FileNameMpp As String, Folder As String
Folder = "C:\Users\nikolasqueiroz\Desktop\VBA Test"
Set myMpp = CreateObject("Msproject.Application")
FileNameMpp = Dir(Folder & "\*.mpp")
Do
myMpp.FileOpenEx Name:=FileNameMpp, ReadOnly:=True
FileNameMpp = Dir
Loop Until FileNameMpp = " "
End Sub
But when I try to open the .mpp file something goes wrong:
Does anyone know how can I fix this?
First of all, the code you posted does not match the code shown in your screenshot. The screenshot code uses the syntax for opening files from Project Server--e.g. prefacing the name of the file with <>\.
Use this code instead:
Sub OpenProjectFiles()
Dim myMpp As MSProject.Application
Dim FileNameMpp As String, Folder As String
Folder = "C:\Users\nikolasqueiroz\Desktop\VBA Test\"
Set myMpp = CreateObject("Msproject.Application")
myMpp.Visible = True
FileNameMpp = Dir(Folder & "*.mpp")
Do While Len(FileNameMpp) > 0
myMpp.FileOpenEx Name:=Folder & FileNameMpp, ReadOnly:=True
FileNameMpp = Dir
Loop
End Sub
Notes:
When automating another application, make it visible so you can see & respond to pop-up messages.
The FileOpenEx method should be given the full path.
Test the output of the Dir function at the beginning of the loop as there may not be any files.
Adding the trailing slash in the Folder variable is simpler & cleaner than adding it later (in two places).
This question already has an answer here:
How to delete files from zip with VBScript
(1 answer)
Closed 3 years ago.
During a complete macro process I am creating a Zip file of a Folder. That folder have multiple sub-folders and files. Using This code:
Dim oApp As Object
NewZip (s_path & "\" & acc_name & ".zip")
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(s_path & "\" & acc_name & ".zip").CopyHere oApp.Namespace(s_path & "\" & acc_name & "\").items
On Error Resume Next
Do Until oApp.Namespace(s_path & "\" & acc_name & ".zip").items.Count = _
oApp.Namespace(s_path & "\" & acc_name & "\").items.Count
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
Set oApp = Nothing
Now What i need to is to check that the Zip is less than 20mb, so that it can be sent via mail. Which I found can be done using line:
FileLen(path)
Now if the file size exceeds 20mb, i want to delete all the files from one specific subfolder of that Zip. I don't have any idea how to do that. Should I just create another zip like the original and try skipping files in that subfolder or there is some way to delete specific files in a Zip ?
I was trying to look inside the Zip using:
Dim FSO As Object
Dim sh As Object, fld As Object, n As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set sh = CreateObject("Shell.Application")
Set ZipFile = sh.Namespace("C:\Users\mohit.bansal\Desktop\Test\Test.zip")
For Each fileInZip In ZipFile.Items
Debug.Print (fileInZip)
Next
Still not able to get inside the Subfolders of the Zip.
To delete a file from a zip file, try this. I am demonstrating on how to delete one file. Feel free to amend it to suit your needs
Logic:
Use .MoveHere to move the file to user's temp directory. This will remove the file from the zip file
Delete the file from the temp directory
Code: (Tried and Tested)
Option Explicit
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
(ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Const MAX_PATH As Long = 260
Sub Sample()
Dim zipFile, oShellApp, fileToDelete, fl
zipFile = "C:\Users\routs\Desktop\Desktop.zip"
fileToDelete = "Tester.xlsm"
Set oShellApp = CreateObject("Shell.Application")
For Each fl In oShellApp.Namespace(zipFile).Items
If fl.Name = fileToDelete Then
oShellApp.Namespace(TempPath).MoveHere (fl)
End If
Next fl
Kill TempPath & fileToDelete
End Sub
'~~> Function to get the user's temp path
Function TempPath() As Variant
TempPath = String$(MAX_PATH, Chr$(0))
GetTempPath MAX_PATH, TempPath
TempPath = Replace(TempPath, Chr$(0), "")
End Function
Alternative
Add all relevant files to the zip
After that in a loop check the file size and if it is within acceptable limits, add optional files one by one.
Using the Hints from above answer by Siddharth. This little piece of code worked.
Fortunately you can pass path of a folder inside the Zip to NameSpace directly and loop through it's files.
Using path as C:\-----\Test.Zip\Folder\Folder
So this worked Beautifully.
Dim oApp As Object
Dim fl As Object
Set oApp = CreateObject("Shell.Application")
For Each fl In oApp.Namespace("C:\Users\mohit.bansal\Desktop\Test\Test.zip\Test\Password Removed Files").items
'Path to a folder inside the Zip
oApp.Namespace("C:\Users\mohit.bansal\Desktop\Test\abc\").MoveHere (fl.Path)
Next
I'm trying to better understand the Dir function. I have a Dir loop to take action on all .csv files in the directory, but when the loop comes across another file type, like .txt, it will error instead of moving on to the next .csv. item.
This is the relevant portion of my code.
strSourceExcelLocation = "\\rilinfs001\Interdepartmental\Billings & Deductions\Billing Coordinators\MCB Reports\East\Monthly Quality MCBs (CMQ & SECMQ)\2019\Individual_Reports\" & fldr & "\"
strWorkbook = Dir(strSourceExcelLocation & "*.csv*")
Do While Len(strWorkbook) > 0
'Open the workbook
Set wbktoExport = Workbooks.Open(Filename:=strSourceExcelLocation & strWorkbook)
'Export all sheets as single PDF
Call Export_Excel_as_PDF(wbktoExport)
'Get next workbook
strWorkbook = Dir
'Close Excel workbook without making changes
wbktoExport.Close False
Loop
So if there are only .csv files in the directory, then this works fine. When it comes across another file type, an error occurs.
The error is on line
strWorkbook = Dir
Run-time error 5: Invalid procedure call or argument
Am I missing something with the way I use the wildcards in the .csv at the beginning?
Thank you
Solved my issue.
The problem seems to have been because when I called another procedure, I had another Dir in that sub to create a new folder if one didn't already exist. So basically I had a Dir in a Dir, which apparently is bad.
I moved the folder creation part to the very beginning of my procedure, so it is executed before I begin the Dir for looping through all the CSV files.
Option Explicit
Sub Loop_Dir_for_Excel_Workbooks()
Dim strWorkbook As String, wbktoExport As Workbook, strSourceExcelLocation As String, fldr As String, strTargetPDFLocation As String, d As String
strTargetPDFLocation = "\\nhchefs001\Accounting\IMAGING\BILLINGS & DEDUCTIONS\EAST MCB FILES\"
'***** Creating a folder to save the PDFs in. Naming the folder with today's date *****
d = Format(Date, "mm-dd-yyyy")
strTargetPDFLocation = "\\nhchefs001\Accounting\IMAGING\BILLINGS & DEDUCTIONS\EAST MCB FILES\" & d & "\"
If Len(Dir(strTargetPDFLocation, vbDirectory)) = 0 Then MkDir strTargetPDFLocation
fldr = InputBox("Input the EXACT Folder Name that you want to create PDFs for")
strSourceExcelLocation = "\\rilinfs001\Interdepartmental\Billings & Deductions\Billing Coordinators\MCB Reports\East\Monthly Quality MCBs (CMQ & SECMQ)\2019\Individual_Reports\" & fldr & "\"
'Search all Excel files in the directory with .xls, .xlsx, xlsm extensions
strWorkbook = Dir(strSourceExcelLocation & "*.csv")
Do While Len(strWorkbook) > 0
'Open the workbook
Set wbktoExport = Workbooks.Open(Filename:=strSourceExcelLocation & strWorkbook)
'Export all sheets as single PDF
Call Export_Excel_as_PDF(wbktoExport, strTargetPDFLocation)
'Close Excel workbook without making changes
wbktoExport.Close False
'Get next workbook
strWorkbook = Dir
Loop
End Sub
Try to hardcode the path and give it a try again. Probably the error is something really small in the hardcoding. E.g., in the code below, replace C:\Users\username\Desktop\AAA\ with the path of the file. Then run it. Do not forget the last \. It should work:
Sub TestMe()
Dim workbookPath As String
workbookPath = Dir("C:\Users\username\Desktop\AAA\" & "*.csv")
Do While Len(workbookPath) > 0
Debug.Print workbookPath
workbookPath = Dir
Loop
End Sub
I'm using Microsoft Scripting Runtime (FSO) to parse folders and produce a list of all of its contents, the folders are on a network and resultant paths end up longer than 260. The minimum code I have is as below:-
Private Sub ProcessFolder(ByVal StrFolder As String)
Dim Fl As File
Dim Fldr As Folder
Dim RootFldr As Folder
Set RootFldr = FS.GetFolder(StrFolder)
For Each Fl In RootFldr.Files
Debug.Print Fl.Path
Next
For Each Fldr In RootFldr.SubFolders
DoEvents
ProcessFolder Fldr.Path
Next
Set RootFldr = nothing
End sub
At a certain level StrFolder length became 259, the Set RootFldr ... folder line worked but For Each Fl In RootFldr.Files gave the error of 76: Path not found, presumably because the content causes the path to breach the 260 limit.
There were files in the folder when looking in Windows Explorer. I am using Excel as the host for this code as I'm outputting the result to workbooks.
Just to be super clear on my question and its background, I need to use FSO (happy to be shown alternatives if they exist) to access files deeper than 260 characters deep in their network path. I need it as FSO as the tool I have is taking the folder paths and the file paths, name, size created, and modified.
The technique to convert MAXFILE encumbered DOS path names to native OS path names is well established and documented. Summarizing:
Prefix a path that uses a drive letter with \\?\, like \\?\C:\foo\bar\baz.txt
Prefix a path that uses a file share with '\\?\UNC\, like \\?\UNC\server\share\baz.txt.
Works well with FileSystemObject too, at least when I tested your code on Windows 10. That might not necessarily be the case in older Windows versions or with the network redirector on your server. Tested by using the FAR file manager to create subdirectories with long names and verified with:
Dim path = "\\?\C:\temp\LongNameTest"
ProcessFolder path
Produced:
\\?\c:\temp\LongNameTest\VeryLongFolderName0123456789012345678901234567890123456789012345678901234567890123456789\VeryLongFolderName0123456789012345678901234567890123456789012345678901234567890123456789\VeryLongFolderName0123456789012345678901234567890123456789012345678901234567890123456789\VeryLongFolderName0123456789012345678901234567890123456789012345678901234567890123456789\VeryLongFolderName0123456789012345678901234567890123456789012345678901234567890123456789\Chrysanthemum.jpg
Which is 488 characters long. Things to keep in mind:
Native path names must be full paths, they cannot be relative paths. In other words, they must always start with a drive letter or share name and start from the root of the drive/share.
You get the native path name back, don't forget to strip the prefix off again if you display it.
Not tested but should fail, there is still a limitation on the the length of the filename itself (without the directory names), can't be longer than 259 chars. Shouldn't be a problem at all since the user can't create them either.
This took a little creative coding but the use of ShortPath was the answer.
This tool was to create a list of every folder and file in a root folder, the files also showing their size, and created/modified dates. The issue was when the resultant path of a file or folder was over 260, then the error Error 76: Path Not Found was thrown and the code would not capture the content of that area.
Using Microsoft Scripting Runtime (FSO) ShortPath would get around this issue but the path went from human readable to coded:-
Full path
\\ServerName00000\Root_Root_contentmanagement\DPT\STANDARDS_GUIDELINES\VENDOR_CERTIFICATION_FILES\PDFX_CERTIFICATION_ALL\2006_2007\DPT\CompantName0\Approved\Quark\India under Colonial Rule_structure sample\058231738X\Douglas M. Peers_01_058231738X\SUPPORT\ADDITIONAL INFORMATION\IUC-XTG & XML file
Short Path
\\lo3uppesaapp001\pesa_cmcoe_contentmanagement\CTS\S4SJ05~5\V275SE~8\PDM5D9~G\2N52EQ~5\HPE\GS9C6L~U\Approved\Quark\IQPSJ5~F\0CWHH1~G\DOFNHA~8\SUPPORT\A6NO7S~K\IUC-XTG & XML file
(Note I've altered the full path to protect IP and company info but the size is the same)
You can see while I could pass short path to someone and they could put it into Windows Explorer to get there, they would know know where it went by simply looking, to get around this a used a global variable that kept the folder path as a full string and followed what the short path was doing. this string is then what I output to the user. The below code is cut down but shows how I achieved it.
The short answer is ShortPath in FSO will get past the issue but the path will not be pretty.
Dim FS As New FileSystemObject
Dim LngRow As Long
Dim StrFolderPath As String
Dim WkBk As Excel.Workbook
Dim WkSht As Excel.Worksheet
Public Sub Run_Master()
Set WkBk = Application.Workbooks.Add
WkBk.SaveAs ThisWorkbook.Path & "\Data.xlsx"
Set WkSht = WkBk.Worksheets(1)
WkSht.Range("A1") = "Path"
WkSht.Range("B1") = "File Name"
WkSht.Range("C1") = "Size (KB)"
WkSht.Range("D1") = "Created"
WkSht.Range("E1") = "Modified"
LngRow = 2
Run "\\ServerName00000\AREA_DEPT0_TASK000"
Set WkSht = Nothing
WkBk.Close 1
Set WkBk = Nothing
MsgBox "Done!"
End Sub
Private Sub Run(ByVal StrVolumeToCheck As String)
Dim Fldr As Folder
Dim Fldr2 As Folder
Set Fldr = FS.GetFolder(StrVolumeToCheck)
'This is the variable that follows the full path name
StrFolderPath = Fldr.Path
WkSht.Range("A" & LngRow) = StrFolderPath
LngRow = LngRow +1
For Each Fldr2 In Fldr.SubFolders
If (Left(Fldr2.Name, 1) <> ".") And (UCase(Trim(Fldr2.Name)) <> "LOST+FOUND") Then
ProcessFolder Fldr2.Path
End If
Next
Set Fldr = Nothing
End Sub
Private Sub ProcessFolder(ByVal StrFolder As String)
'This is the one that will will be called recursively to list all files and folders
Dim Fls As Files
Dim Fl As File
Dim Fldrs As Folders
Dim Fldr As Folder
Dim RootFldr As Folder
Set RootFldr = FS.GetFolder(StrFolder)
If (RootFldr.Name <> "lost+found") And (Left(RootFldr.Name, 1) <> ".") Then
'Add to my full folder path
StrFolderPath = StrFolderPath & "\" & RootFldr.Name
WkSht.Range("A" & LngRow) = StrFolderPath
WkSht.Range("D1") = RootFldr.DateCreated
WkSht.Range("E1") = RootFldr.DateLastModified
Lngrow = LngRow + 1
'This uses the short path to get the files in FSO
Set Fls = FS.GetFolder(RootFldr.ShortPath).Files
For Each Fl In Fls
'This output our string variable of the path (i.e. not the short path)
WkSht.Range("A" & LngRow) = StrFolderPath
WkSht.Range("B" & LngRow) = Fl.Name
WkSht.Range("C" & LngRow) = Fl.Size /1024 '(bytes to kilobytes)
WkSht.Range("D" & LngRow) = Fl.DateCreated
WkSht.Range("E" & LngRow) = Fl.DateLastModified
LngRow = LngRow + 1
Next
Set Fls = Nothing
'This uses the short path to get the sub-folders in FSO
Set Fldrs = FS.GetFolder(RootFldr.ShortPath).SubFolders
For Each Fldr In Fldrs
'Recurse this Proc
ProcessFolder Fldr.Path
DoEvents
Next
Set Fldrs = Nothing
'Now we have processed this folder, trim the folder name off of the string
StrFolderPath = Left(StrFolderPath, Len(StrFolderPath) - Len(RootFldr.Name)+1)
End If
Set RootFldr = Nothing
End Sub
As mentioned this is a cut version of the code that is working for me to exemplify the the method used to get past this limit. Actually seems quite rudimentary once I'd done it.
I got around this once using the subst command of the command shell. It allows you to assign a drive letter to a local path (kind of like a network share).