MSXML2 - How to search specific nodes and replace its child nodes - vba

I have this XML file
I need to search for the <deviceset> element by its name (for example name="DB_") and replace its children subtree <technologies> with updated data.
So far I made function that returns MSXML2.IXMLDOMElement <technologies> with correct structure, but I have no clue how to search and replace in the main document.
I'm trying this approach
'Select everything from table Interlink - This table contains element's names
Dim RS As Recordset
Set RS = CurrentDb.OpenRecordset("SELECT * FROM Interlink")
'Create new document and load the file
Dim oDoc As DOMDocument60
Set oDoc = New DOMDocument60
oDoc.async = False
oDoc.Load CurrentProject.Path & "\JLC_pattern.xml"
Dim Tech As IXMLDOMElement 'I can set this to contain updated <technologies> subtree
'is it better to use IXMLDOMNode? or IXMLDOMDocumentFragment?
Dim devSets As IXMLDOMNodeList 'Collection ?
Dim devSet As IXMLDOMNode 'Node?
'Loop through the recordset, search for elements and replace the subtree <technologies>
Do Until RS.EOF
'Recordset now contains the deviceset name attribute
Debug.Print RS.Fields("lbrDeviceSetName") ' first record contains "DB_"
'I can't find the right method to find the node or collection
'I have tried:
Set devSets = oDoc.getElementsByTagName("deviceset") 'and
Set devSets = oDoc.selectNodes("//eagle/drawing/library/devicesets/deviceset")
'but devSets collection is always empty
For Each devSet In devSets
Debug.Print devSet.baseName ' this does not loop
Next devSet
'I made a function that returns IXMLDOMNode with needed data structure
'Once I find the node I need to replace the subtree
'and move to the next deviceset name
RS.MoveNext
Loop
'Save the modified XML document to disk
oDoc.Save CurrentProject.Path & "\SynthetizedDoc.xml"
RS.Close
'Cleanup...
It may be easier to loop through the collection of nodes and search the recordset instead of looping through the recordset and search the nodes.
Can anyone give me a clue please?
EDIT: I have expanded the VBA code with for each loop
Pattern XML is here JLC_Pattern.xml
EDIT 2: The <technologies> subtree can be quite huge. I don't want to overwhelm this post by code. I have a function getTechnology(tech as string) as IXMLDOMElement that pulls data from DB. Function output content can be downloaded here: IXMLDOMElement.xml The issue is not this function, I just don't know how to insert this output into the correct place of the oDoc

This works for me:
'Create new document and load the file
Dim oDoc As DOMDocument60
Dim devSet As IXMLDOMNode
Set oDoc = New DOMDocument60
oDoc.async = False
'https://learn.microsoft.com/en-us/previous-versions/windows/desktop/ms762632(v=vs.85)
oDoc.SetProperty "ProhibitDTD", False 'needed for MSXML6
oDoc.validateOnParse = False 'or get a DTD-related error
'"The element 'eagle' is used but not declared in the DTD/Schema."
'always test for load errors
If Not oDoc.Load("C:\Tester\JLC_pattern.xml") Then
Debug.Print oDoc.parseError.reason
Exit Sub
End If
'select a single node based on its name attribute value
Set devSet = oDoc.SelectSingleNode("/eagle/drawing/library/devicesets/deviceset[#name='DB_']")
If Not devSet Is Nothing Then
Debug.Print devSet.XML
'work with devSet child nodes...
Else
Debug.Print "node not found"
End If

Related

How to fill multiple Bookmarks / FormFields in Word from the same field in Access using VBA

I had previously been using some VBA to pass fields from Access into a Word document, until coming up against the 255 character limit. Assistance from this site has led me to now use Bookmarks instead of Form Fields.
I was originally filling many different fields on Word and in some instances using the same data from Access in two places on the Word document. I was achieving this by calling:
.FormFields("txtReasonforReward").Result = Me![Reason for Reward]
.FormFields("txtReasonforReward2").Result = Me![Reason for Reward]
As I now have a different way of filling the "Reason for Reward" box, to circumvent the character limit (code below), I'm not sure how to fill "txtReasonforReward2". I do have several instances where I've added a second field and stuck a 2 on the end... I'm not convinced this is the best way so if anybody can advise on how to achieve this with both FormFields and Bookmarks, I'd be really grateful.
Dim objWord As Object
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Set doc = objWord.Documents.Open(***path to file***, , True)
Dim rng As Word.Range
Dim x As String
With doc
.FormFields("txtFirstName").Result = Me![First Name]
.FormFields("txtLastName").Result = Me![Last Name]
`examples cut for clarity...
.FormFields("txtHRID").Result = Me![ID]
.FormFields("txtPeriod").Result = Me![Period]
If doc.ProtectionType <> wdNoProtection Then
doc.Unprotect
End If
Set rng = doc.Bookmarks("txtReasonforReward").Range
rng.MoveStart wdCharacter, -1
x = rng.Characters.First
rng.FormFields(1).Delete
rng.Text = x & Me![Reason for Reward]
doc.Protect wdAllowOnlyFormFields, True
.Visible = True
.Activate
End With
objWord.View.ReadingLayout = True
Building on the code in the question and the background question...
Word can duplicate the content of a bookmark using REF field codes. Since form fields also use bookmark identifiers, this will work with existing form fields as well as bookmarked content. REF fields can be inserted directly, if a person is familiar with doing so OR by inserting a cross-reference to the bookmark.
Referring to the work-around for inserting more than 255 characters, in this case it will be necessary to also place a bookmark around the range being inserted and to update the REF fields so that they mirror the bookmark content throughout the document. The modified section of code is below.
'Declarations to be added at the beginning of the procedure
Dim fld As Word.Field
Dim bkmName As String
'Name of form field, bookmark to be added and text in REF field code
bkmName = "txtReasonforReward"
'Existing code
If doc.ProtectionType <> wdNoProtection Then
doc.Unprotect
End If
Set rng = doc.Bookmarks(bkmName).Range
rng.MoveStart wdCharacter, -1
x = rng.Characters.First
rng.FormFields(1).Delete
rng.Text = x & Me![Reason for Reward]
' New code
'Leave that single character out of the range for the bookmark
rng.MoveStart wdCharacter, 1
'Bookmark the inserted content
doc.Bookmarks.Add bkmName, rng
'Update fields so that REF's pick up the bookmark content
For Each fld In doc.Fields
If fld.Type = wdFieldRef Then
fld.Update
End If
Next
doc.Protect wdAllowOnlyFormFields, True
This approach will get a bit unwieldy if it needs to be applied to many fields. It might make sense to do something like write the bookmark names to a Tag property of the controls in the Access form then loop the controls to pick up bookmark name and data from the control, rather than writing each out explicitly - but this is just a thought for the future.
All that being said, the "modern" way to achieve this is to work with content controls instead of form fields/bookmarks. Content controls do not have the 255 character limit, the document can be protected as a form, multiple content controls can have the same title (name) and/or tag. Furthermore, content controls can be "mapped" to a Custom XML Part stored in the document so that changing the content of one will change the content of another. Trying to describe all that would go beyond what should be in an "answer", here, but is all publicly available by searching the Internet.
Personally, if this were my project and knowing what I know of it: If form fields are not required in the document (no user input via the fields is expected) I would use bookmarks and REF fields, only.
There are so may ways to do this kind of thing. Take a look at the approach below and see if you can get it to work.
Option Compare Database
' This concept uses Docvariables in MS Word
Sub PushToWord()
Dim wapp As Word.Application
Dim wdoc As Word.Document
Dim db As DAO.Database
Dim fld As DAO.Field
Dim rs As DAO.Recordset
Dim filenm As String
Dim NumFields As Integer
Dim i As Integer
Set db = CurrentDb
Set rs = db.OpenRecordset("tbl_CustomerData")
Set wapp = New Word.Application
wapp.Visible = True
Set rs = DBEngine(0)(0).OpenRecordset("SELECT * FROM tbl_CustomerData")
If rs.RecordCount > 0 Then
rs.MoveFirst
Do While Not rs.EOF
For i = 0 To rs.Fields.Count - 1
Set fld = rs.Fields(i)
Debug.Print fld.Name, fld.Value
If fld.Value = 20 Then
filenm = "C:\Users\Ryan\Desktop\Coding\Integrating Access and Word\From Access to Word\Letter1.doc"
Set wdoc = wapp.Documents.Open(filenm)
wapp.ActiveDocument.Variables("Name").Value = rs.Fields("Name").Value
End If
Next
rs.MoveNext
Loop
Set fld = Nothing
rs.Close
End If
Set rs = Nothing
End Sub
The code runs from Access, and you can fire it off any number of ways (button click event, form load event, some other object event, etc.)

VBA HTML Scraping Error "Object Variable or With Variable not set"

I was following a tutorial of this video https://www.youtube.com/watch?v=sGw6r5GVA5g&t=2803s made by the WiseOwlTutorials channel and got stuck at a listing procedure he explains at the 36:00 position of the video.
At that point, he starts to explain how to return the video url and name of a video list from a specific category through a iteration method called Sub ListVideosOnPage(VidCatName As String, VidCatURL As String) used in another module which loops through all video categories of their website main video page https://www.wiseowl.co.uk/videos (left corner menu list).
When this procedure starts, it goes inside each video category and get the name and url of each video from that category in order to list it on a page which, in that part of the Youtube video cited above, is a debug page. However, the actual WiseOwl Video page is diferente from that when the tutorial video was made.
So, I changed his method a little in order to put the correct elements on the debbugin page, as shown below:
Sub ListVideosOnPage(VidCatName As String, VidCatURL As String)
Dim XMLReq As New MSXML2.XMLHTTP60
Dim HTMLDoc As New MSHTML.HTMLDocument
Dim VidTables As MSHTML.IHTMLElementCollection
Dim VidTable As MSHTML.IHTMLElement
Dim VidRows As MSHTML.IHTMLElementCollection
Dim VidRow As MSHTML.IHTMLElement
Dim VidLink As MSHTML.IHTMLElement
XMLReq.Open "GET", VidCatURL, False
XMLReq.send
If XMLReq.Status <> 200 Then
MsgBox "Problem" & vbNewLine & XMLReq.Status & " - " & XMLReq.statusText
Exit Sub
End If
HTMLDoc.body.innerHTML = XMLReq.responseText
'get the table element in each video category found by other module
'VidTables tag added by me to get the new element on the WiseOwl website
Set VidTables = HTMLDoc.getElementsByTagName("table")
'loop starts to search for row and link tags on the current table
For Each VidTable In VidTables
Set VidRows = VidTable.getElementsByTagName("tr")
For Each VidRow In VidRows
Set VidLink = VidRow.getElementsByTagName("a")(0) 'just pick the first link
Debug.Print VidRow.innerText, VidRow.getattribute("href") 'objetc variable not set error happpens here
Next VidRow
Next VidTable
End Sub
I found a way to circumvent this Object Variable or With Variable not set error by changing the code inside vidrow loop, adding a manual index to the code to get only the first link in each row:
For Each VidTable In VidTables
Set VidRows = VidTable.getElementsByTagName("tr")
For Each VidRow In VidRows
Index = 0
For Each VidLink In VidLinks
If Index = 0 Then
Debug.Print VidLink.innerText, VidLink.getAttribute("href")
Index = Index + 1
End If
Next VidLink
Next VidRow
Next VidTable
But, in the turorial video referenced above, the instructor doesnt get this error when he codes indexes in the way shown below:
VidLink = VidRow.getElementsByTagName("a")(0)
Debug.Print VidRow.innerText, VidRow.getattribute("href")
So my question is how do I get these object variable not set errors and in the tutorial video the instructor doesnt? Looks like the same code to me, with each element defined in the right way and a much more efficient way to code then using if's. Could anyone more used to VBA please help with an answer this? Maybe I missing something.
tl:dr:
I first give you the debug and fix info;
I go on to show you a different way using CSS selectors to target the page styling. This is generally faster, more robust and more flexible;
VidCatName doesn't appear to be used but I have left in for now. I personally would remove unless you will later develop the code to use this variable. The second sub parameters are passed by value so I have added ByVal to the signature.
① Debugging:
Your error is because you are looping all table rows and trying to access a tags and then href attributes. The first row of each table is the header row and this doesn't have a tag elements, nor associated href attributes. See image below:
Table element on page:
See that the first tr tagged element in the table contains a child th tag element, indicating it is the table header, and that there is no associated a tag element.
Kind of like you were shown elsewhere in that video, you want to change your loop to a For Next, and then, in this case, start from index 1 to skip the header row.
So, the part containing this line: For Each VidRow In VidRows , becomes the following:
Dim VidRowID As Long
For Each VidTable In VidTables
Set VidRows = VidTable.getElementsByTagName("tr")
For VidRowID = 1 To VidRows.Length - 1 'first row is actually header which doesn't have an a tag or href
Set VidLink = VidRows(VidRowID).getElementsByTagName("a")(0)
Debug.Print VidLink.innerText, VidLink.getAttribute("href")
Next VidRowID
Next VidTable
There is also only one table per page so a loop of all tables is unnecessary code in this case.
Example full call (using your code with just the change in loop type):
Option Explicit
Public Sub test()
ListVideosOnPage "Business Intelligence (70)", "https://www.wiseowl.co.uk/business-intelligence/videos/"
End Sub
Public Sub ListVideosOnPage(ByVal VidCatName As String,ByVal VidCatURL As String)
Dim XMLReq As New MSXML2.XMLHTTP60
Dim HTMLDoc As New MSHTML.HTMLDocument
Dim VidTables As MSHTML.IHTMLElementCollection
Dim VidTable As MSHTML.IHTMLElement
Dim VidRows As MSHTML.IHTMLElementCollection
Dim VidRow As MSHTML.IHTMLElement
Dim VidLink As MSHTML.IHTMLElement
XMLReq.Open "GET", VidCatURL, False
XMLReq.send
If XMLReq.Status <> 200 Then
MsgBox "Problem" & vbNewLine & XMLReq.Status & " - " & XMLReq.statusText
Exit Sub
End If
HTMLDoc.body.innerHTML = XMLReq.responseText
Set VidTables = HTMLDoc.getElementsByTagName("table") 'Should limit to just one table
Dim VidRowID As Long
For Each VidTable In VidTables
Set VidRows = VidTable.getElementsByTagName("tr")
For VidRowID = 1 To VidRows.Length - 1 'first row is actually header which doesn't have an a tag or href
Set VidLink = VidRows(VidRowID).getElementsByTagName("a")(0)
Debug.Print VidLink.innerText, VidLink.getAttribute("href")
Next VidRowID
Next VidTable
End Sub
② CSS selectors:
I would instead use a CSS selector combination to target the a tag elements within the target parent table element. This is written as .bpTable a. A more official term for this combination is descendant selector.
The descendant combinator — typically represented by a single space (
) character — combines two selectors such that elements matched by the
second selector are selected if they have an ancestor element matching
the first selector. Selectors that utilize a descendant combinator are
called descendant selectors.
The .bpTable is in fact itself a class selector (like .getElementsByClassName). The class part indicated by the leading ".". So, elements with class name bpTable; which is the class name of the target table on each page.
Target table element on page:
This selector is applied via the .querySelectorAll method of .document and returns a static nodeList. You can then loop the .Length of this nodeList, from 0 to .Length -1, accessing elements by index.
Public Sub ListVideosOnPage(ByVal VidCatName As String, ByVal VidCatURL As String)
Dim XMLReq As New MSXML2.XMLHTTP60
Dim HTMLDoc As New MSHTML.HTMLDocument
XMLReq.Open "GET", VidCatURL, False
XMLReq.send
If XMLReq.Status <> 200 Then
MsgBox "Problem" & vbNewLine & XMLReq.Status & " - " & XMLReq.statusText
Exit Sub
End If
HTMLDoc.body.innerHTML = XMLReq.responseText
Dim aNodeList As Object, link As Long
Set aNodeList = HTMLDoc.querySelectorAll(".bpTable a")
For link = 0 To aNodeList.Length - 1
Debug.Print aNodeList(link).innerText, aNodeList(link).href
Next
End Sub
References (VBE > Tools > References):
Microsoft HTML Object Library
Microsoft XML, V6.0 'For my Excel 2016 version

Unable to create a Dropdownlist that contains key and values in Excel

I'm having trouble creating a dropdownlist that contains a name and a value for each column.
What I want to achieve is to use the dropdownlist that shows a bunch of names, but I want those names to have a
value, so that I can use it (value) in macro.
For exmple, when I select a name called "Joe" it will consists of the value 25 and will
be outputted as 25.
I've Googled around for some tutorials, but most of it wasn't useful. I've pasted the the img. I want to create a drown from this
Bakers name and value. But have no clue to how I can make this possible.
Some examples or tips would be great! I would love to hear from you.
Here is the macro code:
Sub findValue()
Dim s As String
Dim value As Integer
Dim namesList As Range
Set namesList = Range("G3:G8") 'here you have to specify your range with names
s = InputBox("Enter the name: ")
'now you find the entered value (held in s variable) and get the value of a cell which
'is right to cell found (Offset function, then applied Value property)
value = namesList.Find(s).Offset(0, 1).Value
MsgBox "Found value is " & value
'save found value into the file
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim oFile As Object
Set oFile = fso.CreateTextFile(yourPath) 'don't forget to enter full path to the
'text file here!!
oFile.WriteLine value
oFile.Close
Set fso = Nothing
Set oFile = Nothing
End Sub
Now, the value is stored under value variable, you can do what you want with it :)

Alternate way of sending email from Outlook to OneNote

I've scoured the internet to find an answer, but was unable to find an answer. Here is my problem:
My organisation has a size limitation in Outlook 2013 inbox size. As such, we have had to come up with possible solutions to saving these emails in a comprehesive way which is easy to manage and easy to find way.
I've heard that we could possibly automatically send our emails directly to OneNote 2013. I've used the "send to OneNote" button in Outlook, however I was wondering if anyone has any better solution that could automatically create a section named the email sender's name if it does not exist and copy the email to a new page.
The only VBA code I have found in my searches is to either create a OneNote page or search, however my very limited knowledge in XML does not allow me to go further.
Can anyone point me in the right direction?
Here is some of the code I've found:
Option Explicit
Sub CreateNewPage()
' Connect to OneNote 2010.
' To see the results of the code,
' you'll want to ensure the OneNote 2010 user
' interface is visible.
Dim OneNote As OneNote.Application
Set OneNote = New OneNote.Application
' Get all of the Notebook nodes.
Dim nodes As MSXML2.IXMLDOMNodeList
Set nodes = GetFirstOneNoteNotebookNodes(OneNote)
If Not nodes Is Nothing Then
' Get the first OneNote Notebook in the XML document.
Dim node As MSXML2.IXMLDOMNode
Set node = nodes(2)
Dim noteBookName As String
noteBookName = node.Attributes.getNamedItem("name").Text
' Get the ID for the Notebook so the code can retrieve
' the list of sections.
Dim notebookID As String
notebookID = node.Attributes.getNamedItem("ID").Text
' Load the XML for the Sections for the Notebook requested.
Dim sectionsXml As String
OneNote.GetHierarchy notebookID, hsSections, sectionsXml, xs2013
' Dim a As MSXML2.DOMDocument60
Dim secDoc As MSXML2.DOMDocument60
Set secDoc = New MSXML2.DOMDocument60
If secDoc.LoadXML(sectionsXml) Then
' select the Section nodes
Dim secNodes As MSXML2.IXMLDOMNodeList
Debug.Print secDoc.DocumentElement.XML
Dim soapNS
soapNS = "xmlns:one='http://schemas.microsoft.com/office/onenote/2013/onenote'"
secDoc.SetProperty "SelectionNamespaces", soapNS
Set secNodes = secDoc.DocumentElement.SelectNodes("//one:Section")
If Not secNodes Is Nothing Then
' Get the first section.
Dim secNode As MSXML2.IXMLDOMNode
Set secNode = secNodes(0)
Dim sectionName As String
sectionName = secNode.Attributes.getNamedItem("name").Text
Dim sectionID As String
sectionID = secNode.Attributes.getNamedItem("ID").Text
' Create a new blank Page in the first Section
' using the default format.
Dim newPageID As String
OneNote.CreateNewPage sectionID, newPageID, npsDefault
' Get the contents of the page.
Dim outXML As String
OneNote.GetPageContent newPageID, outXML, piAll, xs2013
Dim doc As MSXML2.DOMDocument60
Set doc = New MSXML2.DOMDocument60
' Load Page's XML into a MSXML2.DOMDocument object.
If doc.LoadXML(outXML) Then
' Get Page Node.
Dim pageNode As MSXML2.IXMLDOMNode
soapNS = "xmlns:one='http://schemas.microsoft.com/office/onenote/2013/onenote'"
doc.SetProperty "SelectionNamespaces", soapNS
Set pageNode = doc.SelectSingleNode("//one:Page")
' Find the Title element.
Dim titleNode As MSXML2.IXMLDOMNode
Set titleNode = doc.SelectSingleNode("//one:Page/one:Title/one:OE/one:T")
' Get the CDataSection where OneNote store's the Title's text.
Dim cdataChild As MSXML2.IXMLDOMNode
Set cdataChild = titleNode.SelectSingleNode("text()")
' Change the title in the local XML copy.
cdataChild.Text = "A Page Created from VBA"
' Write the update to OneNote.
OneNote.UpdatePageContent doc.XML
Dim newElement As MSXML2.IXMLDOMElement
Dim newNode As MSXML2.IXMLDOMNode
' Create Outline node.
Set newElement = doc.createElement("one:Outline")
Set newNode = pageNode.appendChild(newElement)
' Create OEChildren.
Set newElement = doc.createElement("one:OEChildren")
Set newNode = newNode.appendChild(newElement)
' Create OE.
Set newElement = doc.createElement("one:OE")
Set newNode = newNode.appendChild(newElement)
' Create TE.
Set newElement = doc.createElement("one:T")
Set newNode = newNode.appendChild(newElement)
' Add the text for the Page's content.
Dim cd As MSXML2.IXMLDOMCDATASection
Set cd = doc.createCDATASection("Is this what I need to change?")
newNode.appendChild cd
' Update OneNote with the new content.
OneNote.UpdatePageContent doc.XML
' Print out information about the update.
Debug.Print "A new page was created in "
Debug.Print "Section " & sectionName & " in"
Debug.Print "Notebook " & noteBookName & "."
Debug.Print "Contents of new Page:"
Debug.Print doc.XML
End If
Else
MsgBox "OneNote 2010 Section nodes not found."
End If
Else
MsgBox "OneNote 2010 Section XML Data failed to load."
End If
Else
MsgBox "OneNote 2010 XML Data failed to load."
End If
End Sub
Private Function GetAttributeValueFromNode(node As MSXML2.IXMLDOMNode, attributeName As String) As String
If node.Attributes.getNamedItem(attributeName) Is Nothing Then
GetAttributeValueFromNode = "Not found."
Else
GetAttributeValueFromNode = node.Attributes.getNamedItem(attributeName).Text
End If
End Function
Private Function GetFirstOneNoteNotebookNodes(OneNote As OneNote.Application) As MSXML2.IXMLDOMNodeList
' Get the XML that represents the OneNote notebooks available.
Dim notebookXml As String
' OneNote fills notebookXml with an XML document providing information
' about what OneNote notebooks are available.
' You want all the data and thus are providing an empty string
' for the bstrStartNodeID parameter.
OneNote.GetHierarchy "", hsNotebooks, notebookXml, xs2013
' Use the MSXML Library to parse the XML.
Dim doc As MSXML2.DOMDocument60
Set doc = New MSXML2.DOMDocument60
If doc.LoadXML(notebookXml) Then
Dim soapNS
soapNS = "xmlns:one='http://schemas.microsoft.com/office/onenote/2013/onenote'"
doc.SetProperty "SelectionNamespaces", soapNS
Set GetFirstOneNoteNotebookNodes = doc.DocumentElement.SelectNodes("//one:Notebook")
Debug.Print doc.DocumentElement.XML
Else
Set GetFirstOneNoteNotebookNodes = Nothing
End If
End Function
Thanks for your help.
Are you using OneDrive for Business? If so, these Microsoft Flow templates might be very useful: https://ms.flow.microsoft.com/en-us/services/shared_onenote/onenote-business/. In particular, one is for sending important e-mails to OneNote. You can also create your own flow that has different triggers, and specify the name of the page/section you want to create.
Here is an example flow:
Note the "Add Dynamic Content" button. This allows you to specify the name and content of the section.
If you're not using O365, you might be able to use the Microsoft Graph API and the OneNote REST API together to achieve what you want. There aren't VBA examples but there are many others.

Using VBA to get extended file attributes

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"