How to pull file attributes of a file that is found using a wildcard in excel VBA [duplicate] - excel

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"

Related

VBA Write file tags from excel

I have some code that can make a list of files in folder and get their tags:
Option explicit
'Declare variables
Dim ws As Worksheet
Dim i As Long
Dim FolderPath As String
Dim objShell, objFolder, objFolderItem As Object
Dim FSO, oFolder, oFile As Object
Application.ScreenUpdating = False
Set objShell = CreateObject("Shell.Application")
Set ws = ActiveWorkbook.Worksheets("Sheet1") 'Set sheet name
Worksheets("Sheet1").UsedRange.ClearContents
ws.Range("A1:D1").Value = Array("FileName", "Tags", "Subgroup", "Group")
Set FSO = CreateObject("scripting.FileSystemObject")
Set oFolder = FSO.GetFolder(FolderLocation_TextBox.Value)
i = 2 'First row to print result
For Each oFile In oFolder.Files
'If any attribute is not retrievable ignore and continue
On Error Resume Next
Set objFolder = objShell.Namespace(oFolder.Path)
Set objFolderItem = objFolder.ParseName(oFile.Name)
ws.Cells(i, 1) = oFile.Name
ws.Cells(i, 2).Value = objFolder.GetDetailsOf(objFolderItem, 18) 'Tags
ws.Cells(i, 5).Value = objFolder.GetDetailsOf(objFolderItem, 277) 'Description
i = i + 1
On Error Resume Next
Next
And now I'm wondering how to write them to those files I get in the list. I am basically trying to write tags from excel.
I have a full filename in column A and a string I'm trying to write as a tag to each file is in column B.
The address of the folder is in the value of a textbox: UserForm_Tag.FolderLocation_TextBox.value.
There's a set of Workbook.BuiltindocumentProperties you can change via
VBA. You can also add custom property to CustomDocumentProperties. Is
that what you want? Note: built-in properties are displayed in file
properties (file explorer). – Maciej Los ... hours ago
Yes but how do I write the property from excel? – Eduards ... hours ago
Well...
I'm pretty sure it's impossible to change extended file properties via standard VBA methods. I have seen ActiveX object, which can do that, for example: in the answer to the question How can I change extended file properties using vba, user jac do recommend to use dsofile.dll.
Note: this library is limited to 32bit WinOS, see: 64 Bit Application Cannot Use DSOfile. More details about dsofile.dll you'll find here: How to set file details using VBA. The most important information is:
With VBA (DSOFile) you can only set basic file properties and only on
NTFS. Microsoft has discontinued the practice of storing file
properties in the secondary NTFS stream (introduced with Windows
Vista) as properties saved on those streams do not travel with the
file when the file is send as attachment or stored on USB disk that is
FAT32 not NTFS.
As i mentioned in the comment to the question, if you want to change basic (most common used) extended file property for Excel/Word file, i'd suggest to use BuiltinDocumentProperties. Some built-in properties correspond to extended file properties. For example:
BuiltinDocumentProperty
Extended Property (EP)
EP Index
Title
Title
10
Subject
Subject
11
Author
Author
9
Comments
Comments
14
Creation Date
Date created
4
Category
Category
12
Company
Company
30
and so on...
To enumerate all built-in properties:
Sub GetBuiltinProperties()
Dim wsh As Worksheet, bdc As DocumentProperty
Dim i As Long
Set wsh = ThisWorkbook.Worksheets(2)
On Error Resume Next
i = 2
For Each bdc In ThisWorkbook.BuiltinDocumentProperties
wsh.Range("A" & i) = bdc.Name
wsh.Range("B" & i) = bdc.Value
i = i + 1
Next
Set wsh = Nothing
End Sub
To set built-in property:
Sub SetBuiltinProperties()
With ThisWorkbook.BuiltinDocumentProperties
.Item("Keywords") = "My custom tag"
.Item("Comments") = "My custom description"
End With
End Sub
So... If you want to change built-in property for specific workbook, you have to:
open it,
chage/set built-in property,
save it,
and close it.

Convert Outlook Contact Group early binding Excel VBA to late binding

I am trying to insert a list of email addresses from Excel into a contact group in Outlook.
I found Excel VBA code online. It uses early binding. It is not an option to force the user to go into Tools-> References -> Outlook, when they open the file.
I need to transform the code from early to late binding.
Questions:
I understand that I need to change Outlook.Application to
CreateObject('Outlook.Application') and that I can access
olFolderContacts with the number 10 instead. See code below.
I can't figure out how to access the remaining items such as
CreateItem(olDistributionListItem).
Sub CreateContactGroupfromExcel()
Dim objContactsFolder As Outlook.Folder
Dim objContact As Outlook.ContactItem
Dim objContactGroup As Outlook.DistListItem
Dim objNameCell As Excel.Range
Dim objEmailCell As Excel.Range
Dim strName As String
Dim strEmail As String
Dim objTempMail As Outlook.MailItem
Dim objRecipients As Outlook.Recipients
Set objContactsFolder = Outlook.Application.Session.GetDefaultFolder(olFolderContacts)
Set objContactGroup = Outlook.Application.CreateItem(olDistributionListItem)
'You can change the contact group name
objContactGroup.DLName = "PlaceHolder_VBA"
i = 0
Do While Range("vba_email_outlook").Offset(i, 0).Value <> "":
strName = Range("vba_name_outlook").Offset(i, 0).Value
strEmail = Range("vba_email_outlook").Offset(i, 0).Value
Set objContact = objContactsFolder.Items.Find("[FullName] = '" & strName & "'")
'If there is no such a contact, create it.
If objContact Is Nothing Then
Set objContact = Outlook.Application.CreateItem(olContactItem)
With objContact
.FullName = strName
.Email1Address = strEmail
.Save
End With
End If
'Add the contacts to the new contact group
Set objTempMail = Outlook.CreateItem(olMailItem)
objTempMail.Recipients.Add (strName)
Set objRecipients = objTempMail.Recipients
objContactGroup.AddMembers objRecipients
i = i + 1
Loop
'Use "objContactGroup.Save" to straightly save it
objContactGroup.Display
objTempMail.Close olDiscard
End Sub
Declare object variables as generic Object
Dim objContactsFolder As Object
Determine number values of constants. With early binding, these values can be seen when hovering over constant or in VBA immediate window: ?olMailItem. Then reference number in place of constant or leave constants referenced as they are and declare them as constants with Const statements. Const olMailItem = 0
olFolderContacts = 10
olMailItem = 0
olDistributionListItem = 7
I am not an expert but this code allows you to add the reference when you run the VBA script, but it will mean that if it errors out the code quits running you will not be able to debug.
On Error Resume Next ''' If reference already exist this would cause an error
Application.VBE.ActiveVBProject.References.AddFromFile ("C:\Program Files (x86)\Microsoft Office\Office16\MSOUTL.OLB") ''' Might have to change file path
On Error GoTo 0

How to extract exif data from shape using vba Excel 2010?

The project I'm working on imports images from a blob in a MySQL database. Sometimes these images are rotated 90 degrees and the user needs to manually rotate them to the correct orientation.
So my question is, is anyone aware of a function that extract exif data from a shape in Excel using vba? I'm trying to avoid any third party applications to do this.
I eventually turned something up in the bowels of social.msdn.microsoft.com.
Here is the solution. Microsoft Shell Controls and Automation reference required. Credit to OssieMac on social.msdn.microsoft.com. Link to page of post
Pointing it at a shape doesn't seem to work (gives me an error), but I save my mysql blob to a temp file on the pc anyway so this works out for me anyway.
Sub ListMetadata()
Dim fileFolder As String
Dim fileName As String
Dim objShell As Shell32.Shell
Dim objFolder As Shell32.Folder
Dim objItem As Shell32.FolderItem
Dim i As Long
'Edit following line to your path. (Note NO back slash on end.)
fileFolder = ThisWorkbook.Path & "\Picture Test"
'Can insert path like following if you prefer.
'fileFolder = "C:\Users\OssieMac\Documents\Excel\Test Macros\Picture Test"
'Edit following line to your file name
fileName = "DSC00093.JPG"
Set objShell = New Shell
Set objFolder = objShell.Namespace(fileFolder)
Set objItem = objFolder.ParseName(fileName)
With objFolder
For i = 1 To 1000
Sheets("Sheet1").Cells(i, "A") = .GetDetailsOf(objItem.Name, i)
Sheets("Sheet1").Cells(i, "B") = .GetDetailsOf(objItem, i)
Next i
End With
Set objItem = Nothing
Set objFolder = Nothing
Set objShell = Nothing
End Sub

Read File From Sharepoint

I'm writing a script where I wish to write an HTML doc to a string from sharepoint.
Dim Content As String
Dim strShare As String: strShare = "\\link\to\share.html"
Dim iFile As Integer: iFile = FreeFile
Open strShare For Input As #iFile
Content = Input(LOF(iFile), iFile)
Close #iFile
However, I find I get a "path/file access error" every time I run the script for the first time upon boot. Once I visit "\link\to\share.html" in IE for the first time, the path begins to resolve in the VBA script.
My only thought is that IE is performing some sort of "DNS Cache" that VBA can't do. Currently my workaround is to catch the error and force the URL to open in IE the first time the script is run. After that, every other HTML file under that share loads fine.
As a test, I tried switching between from what I understand is http:// formatting (forward slash) and WebDAV formatting (\\ formating), and only the backslash separated paths ever work. I also tried to resolve the share to an IP and try it that way, but that never worked.
My last thought is to try mapping the share to a drive letter name and then specifically accessing the share with G:\link\to\mapped\share.html. But I don't see this as an elegant solution, and wonder if it will receive the same error any way.
Is there something blatant that I do not understand about WebDAV, Windows file handling, and VBA file inputs? There's something weird going on under the hood with resolving that shared domain, and I can't seem to debug it.
See if this helps here and an example below that I used.
2 things though: I only worked with Excel files on Sharepoint and I was already logged in there.
Dim oFSO As Object
'Dim oFolder As Object 'if needed
'Dim oFile As Object 'if needed
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder("\\sharepoint.site.com#SSL\DavWWWRoot\sites\")
'For Each oFolder In oFolder.SubFolders 'loops through folders
' For Each oFile In oFolder.Files 'loops through files
' 'do stuff
' Next oFile
'Next oFolder
I'm a bit confused about what you want to do. Do you want to check out files from SP and check files back into SP?
Sub testing()
Dim docCheckOut As String
'docCheckOut = "//office.bt.com/sites/Training/Design Admin/Training Plan/adamsmacro.xlsm"
docCheckOut = "http://your_path_here/ExcelList.xlsb"
Call UseCheckOut(docCheckOut)
End Sub
Sub UseCheckOut(docCheckOut As String)
' Determine if workbook can be checked out.
If Workbooks.CanCheckOut(docCheckOut) = True Then
Workbooks.CheckOut docCheckOut
Else
MsgBox "Unable to check out this document at this time."
End If
End Sub
Or...do you want to list files in a SP folder?
Sub ListFiles()
Dim folder As Variant
Dim f As File
Dim fs As New FileSystemObject
Dim RowCtr As Integer
Dim FPath As String
Dim wb As Workbook
RowCtr = 1
FPath = "http://excel-pc:43231/Shared Documents"
For Each f In FPath
'Set folder = fs.GetFolder("C:\Users\Excel\Desktop\Ryan_Folder")
'For Each f In folder.Files
Cells(RowCtr, 1).Value = f.Name
RowCtr = RowCtr + 1
Next f
End Sub
Sub test()
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("C:\Users\Excel\Desktop\Ryan_Folder")
'Set colSubfolders = objFolder.SubFolders
'For Each objSubfolder In colSubfolders
Cells(RowCtr, 1).Value = f.Name
RowCtr = RowCtr + 1
'Next
End Sub

Batch copy files to SharePoint site

I searched SO, SU, and SP.SE for a solution, but could not find what I needed. I'm looking for a solution which may be a script or some other non-coding method/tool.
I am trying to write a script (to be used by others) or some other form of automation to upload various reports automatically to a SharePoint site. I have managed to get the following (VBScript) code to work, but only for text-based files -- .CSV in this case, though this also works for .TXT, etc.
Option Explicit
Dim sCurPath
sCurPath = CreateObject("Scripting.FileSystemObject").GetAbsolutePathName(".")
UploadAllToSP sCurPath
Sub UploadAllToSP(sFolder)
Dim fso, folder, fil
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(sFolder)
For Each fil In folder.Files
If fso.GetExtensionName(fil) = "csv" Then
UploadFileToSP fil
End If
Next
End Sub
Sub UploadFileToSP(ofile)
Dim xmlhttp
Dim sharepointUrl
Dim sharepointFileName
Dim tsIn
Dim sBody
Set tsIn = ofile.openAsTextstream
sBody = tsIn.readAll
tsIn.close
sharepointUrl = "http://SHAREPOINT URL HERE"
sharepointFileName = sharepointUrl & ofile.name
set xmlHttp = createobject("MSXML2.XMLHTTP.4.0")
xmlhttp.open "PUT", sharepointFileName, false
xmlhttp.send sBody
If xmlhttp.status < 200 Or xmlhttp.status > 201 Then
wscript.echo "There was a problem uploading " & ofile.name & "!"
End If
End Sub
This only works for text files because it pipes the text data into a file on the SP site. However, if I want to transfer any kind of binary file (.XLS, .PDF), this results in garbage being uploaded.
I tried to take a look at a Shell.Application ==> .Namespace(), but this doesn't seem to work with a URL, but only a physical drive. Here's some of what else I tried (trimmed to show relevant pieces):
Set oApp = CreateObject("Shell.Application")
If oApp.NameSpace(sharepointUrl) <> Null then ' Always Null!
' Copy here
' Some lines omitted
oApp.NameSpace(sharepointUrl).CopyHere ofile.Name ' This also fails when not surrounded by the Null check
Else
MsgBox "SharePoint directory not found!"
End If
I also tried a batch file using xcopy, but that can't connect to the http:// either. I looked at this method, which may work for me, but I'd prefer not to deal with mapping/NET USE, since our company has multiple network shares, the mapping for which varies depending on who's logged in.
Since none of these work quite the way I need: Is there a method to automate this kind of functionality?
I have experience with VBA/VBscript, so either a script like the above, or something built in to an MS Office application (Outlook is best, but I can probably adapt whatever I am given) would be preferable. That being said, I am open to any method that would allow me to do this, running natively in Windows or Office. However, I do not have access to Visual Studio, so I can't use any .NET functionality.
Thanks to Sean Cheshire for pointing me at the obvious answer that I did not see. Posting the relevant code, since I don't believe this yet exists on SO.
Sub UploadFilesToSP(sFolder)
Dim sharepointUrl
Dim sharepointFileName
Dim LlFileLength
Dim Lvarbin()
Dim LobjXML
Dim LvarBinData
Dim PstrFullfileName
Dim PstrTargetURL
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
Dim fldr
Dim f
'This has not been successfully tested using an "https" connection.
sharepointUrl = "http://SHAREPOINT URL HERE"
Set LobjXML = CreateObject("Microsoft.XMLHTTP")
Set fldr = fso.GetFolder(sFolder)
For Each f In fldr.Files
sharepointFileName = sharepointUrl & f.Name
PstrFullfileName = sFolder & f.Name
LlFileLength = FileLen(PstrFullfileName) - 1
' Read the file into a byte array.
ReDim Lvarbin(LlFileLength)
Open PstrFullfileName For Binary As #1
Get #1, , Lvarbin
Close #1
' Convert to variant to PUT.
LvarBinData = Lvarbin
PstrTargetURL = sharepointFileName
' Put the data to the server, false means synchronous.
LobjXML.Open "PUT", PstrTargetURL, False
' Send the file in.
LobjXML.Send LvarBinData
Next f
Set LobjXML = Nothing
Set fso = Nothing
End Sub
This is VBA code, formatted to mostly work with VBScript, though I could not get this block to transfer properly. As VBA, this can be improved some by assigning data types, etc.
' Read the file into a byte array.
ReDim Lvarbin(LlFileLength)
Open PstrFullfileName For Binary As #1
Get #1, , Lvarbin
Close #1
This is a very old post but a very useful one so thanks to everyone's contribution. This is my version with the early binding. I found that the previous posting didn't work due to VBA assumption of the none declared variable types.
Private Sub cmdUploadToApplicationsAndApprovals_Click()
Dim strSharePointUrl As String
Dim strSharePointFileName As String
Dim lngFileLength As Long
Dim bytBinary() As Byte
Dim objXML As XMLHTTP
Dim varBinData As Variant
Dim strFullfileName As String
Dim strTargetURL As String
Dim fso As FileSystemObject
Set fso = New FileSystemObject
Dim folder As folder
Dim file As file
Dim strFolder As String
strFolder = CurrentProject.Path & "\Upload\"
'This has not been successfully tested using an "https" connection.
strSharePointUrl = "http://sps.mysite.ca/subsite/DocLib/"
Set objXML = New XMLHTTP 'CreateObject("Microsoft.XMLHTTP")
Set folder = fso.GetFolder(strFolder)
For Each file In folder.Files
strSharePointFileName = strSharePointUrl & file.Name
strFullfileName = strFolder & file.Name
lngFileLength = FileLen(strFullfileName) - 1
'Read the file into a byte array.
ReDim bytBinary(lngFileLength)
Open strFullfileName For Binary As #1
Get #1, , bytBinary
Close #1
'Convert to variant to PUT.
varBinData = bytBinary
strTargetURL = strSharePointFileName
'Put the data to the server, false means synchronous.
objXML.Open "PUT", strTargetURL, False
'Send the file in.
objXML.Send varBinData
'Now Update the metadata
Next file
'Clean up
Set objXML = Nothing
Set fso = Nothing
MsgBox "Done"
End Sub
FYI the above code required 2 references.
1. Microsoft XML, v6.0
2. Microsoft Scripting Runtime
Hope this helps improve on the already brilliant answer!!

Resources