How can I modify this code to give details of each file in the object folder?
Currently when I run it I just get the details of the folder and not the files in the folder. The specific details I need are the owner, author, date modified, and name. I don't know if this can be done within the function, but I would like to hyperlink to the name to the actual file so I would also need the name's path.
Option Explicit
Type FileAttributes
Name As String
Size As String
FileType As String
DateModified As Date
DateCreated As Date
DateAccessed As Date
Attributes As String
Status As String
Owner As String
Author As String
Title As String
Subject As String
Category As String
Comments As String
Keywords As String
End Type
Public Function GetFileAttributes(strFilePath As String) As FileAttributes
' Shell32 objects
Dim objShell As Shell32.Shell
Dim objFolder As Shell32.Folder
Dim objFolderItem As Shell32.FolderItem
' Other objects
Dim strPath As String
Dim strFileName As String
Dim i As Integer
' If the file does not exist then quit out
If Dir(strFilePath) = "" Then Exit Function
' Parse the file name out from the folder path
strFileName = strFilePath
i = 1
Do Until i = 0
i = InStr(1, strFileName, "\", vbBinaryCompare)
strFileName = Mid(strFileName, i + 1)
Loop
strPath = Left(strFilePath, Len(strFilePath) - Len(strFileName) - 1)
' Set up the shell32 Shell object
Set objShell = New Shell
' Set the shell32 folder object
Set objFolder = objShell.Namespace(strPath)
' If we can find the folder then ...
If (Not objFolder Is Nothing) Then
' Set the shell32 file object
Set objFolderItem = objFolder.ParseName(strFileName)
' If we can find the file then get the file attributes
If (Not objFolderItem Is Nothing) Then
GetFileAttributes.Name = objFolder.GetDetailsOf(objFolderItem, 0)
GetFileAttributes.Size = objFolder.GetDetailsOf(objFolderItem, 1)
GetFileAttributes.FileType = objFolder.GetDetailsOf(objFolderItem, 2)
GetFileAttributes.DateModified = CDate(objFolder.GetDetailsOf(objFolderItem, 3))
GetFileAttributes.DateCreated = CDate(objFolder.GetDetailsOf(objFolderItem, 4))
GetFileAttributes.DateAccessed = CDate(objFolder.GetDetailsOf(objFolderItem, 5))
GetFileAttributes.Attributes = objFolder.GetDetailsOf(objFolderItem, 6)
GetFileAttributes.Status = objFolder.GetDetailsOf(objFolderItem, 7)
GetFileAttributes.Owner = objFolder.GetDetailsOf(objFolderItem, 8)
GetFileAttributes.Author = objFolder.GetDetailsOf(objFolderItem, 9)
GetFileAttributes.Title = objFolder.GetDetailsOf(objFolderItem, 10)
GetFileAttributes.Subject = objFolder.GetDetailsOf(objFolderItem, 11)
GetFileAttributes.Category = objFolder.GetDetailsOf(objFolderItem, 12)
GetFileAttributes.Comments = objFolder.GetDetailsOf(objFolderItem, 14)
GetFileAttributes.Keywords = objFolder.GetDetailsOf(objFolderItem, 40)
End If
Set objFolderItem = Nothing
End If
Set objFolder = Nothing
Set objShell = Nothing
End Function
In fact, The Scripting Guys have exactly the code you are looking for:
Set objFile = CreateObject("DSOFile.OleDocumentProperties")
objFile.Open("C:\Scripts\New_users.xls")
Debug.Print "Author: " & objFile.SummaryProperties.Author
Even though this does not require adding a reference to DSOFile.dll, it does require that it be installed so your workbook is still not very portable. You could add a function that looks for DSOFile.dll and directs the user to the download page if it is not found.
I would still recommend late binding like this because you shouldn't run into any version dependencies this way. If you specifically add a reference to DSOFile.dll and a new version comes out, it may not have exactly the same name and then your code breaks.
Of course, I would recommend initially adding a reference when first writing the code so you can take advantage of Intellisense, but make sure to change it to late binding once your code is written.
Early binding:
Dim objFile As New DSOFile.OleDocumentProperties
objFile.Open("C:\Scripts\New_users.xls")
Then change it to Late binding:
Dim objFile As Object 'New DSOFile.OleDocumentProperties
Set objFile = CreateObject("DSOFile.OleDocumentProperties")
objFile.Open("C:\Scripts\New_users.xls")
Related
I am trying to automate Powerpoint presentation. I found a code on the internet. This code is working well, but it works with the static path in the code. I want to implement it using OpenFolder Dialogue Box. The idea is as, When I click the button import picture, the file dialogue box should be open and I select the folder. The pictures within the folder automatically and the size of the picture should automatically fit the slide. When this process complete, the slide show automatically starts to display the picture using fade animation. The code is as under.
Sub main()
Dim i As Integer
Dim arrFilesInFolder As Variant
arrFilesInFolder = GetAllFilesInDirectory("C:\Users\Admin\OneDrive\Pictures\Screenshots")
For i = LBound(arrFilesInFolder) To UBound(arrFilesInFolder)
Call AddSlideAndImage(arrFilesInFolder(i))
Next
End Sub
Private Function GetAllFilesInDirectory(ByVal strDirectory As String) As Variant
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim arrOutput() As Variant
Dim i As Integer
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder(strDirectory)
ReDim arrOutput(0)
i = 1
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
'print file path
arrOutput(i - 1) = objFile.Path
ReDim Preserve arrOutput(UBound(arrOutput) + 1)
i = i + 1
Next objFile
ReDim Preserve arrOutput(UBound(arrOutput) - 1)
GetAllFilesInDirectory = arrOutput
End Function
Private Function AddSlideAndImage(ByVal strFile As String)
Dim objPresentaion As presentation
Dim objSlide As slide
Set objPresentaion = ActivePresentation
Set objSlide = objPresentaion.Slides.Add(1, PpSlideLayout.ppLayoutChart)
Call objSlide.Shapes.AddPicture(strFile, msoCTrue, msoCTrue, 100, 100, 650, 450)
End Function
Please someone guide, where I am doing wrong. Thanks
Looks like you need to replace the hard-coded file path with code that prompts the user for one. Seems Application.FileDialog should get you there:
Dim path As String
With Application.FileDialog(Type:=msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show Then
path = .SelectedItems(1)
Else
'user cancelled, bail out:
Exit Sub
End If
End With
Dim arrFilesInFolder As Variant
arrFilesInFolder = GetAllFilesInDirectory(path)
'...rest of the code...
I have created a VBA subroutine to list any and all sub-folders that have "NNN" text in the name in a list-box on a userform - I have loads of sub-folders and finding the right one is therefore time consuming. This routine works perfectly.
However, what I now want to do is to double-click on a list-box item and it "selects" the folder in the folder hierarchy to save me the time to locate it manually (it could be several levels down).
I have a snippet that does this:
Public Sub GetItemsFolderPath()
Dim obj As Object
Dim F As Outlook.MAPIFolder
Dim Msg$
Set obj = Application.ActiveWindow
If TypeOf obj Is Outlook.Inspector Then
Set obj = obj.CurrentItem
Else
Set obj = obj.Selection(1)
End If
Set F = obj.Parent
Msg = "The path is: " & F.FolderPath & vbCrLf
Msg = Msg & "Switch to the folder?"
If MsgBox(Msg, vbYesNo) = vbYes Then
Set Application.ActiveExplorer.CurrentFolder = F
End If
End Sub
However, if I try and replace "F" with a folder path which is just a string, it fails.
So my question is, how can I select the folder using just a string for the folder path like "paul#anymail.com\Inbox\03_Group Finance\00_Organization Chart"
Thanks
I tried this little simple thing to return a folder from a path:
Function FolderFromPath(FolderPath As String) As Folder
Dim F As Folder
Dim arrFolders() As String
Dim i As Integer
Set myNamespace = Application.GetNamespace("MAPI")
Set F = myNamespace.GetDefaultFolder(olFolderInbox)
arrFolders = Split(FolderPath, "\")
For i = 4 To UBound(arrFolders)
Set F = F.Folders(arrFolders(i))
Next
Set FolderFromPath = F
End Function
It starts from your inbox (which perhaps isn't what you need), and then splits the path and goes into each folder in the path.
Update after comment
I forgot to show how to use it. You can do it like this:
Path = "\\first.last#company.com\Inbox\Folder1\Folder2"
Set Application.ActiveExplorer.CurrentFolder = FolderFromPath(Path)
The method described by Sam will do what you want. There is a small problem with the code. The index starts to far along the path. 4 should be 2 if the initial reference is to the Inbox.
Function FolderFromPath(FolderPath As String) As Folder
Dim F As Folder
Dim arrFolders() As String
Dim i As Long
arrFolders = Split(FolderPath, "\")
' Initial reference is to the mailbox - array element 0
Set F = Session.Folders(arrFolders(0))
' The next folder is array element 1
For i = LBound(arrFolders) + 1 To UBound(arrFolders)
Set F = F.Folders(arrFolders(i))
Next
Set FolderFromPath = F
End Function
Public Sub GetItemsFolderPath_Test()
Dim FPath As String
FPath = "paul#anymail.com\Inbox\03_Group Finance\00_Organization Chart"
Set ActiveExplorer.CurrentFolder = FolderFromPath(FPath)
End Sub
I'm trying to pull text from a bunch of XML files into Word. I'm working from a list of files and have found that some of them don't actually exist in the folder. So, I'm using this function to check whether the files actually exist before opening them. But I'm still getting error 52 (Bad file name or number).
This is the function:
Function FileThere(FileName As String) As Boolean
FileThere = (Dir(FileName) > "")
End Function
And this is the code I'm calling it from:
Sub PullContent()
Dim docList As Document
Dim docCombinedFile As Document
Dim objFileListTable As Table
Dim objRow As Row
Dim strContent As String
Dim strFileCode As String
'Code # for the current file. (Pulled in temporarily, output to the Word doc.)
Dim strFilename As String
'Name of XML file. Created based on strFileCode
Set docCombinedFile = Documents.Add
'The new doc which will list all warnings
Dim strXml As String
'String variable that holds the entire content of the data module
Dim strInvalidCodes
'String listing any invalid file codes. Displayed at the end.
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
Documents.Open FileName:="C:\Users\kelly.keck\Documents\Triton MTS\IETMs - Test\IETMList.docx"
Set docList = Documents("IETMList.docx")
Set objFileListTable = docList.Tables(1)
For Each objRow In objFileListTable.Rows
strFileCode = objRow.Cells(4).Range.Text
strFileCode = Left(strFileCode, Len(strFileCode) - 2)
strFilename = strFileCode & ".xml"
strPath = "C:\Applications\xml\"
If FileThere(strPath & strFileCode) = True Then
'MsgBox (strPath & strFilename)
strXml = FSO.OpenTextFile(strPath & strFilename).ReadAll
Else
strInvalidCodes = strInvalidCodes & vbCr & strFileCode
End If
Next
MsgBox ("The following filenames were invalid: " & vbCr & strInvalidCodes)
End Sub
Getting this error seems to defeat the purpose of having a function to check if a file exists, but I'm not sure what's wrong with the function.
A bit late to the party, but this hasn't had an accepted answer yet.
I generally use this method to test if a file exists, and your code uses FileSystemObject already so could use that reference.
Public Function FileExists(ByVal FileName As String) As Boolean
Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
FileExists = oFSO.FileExists(FileName)
End Function
I believe that you need to be sure that FileThere is actually returning the Boolean value you intend. It would be more reliable if you checked the Len property (the number of characters) or checked whether it actually returns the empty string.
The following is more verbose than absolutely necessary in order to make the logic clear. If you were to use Len, instead, then you'd check Len(Dir(FileName)) > 0
Function FileThere(FileName as String) as Boolean
Dim bFileExists as Boolean
If Dir(FileName) = "" Then
bFileExists = False
Else
bFileExists = True
End If
FileThere = bFileExists
End Function
Is it possible to export a single CATIA body as STL without creating a separate part with it?
For the time being, I have coded a script which loops through the CATParts present in a folder, fetches the contained bodies and create a single CATPart with each of them and export into stl format.
Dim output_stl_path_HD As String
Dim output_stl_path_MD As String
Dim output_stl_path_SD As String
Dim output_stl_path_via_points As String
Dim output_transformations_path As String
Dim input_path As String
Sub CATMain()
'Path for output file
input_path = CATIA.ActiveDocument.path + "\"
Dim it As Integer
Dim prod As Product
Dim t_p_ref(11)
'List of part names to export
Dim list As Collection
Set list = New Collection
'GET LIST OF CATPART IN FOLDER
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder(input_path)
i = 1
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
'print file name
If (InStr(objFile.path, ".CATPart")) Then
list.Add (objFile.name)
' Set objDocument = CATIA.Documents.Open(objFile.path)
Dim srcDoc As PartDocument
Set srcDoc = CATIA.Documents.Open(objFile.path)
Dim srcPart As Part
Set srcPart = srcDoc.Part
Dim oSel As Selection
Dim bodies1 As Bodies
Dim body1 As body
'
Set bodies1 = srcPart.Bodies
For Each single_body In srcPart.Bodies
A = exportStl(single_body)
Next
Set body1 = srcPart.Bodies.Item(i)
'Dim BoxProduct
'BoxProduct = MsgBox("Quantity of the bodies found:" & srcDoc.Part.Bodies.Count & "", 64)
End If
Next
End Sub
Public Function exportStl(ByVal myBody As body)
Dim oSrc As Part
Dim oTgt As Part
Dim oSrcDoc As PartDocument
Dim oTgtDoc As PartDocument
Dim oBod As body
Dim oSel As Selection
'Sets documents for Source and Target files
Set oSrcDoc = CATIA.ActiveDocument
Set oTgtDoc = CATIA.Documents.Add("Part")
oTgtDoc.Product.PartNumber = myBody.name
'Gets Body to copy
Set oSrc = oSrcDoc.Part
Set oTgt = oTgtDoc.Part
Set oBod = myBody
Set oSel = oSrcDoc.Selection
'Copies Body
oSel.Add oBod
oSel.Copy
Set oSel = oTgtDoc.Selection
'Sets and Pastes in Target file as result with link
oSel.Clear
oSel.Add oTgt.Bodies.Item(1)
oSel.Paste
oSrcDoc.Selection.Clear
CATIA.ActiveDocument.ExportData input_path + myBody.name, "stl"
CATIA.ActiveDocument.Close
End Function
Catia V5 is capable of creating STL files from parts (CatiaPART files), but not from assemblies (CatiaPRODUCT files) or geometrical representations (car files). Therefore, source files, including those saved in a neutral format (STEP or IGES, for example), must be saved as parts. If the source design was saved as an assembly, it is imported to Catia as a product. -
Source : http://www.stratasys.com/customer-support/cad-to-stl/catia
I tried exporting CATBody but was unsuccessful. We must have a CATPart to generate STL
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"