Here's my code:
Sub isdofsodjisf48023jroi23f984444444jiodfiosj12348023jroi23f98()
Dim colFiles As New Collection
RecursiveDir colFiles, "C:\Documents and Settings\Alex Gordon\Desktop\testing\files\", "*.xls", True
Dim vFile As Variant
For Each vFile In colFiles
Call writeincells(vFile)
Next vFile
End Sub
Public Function RecursiveDir(colFiles As Collection, _
strFolder As String, _
strFileSpec As String, _
bIncludeSubfolders As Boolean)
Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant
'Add files in strFolder matching strFileSpec to colFiles
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
colFiles.Add strFolder & strTemp
strTemp = Dir
Loop
If bIncludeSubfolders Then
'Fill colFolders with list of subdirectories of strFolder
strTemp = Dir(strFolder, vbDirectory)
Do While strTemp <> vbNullString
If (strTemp <> ".") And (strTemp <> "..") Then
If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
colFolders.Add strTemp
End If
End If
strTemp = Dir
Loop
'Call RecursiveDir for each subfolder in colFolders
For Each vFolderName In colFolders
Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
Next vFolderName
End If
End Function
Public Function TrailingSlash(strFolder As String) As String
If Len(strFolder) > 0 Then
If Right(strFolder, 1) = "\" Then
TrailingSlash = strFolder
Else
TrailingSlash = strFolder & "\"
End If
End If
End Function
I am filling up a Collection with a list of filenames in a directory structure.
I have 2000 files, but the Collection only return 256. Does anyone know if there is a maximum number that it won't go past?
If so, can you please suggest a better way to code this macro so that it captures all 2000 files?
The code is working OK in Excel 2007. Perhaps what is happening is that you are trying to Watch the Collection in Debug mode. The Debugger shows only the first 256 items.
How about a disconnected recordset? This thread is about VBScript, but it is very similar to VBA:
How do I sort arrays using vbscript?
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
The below code extracts attachments from *.msg files stored in one folder.
I'm seeking to extract attachments from *.msg files stored in many subfolders within a folder.
The path for the main Folder is:
U:\XXXXX\XXXXX\Main Folder
The paths for the subfolders are:
U:\XXXXX\XXXXX\Main Folder\Folder1
U:\XXXXX\XXXXX\Main Folder\Folder2
U:\XXXXX\XXXXX\Main Folder\Folder3
etc.
Sub SaveOlAttachments()
Dim msg As Outlook.MailItem
Dim att As Outlook.Attachment
Dim strFilePath As String
Dim strAttPath As String
'path for msgs
strFilePath = "U:\XXXXX\XXXXX\Main Folder\"
'path for saving attachments
strAttPath = "D\Attachments\"
strFile = Dir(strFilePath & "*.msg")
Do While Len(strFile) > 0
Set msg = Application.CreateItemFromTemplate(strFilePath & strFile)
If msg.Attachments.Count > 0 Then
For Each att In msg.Attachments
att.SaveAsFile strAttPath & att.FileName
Next
End If
strFile = Dir
Loop
End Sub
Using my answer from VBA macro that search for file in multiple subfolders
Sub SaveOlAttachments()
Dim msg As Outlook.MailItem
Dim att As Outlook.Attachment
Dim strFilePath As String
Dim strAttPath As String
Dim colFiles As New Collection, f
'path for msgs
strFilePath = "U:\XXXXX\XXXXX\Main Folder\"
GetFiles strFilePath , "*.msg", True, colFiles
'path for saving attachments
strAttPath = "D\Attachments\"
For Each f in colFiles
Set msg = Application.CreateItemFromTemplate(f)
If msg.Attachments.Count > 0 Then
For Each att In msg.Attachments
att.SaveAsFile strAttPath & att.FileName
Next
End If
Next
End Sub
Sub to perform the search:
Sub GetFiles(StartFolder As String, Pattern As String, _
DoSubfolders As Boolean, ByRef colFiles As Collection)
Dim f As String, sf As String, subF As New Collection, s
If Right(StartFolder, 1) <> "\" Then StartFolder = StartFolder & "\"
f = Dir(StartFolder & Pattern)
Do While Len(f) > 0
colFiles.Add StartFolder & f
f = Dir()
Loop
sf = Dir(StartFolder, vbDirectory)
Do While Len(sf) > 0
If sf <> "." And sf <> ".." Then
If (GetAttr(StartFolder & sf) And vbDirectory) <> 0 Then
subF.Add StartFolder & sf
End If
End If
sf = Dir()
Loop
For Each s In subF
GetFiles CStr(s), Pattern, True, colFiles
Next s
End Sub
As in the Question: the task is to extract all files names from a folder, but the folder path needs to be hard coded into the macro, to prevent these dialog boxes asking me things and wasting my time.
I will not change this folder. It will be the same one until the end of time, and I want to extract the files names into the Excel column, starting from second row.
this is the folder I want to extract ALL files names from.
"C:\Users\michal\SkyDrive\csv\bossa\mstcgl_mst\"
this is my portion of code:
Option Explicit
Sub GetFileNames()
Dim axRow As Long ' inside the Sheet("Lista") row#
Dim xDirectory As String
Dim xFname As String ' name of the file
Dim InitialFoldr$
Dim start As Double
Dim finish As Double
Dim total_time As Double
start = Timer
ThisWorkbook.Sheets("Lista").Range("D2").Activate
InitialFolder = "C:\Users\michal\SkyDrive\csv\bossa\mstcgl_mst"
If Right(InitialFolder, 1) <> "\" Then
InitialFolder = InitialFolder & "\"
End If
Application.InitialFolder.Show
If InitialFolder.SelectedItems.Count <> 0 Then
xDirectory = .SelectedItems(1) & "\"
xFname = Dir(xDirectory, vbArchive)
' Dir's job is to return a string representing
' the name of a file, directory, or an archive that matches a specified pattern.
Do While xFname <> "" ' there is already xFname value (1st file name) assigned.
ActiveCell.Offset(xRow) = xFname
xRow = xRow + 1 ' następny xRow
xFname = Dir()
Loop
End If
End With
finish = Timer ' Set end time.
total_time = Round(finish - start, 3) ' Calculate total time.
MsgBox "This code ran successfully in " & total_time & " seconds", vbInformation
End Sub
this is the line that crushes:
If InitialFolder.SelectedItems.Count <> 0 Then
xDirectory = .SelectedItems(1) & "\"
And two more important questions in the .png file.
Please, respond to them as well - it's very important 4 me.
Or if U guys know any other method to do this faster just don't hesitate and share Your Code with me - I'll be very grateful.
Sub Files()
Dim sht As Worksheet
Dim strDirectory As String, strFile As String
Dim i As Integer: i = 1
Set sht = Worksheets("Sheet1")
strDirectory = "C:\Users\User\Desktop\"
strFile = Dir(strDirectory, vbNormal)
Do While strFile <> ""
With sht
.Cells(i, 1) = strFile
.Cells(i, 2) = strDirectory + strFile
End With
'returns the next file or directory in the path
strFile = Dir()
i = i + 1
Loop
End Sub
See example below
Public Sub Listpng()
Const strFolder As String = "C:\SomeFolder\"
Const strPattern As String = "*.png"
Dim strFile As String
strFile = Dir(strFolder & strPattern, vbNormal)
Do While Len(strFile) > 0
Debug.Print strFile '<- view this in Immediate window; Ctrl+g will take you there
strFile = Dir
Loop
End Sub
There's a couple of procedures I use depending on whether I want subfolders as well.
This loops through the folder and adds path & name to a collection:
Sub Test1()
Dim colFiles As Collection
Dim itm As Variant
Set colFiles = New Collection
EnumerateFiles "C:\Users\michal\SkyDrive\csv\bossa\mstcgl_mst\", "*.xls*", colFiles
For Each itm In colFiles
Debug.Print itm
Next itm
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
This second way goes through the subfolders as well returning path & name. For some reason if you change InclSubFolders to False it only returns the name - got to sort that bit out.
Sub Test2()
Dim vFiles As Variant
Dim itm As Variant
vFiles = EnumerateFiles_2("C:\Users\michal\SkyDrive\csv\bossa\mstcgl_mst\", "xls*")
For Each itm In vFiles
Debug.Print itm
Next itm
End Sub
Public Function EnumerateFiles_2(sDirectory As String, _
Optional sFileSpec As String = "*", _
Optional InclSubFolders As Boolean = True) As Variant
EnumerateFiles_2 = Filter(Split(CreateObject("WScript.Shell").Exec _
("CMD /C DIR """ & sDirectory & "*." & sFileSpec & """ " & _
IIf(InclSubFolders, "/S ", "") & "/B /A:-D").StdOut.ReadAll, vbCrLf), ".")
End Function
I got this code from somewhere in the net, and it works fine for me. However my experience is not enough to run it in all subfolders of the main one ("C:\Folder\"). I would appreciate any suggestion.
Sub check()
Dim strFolder As String
Dim strFile As String
strFolder = "C:\Folder\"
strFile = Dir(strFolder & "*.*")
Do While Len(strFile) > 0
If InStr(strFile, "xxx") > 0 Then
Name strFolder & strFile As strFolder & Replace(strFile, "xxx", "yyy")
End If
strFile = Dir()
Loop
End Sub
You're much better off using the System.IO namespace(you'll need to add the Imports statement for it), as there is a Directories.GetFiles method that allows for an option to search AllDirectories within your specified folder
Imports System.IO;
Sub Check()
Dim strFolder As String = "C:\Folder\"
Dim strFiles() As String = Directory.GetFiles(strFolder, "*.*", SearchOption.AllDirectories)
For Each strFile As String In strFiles
If strFile.Contains("xxx") Then
File.Move(strFolder & strFile, strFolder & strFile.Replace("xxx", "yyy"))
End If
Next
End Sub
I'm trying to crawl through a certain drive and grab data off of certain .xls files that are buried in sub-directories. The drive is over a TB, and the folders don't all have the same hierarchy, so I'm crawling through all of them. So far, the script works great.
The problem is, there are zipped files in the drive. At least half the files are in zipped format. How can I crawl through these files as well?
Here is the part of my code that crawls through the sub-directories. There is another function "TrailingSlash" which just appends a "\" to the string if it doesn't already have one. I give credit to the author in my comments.
Public Function recursiveDir(colFiles As Collection, strFolder As String, strFileSpec As String, bIncludeSubfolders As Boolean) as Collection
'From Ammara.com/access_image_faq/recursive_folder_search.html
'Recursive function to search document tree from specific file extension
Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant
Dim colFiles As New Collection
Dim counter As Integer
'Add files in strFolder matching strFileSpec to colFiles
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
On Error Resume Next
Do While strTemp <> vbNullString
colFiles.Add (strFolder & strTemp)
counter = counter + 1
Debug.Print ("files found: " & counter)
strTemp = Dir
Loop
If bIncludeSubfolders Then
'Fill colFolders with list of subdirectories of strFolder
strTemp = Dir(strFolder, vbDirectory)
Do While strTemp <> vbNullString
If (strTemp <> ".") And (strTemp <> "..") Then
If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
colFolders.Add strTemp
End If
End If
strTemp = Dir
Loop
'Call recursiveDir for each subfolder in colFolders
For Each vFolderName In colFolders
Call recursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
Next vFolderName
End If
recursiveDir = colFiles
End Function
The function adds all the path strings to the collection "colFolders", which I then use to open and extract data from. I'm now thinking there may not be a simple way to return a string path to a file within a zipped folder. There may need to be a separate function that is called when this function encounters a zip, that in turn crawls through the zipped folder and extracts the specific file to a local destination (as long as I don't have to extract the whole folder, we should be good).
I'm kind of lost in what I should do. Googleing around points me towards using shell.Application. I know nothing of shells, is this the path I should take?
Thanks SO - you all are awesome!
Try this code instead to search through subfolders:
Sub SO()
Dim x, i
x = GetFiles("C:\Users\SO\Folder", "*.xls*", True) '// x becomes an array of files found
For Each i In x
Debug.Print i
Next i
End Sub
'-------------------------------------------------
Function GetFiles(StartPath As String, FileType As String, SubFolders As Boolean) As Variant
StartPath = StartPath & IIf(Right(StartPath, 1) = "\", vbNullString, "\") 'Sanity check
GetFiles = Split(Join(Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR """ & StartPath & FileType & """ " & _
IIf(SubFolders, "/S", vbNullString) & " /B /A:-D").StdOut.ReadAll, vbCrLf), ":"), "#"), "#")
End Function
But for zip files, there isn't really anything native to windows that will allow you to do this other than the CreateObject("Shell.Application").Namespace(zipName).Items method.
I prefer to use 7-zip which is free, open-source and has a great command line utility which means you can access it via VBA too using the CreateObject("WScript.Shell") method (like above)