I've got an excel macro which is reading XML values from one file and replicating them in a second. I can't just copy files, as the second file has more and different stuff in it, and the user input determins what is being mapped. E.g. to use the classic example of a movie database, the user picks which genres to copy from source to target. I need to maps specific values across; the XPaths of the source and target are in a spreadsheet. Not all of the tags exist in the new XML file, so they need to be created my my code before their values can be populated.
I've got a great start from Greg-R's work at Create xml file based on xPath from Excel with VBA ; but his code doesn't handle numbered nodes. I've easily stripped the number from the target tag, but can't figure out the correct methods for adding the attribute to the node.
E.g. the XPath could be //Movies/Title[#number=1]/Actor[#number=5].Name
Here's what I've got so far:
Sub makeXPath(xmldoc As Object, xpath As String)
'Original code from: https://stackoverflow.com/questions/12149941/create-xml-file-based-on-xpath-from-excel-with-vba
Dim partsOfPath() As String
Dim oNodeList As IXMLDOMNodeList
Dim strXPathQuery As String
Dim sParent As String
Dim objRootElem As IXMLDOMElement
Dim objMemberElem As IXMLDOMElement
Dim objMemberName As IXMLDOMElement
Dim objParent As Object
Set objParent = xmldoc
partsOfPath = Split(xpath, "/")
For i = LBound(partsOfPath) To UBound(partsOfPath)
If strXPathQuery > "" Then strXPathQuery = strXPathQuery & "/"
strXPathQuery = strXPathQuery & partsOfPath(i)
Set oNodeList = xmldoc.SelectNodes(strXPathQuery)
If oNodeList.Length = 0 Then
'if I don't have the node, create it
Debug.Print "partsOfPath(" & i & ") = " & partsOfPath(i)
NumberPos = InStr(partsOfPath(i), "[#number=")
If NumberPos > 0 Then
'Numbered node, extract the number
ElementName = Left(partsOfPath(i), NumberPos - 1)
'Len("[#number=") = 9. Speed the code up by not calculating it each time. Every little bit helps!
NodeNumber = Mid(partsOfPath(i), NumberPos + 9, Len(partsOfPath(i)) - NumberPos - 9)
Else
ElementName = partsOfPath(i)
NodeNumber = ""
End If
Set objMemberElem = xmldoc.createElement(ElementName)
objParent.appendChild objMemberElem
If Not NodeNumber = "" Then
objMemberElem.createAttribute ("number") '<<<------ This bit is throwing errors :(
.createAttribute ("number")
objParent.Attributes.setNamedItem(objAttr).Text = NodeNumber
End If
'setting the parent for the next element of the path
Set objParent = objMemberElem
Else
'setting parent to first iteration, until I make adjustment otherwise later
Set objParent = oNodeList.Item(0)
End If
Next
End Sub
I've researched this til I'm blind (How many tabs can Chrome handle?) and tried various methods, but none are working. What are the methods I should be using?
Thanks for your help legends!
Just like createElement, createAttribute is a method of the xml document, not of a node like objMemberElem.
This should work:
If Not NodeNumber = "" Then
Set objAttr = xmldoc.createAttribute("number")
objAttr.Value = NodeNumber
objMemberElem.Attributes.setNamedItem objAttr
End If
Related
Trying to use Excel VBA to capture all the file attributes from files on disk, including extended attributes. Was able to get it to loop through the files and capture the basic attributes (that come from the file system):
File Path
File Name
File Size
Date Created
Date Last Accessed
Date Last Modified
File Type
Would also like to capture the extended properties that come from the file itself:
Author
Keywords
Comments
Last Author
Category
Subject
And other properties which are visible when right clicking on the file.
The goal is to create a detailed list of all the files on a file server.
You say loop .. so if you want to do this for a dir instead of the current document;
Dim sFile As Variant
Dim oShell: Set oShell = CreateObject("Shell.Application")
Dim oDir: Set oDir = oShell.Namespace("c:\foo")
For Each sFile In oDir.Items
Debug.Print oDir.GetDetailsOf(sFile, XXX)
Next
Where XXX is an attribute column index, 9 for Author for example.
To list available indexes for your reference you can replace the for loop with;
for i = 0 To 40
debug.? i, oDir.GetDetailsOf(oDir.Items, i)
Next
Quickly for a single file/attribute:
Const PROP_COMPUTER As Long = 56
With CreateObject("Shell.Application").Namespace("C:\HOSTDIRECTORY")
MsgBox .GetDetailsOf(.Items.Item("FILE.NAME"), PROP_COMPUTER)
End With
You can get this with .BuiltInDocmementProperties.
For example:
Public Sub PrintDocumentProperties()
Dim oApp As New Excel.Application
Dim oWB As Workbook
Set oWB = ActiveWorkbook
Dim title As String
title = oWB.BuiltinDocumentProperties("Title")
Dim lastauthor As String
lastauthor = oWB.BuiltinDocumentProperties("Last Author")
Debug.Print title
Debug.Print lastauthor
End Sub
See this page for all the fields you can access with this: http://msdn.microsoft.com/en-us/library/bb220896.aspx
If you're trying to do this outside of the client (i.e. with Excel closed and running code from, say, a .NET program), you need to use DSOFile.dll.
'vb.net
'Extended file stributes
'visual basic .net sample
Dim sFile As Object
Dim oShell = CreateObject("Shell.Application")
Dim oDir = oShell.Namespace("c:\temp")
For i = 0 To 34
TextBox1.Text = TextBox1.Text & oDir.GetDetailsOf(oDir, i) & vbCrLf
For Each sFile In oDir.Items
TextBox1.Text = TextBox1.Text & oDir.GetDetailsOf(sFile, i) & vbCrLf
Next
TextBox1.Text = TextBox1.Text & vbCrLf
Next
I was finally able to get this to work for my needs.
The old voted up code does not run on windows 10 system (at least not mine). The referenced MS library link below provides current examples on how to make this work. My example uses them with late bindings.
https://learn.microsoft.com/en-us/windows/win32/shell/folder-getdetailsof.
The attribute codes were different on my computer and like someone mentioned above most return blank values even if they are not. I used a for loop to cycle through all of them and found out that Title and Subject can still be accessed which is more then enough for my purposes.
Private Sub MySubNamek()
Dim objShell As Object 'Shell
Dim objFolder As Object 'Folder
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace("E:\MyFolder")
If (Not objFolder Is Nothing) Then
Dim objFolderItem As Object 'FolderItem
Set objFolderItem = objFolder.ParseName("Myfilename.txt")
For i = 0 To 288
szItem = objFolder.GetDetailsOf(objFolderItem, i)
Debug.Print i & " - " & szItem
Next
Set objFolderItem = Nothing
End If
Set objFolder = Nothing
Set objShell = Nothing
End Sub
Lucky discovery
if objFolderItem is Nothing when you call
objFolder.GetDetailsOf(objFolderItem, i)
the string returned is the name of the property, rather than its (undefined) value
e.g. when i=3 it returns "Date modified"
Doing it for all 288 values of I makes it clear why most cause it to return blank for most filetypes
e.g i=175 is "Horizontal resolution"
I'm trying to link shape data field from external data like excel.
As #JohnGoldsmith suggested I used DropLinked but "I'm getting object name not found" error.
My main agenda is drop multiple shapes on drawing with shape data field "Name", then fill all the shape data field using external data in order. I also used spatial search for dropping shapes on drawing(Thanks to #Surrogate). By the way I'm using Visio Professional 2019.
It's often a good plan to separate chained members so you can identify whether (as #Paul points out) you're having a problem getting to the stencil or the master.
Following is a modified example of link shapes to data. I've ditched all of the spatial search stuff as I think that's a separate issue. If you still have trouble with that I would ask another question and narrow your sample code to not include the data linking part - ie just drop shapes and try and change their position. Bear in mind there's also Page.Layout and Selection.Layout
I think you've got the adding the DataRecordsets in the other linked question, so this example makes the following assumptions:
You have a drawing document open
You have the "Basic Shapes" stencil open (note my version is metric "_M")
You have a DataRecordset applied to the document named "AllNames"
The above record set has a column named "Name" that contains the data you want to link
Public Sub ModifiedDropLinked_Example()
Const RECORDSET_NAME = "AllNames"
Const COL_NAME = "Name"
Const STENCIL_NAME = "BASIC_M.vssx"
Const MASTER_NAME = "Rectangle"
Dim vDoc As Visio.Document
Set vDoc = Application.ActiveDocument
Dim vPag As Visio.Page
Set vPag = Application.ActivePage
Dim vShp As Visio.Shape
Dim vMst As Visio.Master
Dim x As Double
Dim y As Double
Dim xOffset As Double
Dim dataRowIDs() As Long
Dim row As Long
Dim col As Long
Dim rowData As Variant
Dim recordset As Visio.DataRecordset
Dim recordsetCount As Integer
For Each recordset In vDoc.DataRecordsets
If recordset.Name = RECORDSET_NAME Then
dataRowIDs = recordset.GetDataRowIDs("")
xOffset = 2
x = 0
y = 2
Dim vStencil As Visio.Document
Set vStencil = TryFindDocument(STENCIL_NAME)
If Not vStencil Is Nothing Then
Set vMst = TryFindMaster(vStencil, MASTER_NAME)
If Not vMst Is Nothing Then
For row = LBound(dataRowIDs) + 1 To UBound(dataRowIDs) + 1
rowData = recordset.GetRowData(row)
For col = LBound(rowData) To UBound(rowData)
Set vShp = vPag.DropLinked(vMst, x + (xOffset * row), y, recordset.ID, row, False)
Debug.Print "Linked shape ID " & vShp.ID & " to row " & row & " (" & rowData(col) & ")"
Next col
Next row
Else
Debug.Print "Unable to find master '" & MASTER_NAME & "'"
End If
Else
Debug.Print "Unable to find stencil '" & STENCIL_NAME & "'"
End If
Else
Debug.Print "Unable to find DataRecordset '" & RECORDSET_NAME & "'"
End If
Next
End Sub
Private Function TryFindDocument(docName As String) As Visio.Document
Dim vDoc As Visio.Document
For Each vDoc In Application.Documents
If StrComp(vDoc.Name, docName, vbTextCompare) = 0 Then
Set TryFindDocument = vDoc
Exit Function
End If
Next
Set TryFindDocument = Nothing
End Function
Private Function TryFindMaster(ByRef vDoc As Visio.Document, mstNameU As String) As Visio.Master
Dim vMst As Visio.Master
For Each vMst In vDoc.Masters
If StrComp(vMst.NameU, mstNameU, vbTextCompare) = 0 Then
Set TryFindMaster = vMst
Exit Function
End If
Next
Set TryFindMaster = Nothing
End Function
The above code drops six shapes onto the page and adds a Shape Data row (Prop._VisDM_Name) with the corresponding data value. If you want the name text to appear in the shape then you would normally modify the master with an inserted field in the shape's text. (If you get stuck with this part then ask another question.)
One last point is that this example loops through the DataRecordset rows dropping a shape for each one, but there is also a Page.DropManyLinkedU method that allows you to this en masse.
I'm trying to write a VBA macro that will read through a text document and place specific words into columns. UPDATE: Here's a sample of the file, apparently it's XML, so at least I learned something new today. So i guess what I need is a program to shed the XML parts, and place just the text into columns.
<Alarm>
<ID>1002</ID>
<Type>Fault</Type>
<Message>Bad Brake</Message>
<Tagname>error.e2</Tagname>
</Alarm>
<Alarm>
<ID>1004</ID>
<Type>Fault</Type>
<Message>No Motion</Message>
<Tagname>error.e4</Tagname>
</Alarm>
<Alarm>
<ID>1005</ID>
<Type>Fault</Type>
<Message>Upper safety door open</Message>
<Tagname>error.e5</Tagname>
</Alarm>
Ultimately, I'm trying to put the 4 digit error codes in column A (i.e. 1002, 1004...), and the error message in column B (i.e. Bad Brake, No motion....). I'll paste what I have so far, I tried coding it for just one pair of data to start. I'm stuck trying to get the error message into column B. The error messages all start in the same position on each line, but I can't figure out how to stop copying the text, since each error message is a different length of characters. Any ideas?
(P.S. - I apologize if the code is terrible, I've been interning as an electrical engineer, so my programming has gotten rather rusty.)
Private Sub CommandButton1_Click()
Dim myFile As String, textLine As String, ID As Integer, error_msg As Integer
myFile = "C:\Users\scholtmn\Documents\Projects\Borg_Warner_txt_file\BW_fault_codes.txt"
Open myFile For Input As #1
Do Until EOF(1)
Line Input #1, textLine
Text = Text & textLine
Loop
Close #1
ID = InStr(Text, "<ID>")
error_msg = InStr(Text, "<Message>")
Range("A1").Value = Mid(Text, ID + 4, 4)
Range("B1").Value = Mid(Text, error_msg + 9, (InStr(Text, " <") - 31))
End Sub
Please, try the next code:
Sub ExtractErrorsDefinition()
'it needs a reference to 'Microsoft XML, v6.0'
Dim XMLFileName As String, oXMLFile As New MSXML2.DOMDocument60, sh As Worksheet
Dim N As MSXML2.IXMLDOMNode, i As Long, arr
Set sh = ActiveSheet 'use here the necessary sheet
XMLFileName = "the full text file path" '"C:\Utile\Teste Corel\XMLtext.txt"
oXMLFile.Load (XMLFileName)
ReDim arr(1 To oXMLFile.SelectNodes("AlarmDictionary/Alarm").length, 1 To 2): i = 1
For Each N In oXMLFile.SelectNodes("AlarmDictionary/Alarm")
arr(i, 1) = N.SelectSingleNode("ID").Text: arr(i, 1) = N.SelectSingleNode("Message").Text: i = i + 1
Next
sh.Range("A2").Resize(UBound(arr), 2).value = arr
End Sub
It may work using late binding, but it is better to have the intellisense suggestion, especially when not very well skilled in working with XML.
If looks complicated to add such a reference, I can add a piece of code to automatically add it.
Please, run the next code to automatically add the necessary reference. Save your workbook and run the first code after:
Sub addXMLRef()
'Add a reference to 'Microsoft Scripting Runtime':
'In case of error ('Programmatic access to Visual Basic Project not trusted'):
'Options->Trust Center->Trust Center Settings->Macro Settings->Developer Macro Settings->
' check "Trust access to the VBA project object model"
Application.VBE.ActiveVBProject.References.AddFromFile "C:\Windows\System32\msxml6.dll"
End Sub
It looks like the txt file you are using is actually an xml file. If you changed the format, this piece of code I slightly adjusted from here should work fine.
Sub From_XML_To_XL()
Dim xmlWb As Workbook, xSWb As Workbook, xStrPath$, xfdial As FileDialog, _
xFile$, lr%, first As Boolean, r As Range
first = True
Set xfdial = Application.FileDialog(msoFileDialogFilePicker)
xfdial.AllowMultiSelect = False
xfdial.Title = "Select an XML File"
If xfdial.Show = -1 Then xStrPath = xfdial.SelectedItems(1) & ""
If xStrPath = "" Then Exit Sub
Set xSWb = ThisWorkbook
lr = xSWb.ActiveSheet.Range("a" & Rows.Count).End(xlUp).Row ' last used row, column A
xFile = xStrPath
Set xmlWb = Workbooks.OpenXML(xFile)
If first Then
Set r = xmlWb.Sheets(1).UsedRange ' with header
Else
xmlWb.Sheets(1).Activate
Set r = ActiveSheet.UsedRange
Set r = Range(Cells(3, 1), Cells(r.Rows.Count, r.Columns.Count))
End If
r.Copy xSWb.ActiveSheet.Cells(lr + 1, 1)
lr = xSWb.ActiveSheet.Range("a" & Rows.Count).End(xlUp).Row
xmlWb.Close False
first = False
End Sub
I think you'll find this task a lot easier if you take advantage of the fact it is in XML format. You can find more information about working with XML in VBA here.
As Ben Mega already stated: you have an XML-File - why not use XML-functionality.
Add "Microsoft XML, v6.0" to your project references - then you can use this code
Public Sub insertTextFromXML()
Dim objXML As MSXML2.DOMDocument60
Set objXML = New MSXML2.DOMDocument60
If Not objXML.Load("T:\Stackoverflow\Test.xml") Then
Err.Raise objXML.parseError.ErrorCode, , objXML.parseError.reason
End If
Dim nAlarm As MSXML2.IXMLDOMNode
'loop through all alarms and output ID plus message
For Each nAlarm In objXML.SelectNodes("AlarmDictionary/Alarm")
With nAlarm
Debug.Print .SelectSingleNode("ID").Text, .SelectSingleNode("Message").Text
End With
Next
'Filter for ID 1004
Set nAlarm = objXML.SelectSingleNode("AlarmDictionary/Alarm[ID=1004]")
Debug.Print nAlarm.XML
End Sub
You can google for VBA XPath to find out how to access the various values.
I am very new to VBA and I'm looking to use it to automate some of my processes. I have looked around this website (and others) and although I find very similar queries, I can't seem to find one that fits my needs exactly.
So far the closest thing I've found to what I'm looking to do is this: Wanting to create a search field and button to trigger VBA script to run
I have a source folder with all my data. My data is stored in multiple text files. Here is an example of what the data in the files looks like:
10001,1,205955.00
10001,2,196954.00
10001,3,4.60
10001,4,92353.00
10001,5,85015.00
10001,6,255.90
10001,7,804.79
10001,8,205955.00
10001,9,32465.00
In each row, the first number is a geographic code, second number is a numeric code for a specific indicator (not important for what I'm trying to do), and the third number is the value I want to import into my spreadsheet. Each geographic code is associated with 2247 rows.
I want to use a search box control in Excel that I can type a specific geographic code into, click a button and then the macro would run, searching the files for that specific code and then importing all the values - in the order they are listed in the data file - into my desired range in the workbook.
So far I've gotten this code written. Again, forgive me if this is bad code... I tried to re-purpose the code from the other forum post I mentioned earlier.
I think I setup the import location right... I want it to import into column C, row 3 of the sheet that the search box/button combo will be present on. But now, I am unsure how I would get the import aspect to work. Thanks in advance for anyone who can help on this issue.
Sub SearchFolders()
Dim FSO As Object
Dim Folder As Object
Dim File As Object
Dim TS As Object
Dim SourceFolder As String
Dim Search As String
Dim LineNumber As Long
Dim DataSh As Worksheet
SourceFolder = "C:\Users\MarMar\Desktop\Data\Census2016\DataFiles\"
Search = TextBox1.Value
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Folder = FSO.GetFolder(SourceFolder)
Set DataSh = ActiveSheet.Cells(3, 3)
For Each File In Folder.Files
Set TS = File.OpenAsTextStream()
LineNumber = 0
Do While Not TS.AtEndOfStream
LineNumber = LineNumber + 1
If InStr(TS.ReadLine, Search) Then
'Code to Import Values to DataSh ???
End If
Loop
TS.Close
Next File
End Sub
Maybe something like this:
Dim arr
For Each File In Folder.Files
Set TS = File.OpenAsTextStream()
LineNumber = 0
Do While Not TS.AtEndOfStream
arr = Split(TS.ReadLine, ",") 'split line to array
'check first element in array
If arr(0) = Search Then
datash.Resize(1, UBound(arr) + 1).Value = arr
Set datash = datash.Offset(1, 0)
End If
Loop
TS.Close
Next File
Final result that worked for me!
Sub SearchImportData1()
Dim FSO As Object
Dim SourceFolder As String
Dim Folder As Object
Dim Import As Range
Dim Search As String
Dim TextBox1 As TextBox
Dim File As Object
Dim TS As Object
Dim LineNumber As Integer
Dim Arr As Variant
SourceFolder = "C:\Users\MarMar\Desktop\Data\Census2016\DataFiles\"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Folder = FSO.GetFolder(SourceFolder)
Set Import = ActiveSheet.Cells(2, 3)
Search = ActiveSheet.TextBox1.Text
For Each File In Folder.Files
Set TS = File.OpenAsTextStream()
LineNumber = 0
Do While Not TS.AtEndOfStream
Arr = Split(TS.ReadLine, ",")
If Arr(0) = Search Then
Import.Resize(1, 1).Value = Arr(2)
Set Import = Import.Offset(1, 0)
End If
Loop
TS.Close
Next File
End Sub
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.