Copy random 25 files from 1300 to another folder with VBA - excel

I have 1300 excel files on a server, with revenues in them. I need to compare these revenues with one pivot file to make sure the revenues are the same in the actual 2 files. Because it is on a server, opening all of them from a server would be pretty slow, thats why I want to copy a sample of them (25 excel files) to my compter first, and then run my comparison macro from this folder. But I want to make the copying process automatized, so I somehow need to select randomly 25 of these files, and then copy it to an other folder.
I have a code to copy all of the files from one folder to another, but I need the random selection to it.
Thanks.
Sub Copy_Folder()
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
FromPath = "C:\Users\NagyI2\Documents\Macro testing"
ToPath = "C:\Users\NagyI2\Documents\Copy test"
If Right(FromPath, 1) = "\" Then
FromPath = Left(FromPath, Len(FromPath) - 1)
End If
If Right(ToPath, 1) = "\" Then
ToPath = Left(ToPath, Len(ToPath) - 1)
End If
Set FSO = CreateObject("scripting.filesystemobject")
If FSO.FolderExists(FromPath) = False Then
MsgBox FromPath & " doesn't exist"
Exit Sub
End If
FSO.CopyFolder Source:=FromPath, Destination:=ToPath
End Sub

The files-collection of a folder-object gives a list of files in that folder. However, you cannot access to one of the files by index, just by name. So the following code creates first an array with the names of all files. Then, in a second loop, a file index is created by random, and the file is copied to the destination folder.
Dim FSO As Object, folder a Object, file as Object
Set folder = fso.GetFolder(FromPath)
Dim fList() As String, i As Long
ReDim fList(1 To folder.Files.Count)
For Each file In folder.Files
i = i + 1
fList(i) = file.Name
Next file
Dim copyCount As Long, fIndex As Long
copyCount = 0
Do While copyCount < 25 And copyCount < folder.Files.Count
fIndex = Int(Rnd * folder.Files.Count) + 1
If fList(fIndex) <> "" Then
Set file = folder.Files(CStr(fList(fIndex)))
file.Copy ToPath, True
fList(fIndex) = "" ' Mark this file as copied to prevent that it is picked a 2nd time
copyCount = copyCount + 1
End If
Loop

A possible solution for your task is:
Read all filenames in FromPath in an array.
In a loop with 25 runs generate a random number based on the length of the array.
Ensure that you did not copy by chance a file you already have copied.

it must be very fast
Sub CopyFiles()
Dim objRows() As String
Dim fso As Object
Dim randNum As Long
Source = "C:\Users\NagyI2\Documents\Macro testing\"
Destination = "C:\Users\NagyI2\Documents\Copy test\"
randNum = 25 ' set random number
results = CreateObject("WScript.Shell").Exec("CMD /C DIR """ & Source & "*.xls*"" /S /B /A:-D").StdOut.ReadAll ' get file list in Source
objRows = Split(results, vbCrLf) ' move list to array
ReDim Preserve objRows(UBound(objRows) - 1) ' trim last empty value
sList = getRand(randNum, objRows) ' get randomized list
Set fso = VBA.CreateObject("Scripting.FileSystemObject")
For Each sFile In sList
Call fso.CopyFile(sFile, Destination, True) ' copy randomized files
Next sFile
End Sub
Function getRand(rKey As Long, sArr As Variant) As Variant
Randomize
Set dict = CreateObject("Scripting.Dictionary")
upperbound = UBound(sArr)
lowerbound = LBound(sArr)
If rKey > upperbound Then getRand = sArr: Exit Function
For i = 1 To rKey
key = Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
If Not dict.Exists(key) Then dict.Add key, sArr(key) Else i = i - 1
Next i
getRand = dict.Items
End Function

Related

After using hyperlink to open several pdf files, the Acrobat window is in full mode. How to snap_to_left that window from the same VBA Excel macro?

I have to review scanned documents in order to check the certainty of data in other documents called resolutions.
Each pdf file name contains the number and the date of passing of each resolution.
I made a VBA excel macro that reads all the pdf files in a folder, extracts the date of passing, and builds a list ordered chronologically according to that dates. Latest to newest. Later the macro opens the pdf files in that order by using ActiveWorkbook.FollowHyperlink.
I snap the big screen of my PC into two parts, the leftmost for Adobe Acrobat, and the rightmost for the database containing the data records.
Problem is that after opening the pdf files, Adobe Acrobat is opened in full mode.
I have this code that functions perfectly but DOES NOT RETURN the Adobe Acrobat to the leftmost part of the screen.
Sub OpenPDF()
Dim i As Long, j As Long, k As Long, m As Long, uFila As Long, n As Long
Dim oFSO As Object, oFile As Object
Dim oCarpeta As Object
Dim oArchivo As Object
Dim x As String, z As String, y() As Variant, Hoja As Worksheet
Dim Partes() As String, returnValue As Boolean, bMinimize As Integer
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oCarpeta = oFSO.GetFolder("X:\_RIE\Resoluciones")
n = 0: bMinimize = 1
For Each oArchivo In oCarpeta.Files
n = n + 1
ReDim Preserve y(n)
x = oArchivo.Name
Partes = Split(x, "-")
x = Trim(Partes(3))
x = Right(x, 4) & Mid(x, 3, 2) & Left(x, 2) ' x take the yyyymmdd format
' An "*" is inserted for future use in spliting the long name
y(n) = x & "*" & oArchivo.Name
Next oArchivo
'The Ordenado function takes the array sent and order it
y = Ordenado(y)
'Now the Acrobat app is called to close all possible pdf files opened.
Set oFSO = CreateObject("AcroExch.App")
oFSO.CloseAllDocs
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oCarpeta = oFSO.GetFolder("x:\_RIE\Resoluciones")
MsgBox "The documents will be open in chronological order." & Chr(13) & _
"Oldest to the left and so on." & Chr(13) & _
"At final you will have to restore the Adobe Acrobat window," & Chr(13) & _
"by clicking the Windows Key + Left Arrow Key."
For i = 1 To n
Partes = Split(y(i), "*")
y(i) = oCarpeta.Path & "\" & Partes(1)
Next
'This loop opens directly each pdf file.
For i = 1 To n
x = y(i)
ActiveWorkbook.FollowHyperlink (x)
Next i
'The Adobe Acrobat is invoked
Set oFSO = Nothing
Set oFSO = CreateObject("AcroExch.App")
With oFSO
.Show
'All smooth until here
'Next line is not functioning
.Restore True
End With
'That's the reason why the user has to pulse the Restore icon
'in the rightmost upper corner of the screen or
'press the Windows Key + Left Arrow Key.
Set Hoja = ActiveWorkbook.Worksheets(1)
Hoja.Activate
End Sub
Function Ordenado(myArray As Variant)
Dim i As Long
Dim j As Long
Dim Temp
'Sort the Array A-Z
For i = LBound(myArray) To UBound(myArray) - 1
For j = i + 1 To UBound(myArray)
If UCase(myArray(i)) > UCase(myArray(j)) Then
Temp = myArray(j)
myArray(j) = myArray(i)
myArray(i) = Temp
End If
Next j
Next i
Ordenado = myArray
End Function

VBA script to run batch file from excel list, read result file, parse result file and write result to primary excel file

So, before I place my code, I'll explain what I am trying to do, because I can't test the script myself due to what it is supposed to do, effecting what it must do. I know this is a bit odd, but bear with me please.
Once every two weeks or so, we currently run batch files to update a specific tool on all the WS's in our organization.
Yes, we do have tool propagation software, but as this specific tool is extremely important, we don't trust it's distribution to any automated method which have proven in most cases to fail without us being able to understand the reason.
So, I wrote a few simple command batch files which run the installation command, and write the output to a text file which we then manually go through to find which ws's it was installed on, and which it wasn't.
The ws's on which it was not installed are the ws's we know we know due to the failure, that we have additional issues with and we then put all our effort into finding and fixing those issues.
As you can imagine, it's a time consuming effort, and I have decided I want to automate as much as possible of the manual check, in order to know quickly which ws's failed, and the fail code.
I start out with a list of ws names in excel.
For example,
K190ASSn1.domainname
m930eastgate.domainname
n190alka.domainname
n190amsv.domainname
n190amzi.domainname
N190ARME.domainname
N190AVMA.domainname
N190AVNT.domainname
n190chockstest.domainname
N190DLCR.domainname
N190DNBS.domainname
N190edsh.domainname
n190ehma2.domainname
N190EISH.domainname
I wrote my script to do the following:
Read all the ws names from column A into an array.
Loop through the array, and use the Shell function to call an external cmd file which then runs, and writes the result of the run into a TXT file located in a directory on the D drive called "Minstall".
I then read the names of all the files created in that directory into a new array.
I sort both arrays from A to Z (using a script I found online) to get everything in the same order for the next stage.
I then loop through the file names in the 2nd array, and read each file into a text field which I then parse to find the result of the script run.
That result is then written into a third array in the same logical position of the file name I read.
Finally, I re-write the file names back to the worksheet, overwriting what was there, and in the adjacent column, I write the run result from the relevant cell position in the third array.
I will then end up with a file that contains all the data in one visible point (I hope).
At a later stage, I will add a script that will email the relevant team with a list of the ws's they need to deal with (Those with any run result different from zero), and what they need to do. But that's not for the here and now.
Since if I run the code and it works (I hope) it would perform the update, and I do not yet want to do that, what I am really looking for, is additional eyes to go over my code, to see if what I wrote for each action as defined above is correct and will work, and if there is a way to perhaps write what I did, better.
In general, I went over each stage and everything "looks" good.
Anyone willing to assist here ?
Added by request of #CDP1802:
Examples of the two different results that can be found in the text files. One contains a result of zero, meaning that the script worked. The other contains a code of 1603, which is a generic "there's a problem captain but I don't know what it is" response from M$ msiexec.
The spaces between the lines of the text are what appear in the actual text file.
Example 1 (0 response)
PsExec v2.33 - Execute processes remotely
Copyright (C) 2001-2021 Mark Russinovich
Sysinternals - www.sysinternals.com
C:\Windows\system32>msiexec /i "\\server\Minstall\Installation.msi" /qn ACCEPTEULA=YES REPORTSERVER=server.domainname USESSL=TRUE REPORTSERVERPORT=443 IGNORESSLERRORS=TRUE InstallCertificates=yes /l*v C:\Windows\TEMP\install_log4258289.txt
Connecting to K190LPRTLV4.iaadom...
Starting PSEXESVC service on K190LPRTLV4.iaadom...
Copying authentication key to K190LPRTLV4.iaadom...
Connecting with PsExec service on K190LPRTLV4.iaadom...
Copying d:\Install425.bat to K190LPRTLV4.iaadom...
Starting d:\Install425.bat on K190LPRTLV4.iaadom...
Install425.bat exited on K190LPRTLV4.iaadom with error code 0.
Example 2 (1603 response)
PsExec v2.33 - Execute processes remotely
Copyright (C) 2001-2021 Mark Russinovich
Sysinternals - www.sysinternals.com
C:\Windows\system32>msiexec /i "\\server\Minstall\Installation.msi" /qn ACCEPTEULA=YES REPORTSERVER=server.domainname USESSL=TRUE REPORTSERVERPORT=443 IGNORESSLERRORS=TRUE InstallCertificates=yes /l*v C:\Windows\TEMP\install_log4258289.txt
Connecting to K190LPRTLV3.iaadom...
Starting PSEXESVC service on K190LPRTLV3.iaadom...
Copying authentication key to K190LPRTLV3.iaadom...
Connecting with PsExec service on K190LPRTLV3.iaadom...
Copying d:\Install425.bat to K190LPRTLV3.iaadom...
Starting d:\Install425.bat on K190LPRTLV3.iaadom...
Install425.bat exited on K190LPRTLV3.iaadom with error code 1603.
The updated code is as follows:
Option Explicit
Sub Check_Files()
Const Col_Names = "A"
Const Col_Result = "B"
Const Row_Text = 4 'first line of text and result
Dim wb As Workbook
Dim wsMain As Worksheet
Dim WSNames() As String 'Will hold all the ws names as an array read from column A
Dim WSResult() 'Will hold result for specific ws
Dim DirectoryListArray() As string
ReDim DirectoryListArray(3000) 'Set the directory listing array size to 3000 as a max count
Dim NumberArray() As Long
Dim lastrow As Long, FileCount As Long, NumberCount As Long, r As Long, i As Long, j As Long
Dim awsname as string, strDir As string, strPath As string
Dim item as variant
Dim ReadFile As String, text As String, textline As String, RetCode As Integer
Set wb = ActiveWorkbook
With wb
Set wsMain = .Sheets("Main")
End With
'Copy ws names into array for speed
With wsMain
lastrow = .Cells(.Rows.Count, Col_Names).End(xlUp).Row
If lastrow < Row_Text Then
MsgBox "No ws names found in column " & Col_Names, vbCritical
Exit Sub
End If
WSNames = .Cells(1, Col_Names).Resize(lastrow).Value2
ReDim WSResult(1 To lastrow)
End With
'Write how many names were read into array
Cells(1,3) = "Number of names read into array is " & lastrow
'loop through all ws names and run the batch file for each one
For r = Row_Text To UBound(WSNames)
awsname = WSNames(r, 1) 'Read in next ws name from array
Runcmd(awsname)
Next r
'Write how many batch files were run into worksheet
Cells(2,3) = "Number of batch files run is " & r
'count how many text files have been created
strDir = "D:\Minstall"
strPath = strDir & "\*.txt"
'Loop through all the files in the directory by using Dir$ function
MyFile = Dir$(strPath)
Do While MyFile <> ""
DirectoryListArray(FileCount) = MyFile
MyFile = Dir$
FileCount = FileCount + 1
Loop
'Reset the size of the array without losing its values by using Redim Preserve
Redim Preserve DirectoryListArray(FileCount - 1)
'Write how many text files were found
Cells(3,3) = "Number of txt files found is " & FileCount
''Debug.Print writes the results to the Immediate window (press Ctrl + G to view it)
'For FileCount = 0 To UBound(DirectoryListArray)
'Debug.Print DirectoryListArray(FileCount)
'Next FileCount
'Sort the arrays so that we have the same order in both arrays
'Since both arrays should in effect have the same amount of elements
'sorting names array from A to Z
For i = LBound(WSNames) To UBound(WSNames)
For j = i + 1 To UBound(WSNames)
If UCase(WSNames(i,1)) > UCase(WSNames(j,1)) Then
Temp = WSNames(j,1)
WSNames(j,1) = WSNames(i,1)
WSNames(i,1) = Temp
End If
Next j
Next i
'sorting file array from A to Z
For i = LBound(DirectoryListArray) To UBound(DirectoryListArray)
For j = i + 1 To UBound(DirectoryListArray)
If UCase(DirectoryListArray(i,1)) > UCase(DirectoryListArray(j,1)) Then
Temp = DirectoryListArray(j,1)
DirectoryListArray(j,1) = DirectoryListArray(i,1)
DirectoryListArray(i,1) = Temp
End If
Next j
Next i
NumberCount = 0
'Loop through files in directory based on what's in array
For i = LBound(DirectoryListArray) To UBound(DirectoryListArray)
ReadFile = "D:\Minstall" & "\" & DirectoryListArray(NumberCount)
ReadFile = Application.GetOpenFilename()
Open myFile For Input As #1
Do Until EOF(1)
Line Input #1, textline
text = text & textline
Loop
Close #1
RetCode = InStr(text, "with error code ")
NumFound = Mid(text, posLat + 16, 1)
If NumFound > 0 Then
NumFound = Mid(text, posLat + 16, 4)
'Write the number found into the number array
NumberArray(NumberCount) = NumFound
NumberCount = NumberCount + 1
Else
'Write the number found into the number array
NumberArray(NumberCount) = NumFound
NumberCount = NumberCount + 1
End If
Next i
'Write the ws name into the worksheet and write the number found to the cell to the right of the ws name in the worksheet
For i = LBound(WSNames) To UBound(WSNames)
Cells(j, Col_Names) = WSNames(i,1)
Cells(j, Col_Result) = NumberCount(i,1)
j = j + 1
Next i
End Sub
Sub Runcmd(awsname)
Dim PathToBatch as string
'Set the path and batch file with the ws name as a parameter for the batch to run
PathToBatch = "D:\min425.cmd" & " " & awsname
Call Shell(PathToBatch, vbNormalFocus)
End Sub
The main changes are using a FileSystemObject to read the text files, a Regular Expression to extract the error code, and a WScript.Shell object to run the batch file so macro waits for the script to complete. I have commented out the RunCmd line and replaced it with a RunTest that creates a text file so you can test it.
Option Explicit
Sub Check_Files()
Const DIR_OUT = "D:\Minstall"
Const COL_NAMES = "A"
Const COL_RESULTS = "B"
Const COL_TS = "C" ' timestamp
Const COL_ERR = "D" ' Shell errors
Const ROW_START = 4 'first line of text and result
Dim wb As Workbook, ws As Worksheet
Dim rng As Range, arNames, awsname As String
Dim result As String, txtfile As String
Dim i As Long, LastRow As Long, n As Long, r As Long, colour As Long
Dim t0 As Single: t0 = Timer
Set wb = ThisWorkbook
Set ws = wb.Sheets("Main")
With ws
' read names into array
LastRow = .Cells(.Rows.Count, COL_NAMES).End(xlUp).Row
n = LastRow - ROW_START + 1
If n < 1 Then
MsgBox "No records found on " & ws.Name, vbCritical
Exit Sub
Else
Set rng = .Cells(ROW_START, COL_NAMES).Resize(n)
arNames = rng.Value2
'Write how many names were read into array
.Cells(1, 3) = "Number of names read into array is " & n
End If
' clear results
With rng.Offset(, 1).Resize(, 3)
.Clear
.Interior.Pattern = xlNone
End With
' run commands with WsSCript
Dim WShell As Object
Set WShell = CreateObject("WScript.Shell")
For i = 1 To UBound(arNames)
awsname = arNames(i, 1)
r = ROW_START + i - 1
' RUN COMMANDS
.Cells(r, COL_ERR) = RunTest(awsname, DIR_OUT)
'.Cells(r, COL_ERR) = RunCmd(WShell, awsname, DIR_OUT)
.Cells(r, COL_TS) = Format(Now, "yyyy-mm-dd HH:MM:SS") ' timestamp
Next
Set WShell = Nothing
'Write how many batch files were run into worksheet
.Cells(2, 3) = "Number of batch files run is " & UBound(arNames)
' read text files with FSO, parse with regex
Dim FSO As Object, ts As Object, regex As Object, txt As String
Set FSO = CreateObject("Scripting.FileSystemObject")
Set regex = CreateObject("VBScript.RegExp")
With regex
.Global = False
.MultiLine = True
.IgnoreCase = True
.Pattern = "with error code (\d+)"
End With
n = 0
' process text file
For i = 1 To UBound(arNames)
r = ROW_START + i - 1
awsname = arNames(i, 1)
txtfile = DIR_OUT & awsname & ".txt"
result = ""
' does file exist for this machine
If FSO.fileExists(txtfile) Then
' read file
n = n + 1
Set ts = FSO.openTextfile(txtfile)
txt = ts.readall
ts.Close
' extract error number from text
If regex.test(txt) Then
result = regex.Execute(txt)(0).submatches(0)
End If
' error codes
If result = "0" Then
colour = RGB(0, 255, 0) ' green
Else
colour = RGB(255, 255, 0) ' yellow
End If
Else
result = "No Text File"
colour = RGB(255, 0, 0) ' red
End If
' result
With .Cells(r, COL_RESULTS)
.Value2 = result
.Interior.Color = colour
End With
Next
.Cells(3, 3) = "Number of txt files found is " & n
.Columns.AutoFit
End With
MsgBox "Text files found for " & n, vbInformation, Format(Timer - t0, "0.0 secs")
End Sub
Function RunTest(awsname As String, folder As String) As String
Dim FSO, ts, errno: Set FSO = CreateObject("Scripting.FileSystemObject")
If Rnd() < 0.3 Then errno = 0 Else errno = Int(10000 * Rnd())
Set ts = FSO.createTextFile(folder & awsname & ".txt")
ts.write "This is with error code " & errno & "." & vbCrLf & vbCrLf
ts.Close
RunTest = "Test"
End Function
Function RunCmd(WShell, awsname As String, folder As String) As String
MsgBox "RunCmd DISABLED", vbCritical: End
'Const SCRIPT = "D:\min425.cmd"
'Dim cmd: cmd = SCRIPT & " " & awsname
'RunCmd = WShell.Run(cmd, vbNormal, True) ' waittocomplete
End Function

Populate a combo box with a list of last 10 latest folders from a directory

I have a combo box that I want to be filled with a list of last 10 latest folders in a specified directory. Say,
There are 40 folders. In the combo box it should list the latest 10 folders.
Thank you,
Private Sub UserForm_Initialize()
Dim name
For Each name In ListDirectory(Path:="C:\Users\AllertonFC\Documents\FA Level 1 & Level 2\", AttrInclude:=vbDirectory, AttrExclude:=vbSystem Or vbHidden)
Me.ComboBox1.AddItem name
Next name
End Sub
Function ListDirectory(Path As String, AttrInclude As VbFileAttribute, Optional AttrExclude As VbFileAttribute = False) As Collection
Dim Filename As String
Dim Attribs As VbFileAttribute
Set ListDirectory = New Collection
' first call to Dir() initializes the list
Filename = Dir(Path, AttrInclude)
While Filename <> ""
Attribs = GetAttr(Path & Filename)
' to be added, a file must have the right set of attributes
If Attribs And AttrInclude And Not (Attribs And AttrExclude) Then
ListDirectory.Add Filename, Path & Filename
End If
' fetch next filename
Filename = Dir
Wend
End Function
This should work, I find it easier to put values into a string and split it at the last minute into an array, also not using Dir, instead using a Scripting.FileSystemObject
Public Sub cBoxFiller()
Dim oFS As Object, SrcFldr As String, oFldr As Object, xFldr As Object
Dim FldrsTxt As String, FldrsAR() As String, GudCtr As Long
Dim cBoxTxt As String, i As Long
SrcFldr = "C:\Users\AllertonFC\Documents\FA Level 1 & Level 2\"
Set oFS = CreateObject("Scripting.FileSystemObject")
Set oFldr = oFS.getfolder(SrcFldr)
' Generate an Array of ALL SubFolders
FldrsTxt = ""
For Each xFldr In oFldr.subFolders
FldrsTxt = IIf(FldrsTxt = "", "", FldrsTxt & vbCrLf) & xFldr.name ' or xFldr.Path
Next xFldr
FldrsAR = Split(FldrsTxt, vbCrLf)
' Done
' Build a String of Last 10 Folders - separated by VbCrLf
GudCtr = 0
For i = UBound(FldrsAR) To LBound(FldrsAR) Step -1
If GudCtr < 10 Then
GudCtr = GudCtr + 1
cBoxTxt = IIf(cBoxTxt = "", "", cBoxTxt & vbCrLf) & FldrsAR(i)
End If
Next i
' Done
' Split into an Array & Assign to the ComboBox
ComboBox1.List = Split(cBoxTxt, vbCrLf)
' Done
End Sub

VBA - get all file properties

I want to get properties from all files in a folder. I have this already working for a fixed number of properties, my only concern is to find the last property's index, used in GetDetailsOf method, so that I can have all properties listed.
Function below returns count of properties, but is incorrect, because it's based on last non-empty property name. There are however a few indices with empty names (not sure if they can have values), followed by another indices which have property name with normal string.
I also tried On Error Resume Next with error indicating that last index has already been used, but there never was an error and it resulted in an endless loop, apparently GetDetailsOf will accept every long >=0.
I would also like to know if the number of file properties is the same for each folder on one machine.
EDIT: I may have not clearly expressed it, what I want is to get index of last property name, so that I can check values for all existing properties.
EDIT 2: Here's a link to my file, listing properties for all files in selected folder and subfolders of all levels. There may be some not handled bugs (I already sorted one with shortcuts crashing macro), Windows path length limit comes to my mind, but it will in general work for selected folder.
Main function of interest is CountProperties in list_properties module. It decides on how many property columns will be returned.
https://drive.google.com/open?id=1TRIZJoGnHXs9LJtxDBj9rp27ngkects-
Function CountProperties(ByRef FldPath) As Long
Dim objShell As Object
Dim objFolder As Object
Dim testStr As String
Dim propertyCnt As Long
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(Left(FldPath, Len(FldPath) - 1)) 'no slash in the end
Do
testStr = vbNullString
testStr = objFolder.GetDetailsOf(objFolder.Items, propertyCnt)
If testStr = vbNullString Then Exit Do
propertyCnt = propertyCnt + 1
Loop
CountProperties = propertyCnt
End Function
I am not entirely clear what the end goal of this is but the following should extract all the info you need.
Includes: Count of total set properties by file, folder count of set properties , each file's extended properties values and whether all files in a folder have the same number of properties with assigned values. I'd probably re-factor the function but await your feedback.
Note:
I chose an array to be returned as I thought you might end up comparing folders and this way you can simply create a collection/dictionary of the returned arrays using the folder paths as keys. You can then access and compare items within the arrays across folders.
Code:
Option Explicit
''******************************************************************
'' folderInfo returns:
'' folderInfo(0) = PATH_FOLDER - folder path used
'' folderInfo(1) = AllFileProperties - Dictionary of arrays containing all the file properties of each file within the folder
'' folderInfo(2) = totalPropertiesSetInFolder - total count of extended properties <> vbNullString in the folder
'' folderInfo(3) = filePropertyCounts - dictionary of each file with its respective set property count
'' folderInfo(4) = AllFilesHaveSamePropertyCount - Boolean to say if all files in folder have same # extended properties set
''******************************************************************
Public Sub test()
Const PATH_FOLDER As String = "C:\Users\User\Desktop\TestFolder\"
Dim resultsArray()
resultsArray() = folderInfo(PATH_FOLDER) '<== All the info is now returned here
''***************************************************************************************
'' Examples of extracting the retrieved information from the array
''***************************************************************************************
'Example: folderInfo(0) = folderPath
Debug.Print "Folderpath = " & resultsArray(0)
Debug.Print String$(20, Chr$(60))
Debug.Print vbNewLine
''***************************************************************************************
'Example: folderInfo(1) = AllFileProperties
Debug.Print "AllFileProperties:"
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Set dict = resultsArray(1)
Dim key As Variant, arr(), i As Long
For Each key In dict.keys
Debug.Print "FileName = " & key
arr() = dict(key)
For i = LBound(arr, 1) To UBound(arr, 1)
Debug.Print arr(i, 1), arr(i, 2)
Next i
Debug.Print String$(20, Chr$(60))
Debug.Print vbNewLine
Next key
''***************************************************************************************
''Example: folderInfo(2) = totalPropertiesSetInFolder
MsgBox "Total properties set in folder = " & resultsArray(2)
''***************************************************************************************
''Example: folderInfo(3) = filePropertyCounts
Dim dict2 As Object
Set dict2 = CreateObject("Scripting.Dictionary")
Set dict2 = resultsArray(3)
Dim key2 As Variant
For Each key2 In dict2.keys
Debug.Print key2 & " set property count = " & dict2(key2)
Next key2
''***************************************************************************************
''Example: folderInfo(4) = AllFilesHaveSamePropertyCount
MsgBox "All files have the same # of set properties? = " & resultsArray(4)
End Sub
Public Function folderInfo(ByVal PATH_FOLDER As String) As Variant
Dim objShell As Object
Dim objFolder As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(Left$(PATH_FOLDER, Len(PATH_FOLDER) - 1))
'Retrieving Extended File Properties
Dim i As Long
Dim arrHeaders(35)
For i = 0 To 34
arrHeaders(i) = objFolder.GetDetailsOf(objFolder.items, i)
Next
Dim fileName As Object, setPropertyCount As Long, filePropertyCounts As Object, totalPropertiesSetInFolder As Long
Set filePropertyCounts = CreateObject("Scripting.Dictionary")
Dim AllFileProperties As Object
Set AllFileProperties = CreateObject("Scripting.Dictionary")
For Each fileName In objFolder.items
setPropertyCount = 0
Dim fileProperties(0 To 35, 0 To 35)
fileProperties(0, 0) = fileName
For i = 0 To 34
If objFolder.GetDetailsOf(fileName, i) <> vbNullString Then setPropertyCount = setPropertyCount + 1
fileProperties(i + 1, 1) = arrHeaders(i)
fileProperties(i + 1, 2) = objFolder.GetDetailsOf(fileName, i)
' Debug.Print i & vbTab & arrHeaders(i) _
' & ": " & objFolder.GetDetailsOf(fileName, i)
' Debug.Print vbNewLine
Next i
'Debug.Print fileName & ": setpropertyCount = " & setPropertyCount
filePropertyCounts.Add fileName.Name, setPropertyCount
AllFileProperties.Add fileName.Name, fileProperties
Next fileName
totalPropertiesSetInFolder = Application.WorksheetFunction.Sum(filePropertyCounts.items)
folderInfo = Array(PATH_FOLDER, AllFileProperties, totalPropertiesSetInFolder, filePropertyCounts, AllFilesHaveSamePropertyCount(filePropertyCounts))
End Function
Public Function AllFilesHaveSamePropertyCount(ByVal filePropertyCounts As Object) As Boolean
AllFilesHaveSamePropertyCount = True
Dim key As Variant
For Each key In filePropertyCounts.Keys
If filePropertyCounts(key) <> Application.WorksheetFunction.Max(filePropertyCounts.items) Then
AllFilesHaveSamePropertyCount = False
Exit Function
End If
Next key
End Function
Example run:
Reference:
https://technet.microsoft.com/en-us/library/ee176615.aspx
After running some code to learn more about file properties obtained via GetDetailsOf, especially checking property names of thousands of folders on C, here is what I've found out (Windows 7):
Number of property names is constant for all these folders and all of them appear in the same order.
The maximum index of non-empty string property was 299 (0 to 299). There were 4 empty string names several indices near the end. #Slai claims that the number varies depending on Windows version, as new are added with another releases or updates.
I think that checking one folder with GetDetailsOf let's say from 500 to 0 and seeing index of 1st not empty name would be the way to find last index.
I would however recommend getting only needed properties, because processing time depends heavily on file type and while for some 50 GB directories containing 1500 files I could get 300 property values for all files in a few seconds, a directory with even less files, but all mp3, took minutes.

read folders and any document properties from excel?

I am wanting to try something and I'm fairly sure it's possible, but not really sure!!
In MS Excel (2003) can I write a VBA script which will open a location (eg: s://public/marketing/documents/) and list all the documents located within there (filename)?
The ultimate goal would be to have the document name, date last modified, date created and modified by name.
Is this possible? I'd like to return any found values in rows on a sheet. eg: type: FOLDER, type: Word Doc etc.
Thanks for any info!
Done that recently. Use the DSOFile object. In Excel-VBA you first need to create a reference to Dsofile.dll ("DSO OLE Document Properties Reader 2.1" or similar). Also check you have a reference to the Office library
First you may want to select the file path which you want to examine
Sub MainGetProps()
Dim MyPath As String
MyPath = GetDirectoryDialog()
If MyPath = "" Then Exit Sub
GetFileProps MyPath, "*.*"
End Sub
Let's have a nice Path selection window
Function GetDirectoryDialog() As String
Dim MyFD As FileDialog
Set MyFD = Application.FileDialog(msoFileDialogFolderPicker)
With MyFD
.AllowMultiSelect = False
.Show
If .SelectedItems.Count <> 0 Then
GetDirectoryDialog = .SelectedItems(1)
End If
End With
End Function
Now let's use the DSO object to read out info ... I reduced the code to the bare necessary
Private Sub GetFileProps(MyPath As String, Arg As String)
Dim Idx As Integer, Jdx As Integer, MyFSO As FileSearch, MyRange As Range, MyRow As Integer
Dim DSOProp As DSOFile.OleDocumentProperties
Set DSOProp = New DSOFile.OleDocumentProperties
Set MyRange = ActiveSheet.[A2] ' your output is nailed here and overwrites anything
Set MyFSO = Application.FileSearch
With MyFSO
.NewSearch
.LookIn = MyPath
.SearchSubFolders = True ' or false as you like
.Filename = Arg
.FileType = msoFileTypeAllFiles
If .Execute() > 0 Then
MsgBox .FoundFiles.Count & " file(s) found." ' to see what you will get
For Idx = 1 To .FoundFiles.Count
DSOProp.Open .FoundFiles(Idx) ' examine the DSOProp element in debugger to find all summary property names; not all may be filled though
Debug.Print .FoundFiles(Idx)
Debug.Print "Title: "; DSOProp.SummaryProperties.Title
Debug.Print "Subject: "; DSOProp.SummaryProperties.Subject
' etc. etc. write it into MyRange(Idx,...) whatever
' now hunt down the custom properties
For Jdx = 0 To DSOProp.CustomProperties.Count - 1
Debug.Print "Custom #"; Jdx; " ";
Debug.Print " Name="; DSOProp.CustomProperties(Jdx).Name;
If DSOProp.CustomProperties(Jdx).Type <> dsoPropertyTypeUnknown Then
Debug.Print " Value="; DSOProp.CustomProperties(Jdx).Value
Else
Debug.Print " Type=unknowwn; don't know how to print";
End If
MyRow = MyRow + 1
Next Jdx
DSOProp.Close
Next Idx
Else
MsgBox "There were no files found."
End If
End With
End Sub
and that should be it
good luck MikeD

Resources