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.
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"
Goal for my project:
I want to be able to copy the contents of one document and append that selection to the end of another document.
What it does... (this is just background info so you understand why I am trying to do this):
I am trying to dynamically produce a document which quotes a variety of information regarding different parts and materials involved for a product.
The document itself has a consistent format which I have broken down and separated into two documents. The first contains a bunch of data that needs to be entered manually, and is where I want to append all additional content. The second contains roughly a dozen custom fields which are updated from an excel spreadsheet in VBA. For a single part and as a single doc this works as I want it (my base case). However my issue is when there are multiple parts for a project.
The Problem:
For multiple parts I have to store information in an array which changes in size dynamically as each additional part is added. When someone has added all the necessary parts they can select a button called "Create Quote".
Create quote runs a procedure which creates/opens separate copies of the two template documents mentioned above (saved on my computer). It then iterates through the array of parts and updates all the custom field in the 2nd document (no problems). Now I just need the contents of the 2nd document appended to the end of the first which is my problem.
What I want:
Ideally, my procedure will continue to iterate through every part in the array - updating custom fields, copy then paste the updated text, repeat... Until every part is included in the newly generated quote.
What I Tried - this code can be found in my generate quote procedure
I have tried many of the examples and suggestions provided by people who had similar question, but I don't know if its because I am operating from an excel doc, but many of their solution have not worked for me.
This is my most recent attempt and occurs after each iteration of the for loop
wrdDoc2.Fields.Update 'Update all the fields in the format document
wrdDoc2.Activate
Selection.WholeStory ' I want to select the entire document
Selection.Copy ' Copy the doc
wrdDoc1.Activate ' Set focus to the target document
Selection.EndKey wdStory ' I want the selection to be pasted to the end of the document
Selection.PasteAndFormat wdPasteDefault
QUOTE PROCEDURE - I am only including a handful of the fields I am updating because its not necessary to show them all
Private Sub quote_button_Click()
On Error GoTo RunError
Dim wrdApp1, wrdApp2 As Word.Application
Dim wrdDoc1, wrdDoc2 As Word.Document
Set wrdApp1 = CreateObject("Word.Application")
Set wrdApp2 = CreateObject("Word.Application")
wrdApp1.Visible = True
wrdApp2.Visible = True
Set wrdDoc1 = wrdApp1.Documents.Add(Template:="C:\MWES\AQT_v1.1(start).docm", NewTemplate:=False, DocumentType:=0)
Set wrdDoc2 = wrdApp2.Documents.Add(Template:="C:\MWES\AQT_v2.1(format).docm", NewTemplate:=False, DocumentType:=0)
Dim propName As String
For i = LBound(part_array, 1) To UBound(part_array, 1)
For Each prop In wrdDoc2.CustomDocumentProperties
propName = prop.name
' Looks for and sets the property name to custom values of select properties
With wrdDoc2.CustomDocumentProperties(propName)
Select Case propName
Case "EST_Quantity"
.value = part_array(i, 0) ' "QTY" ' Sheet1.Cells(1, 3) 'NA
Case "EST_Metal_Number"
.value = part_array(i, 1) ' "METAL_#" ' Sheet1.Cells(2, 3) 'NA"
Case "EST_Metal_Name"
.value = part_array(i, 2) ' "METAL_N" ' Sheet1.Cells(5, 2)
End Select
End With
Next prop ' Iterates until all the custom properties are set
wrdDoc2.Fields.Update 'Update all the fields in the format document
wrdDoc2.Activate
Selection.WholeStory ' I want to select the entire document
Selection.Copy ' Copy the doc
wrdDoc1.Activate ' Set focus to the target document
Selection.EndKey wdStory ' I want the selection to be pasted to the end of the document
Selection.PasteAndFormat wdPasteDefault
Next i ' update the document for the next part
RunError: ' Reportd any errors that might occur in the system
If Err.Number = 0 Then
Debug.Print "IGNORE ERROR 0!"
Else
Dim strError As String
strError = "ERROR: " & Err.Number & vbCrLf & Err.Description & vbCrLf & Erl
MsgBox strError
Debug.Print strError & " LINE: " & Erl
End If
End Sub
I apologize this was so long winded. Let me know if there is anything confusing or you may want clarified. I think I included everything though.
I think you're close, so here are a couple of comments and an example.
First of all, you're opening two separate MS Word Application objects. You only need one. In fact, it's possible that the copy/paste is failing because you're trying to copy from one Word app to a document opened in the other. (Trust me, I've seen weird things like this.) My example below shows how to do this by only opening a single application instance.
Dim mswApp As Word.Application
Set mswApp = AttachToMSWordApplication() 'more on this function below...
Dim doc1 As Word.Document
Dim doc2 As Word.Document
Set doc1 = mswApp.Documents.Open("C:\Temp\combined.docx")
Set doc2 = mswApp.Documents.Open("C:\Temp\control.docx")
While I don't often write code for Word, I've found that there are so many different ways to get at the same content using different objects or properties. This is always a source of confusion.
Based on this answer, which has worked well for me in the past, I then set up the source and destination ranges to perform the "copy":
Dim destination As Word.Range
Dim source As Word.Range
Set source = doc1.Content
Set destination = doc2.Content
destination.Collapse Direction:=Word.wdCollapseEnd
destination.FormattedText = source
Here is the whole module for reference:
Option Explicit
Sub AddDocs()
Dim wordWasRunning As Boolean
wordWasRunning = IsMSWordRunning()
Dim mswApp As Word.Application
Set mswApp = AttachToMSWordApplication()
Dim doc1 As Word.Document
Dim doc2 As Word.Document
Set doc1 = mswApp.Documents.Open("C:\Temp\combined.docx")
Set doc2 = mswApp.Documents.Open("C:\Temp\control.docx")
Dim destination As Word.Range
Dim source As Word.Range
Set source = doc1.Content
Set destination = doc2.Content
destination.Collapse Direction:=Word.wdCollapseEnd
destination.FormattedText = source
doc2.Close SaveChanges:=True
doc1.Close
If Not wordWasRunning Then
mswApp.Quit
End If
End Sub
Here's the promised note on a couple functions I use in the sample. I've built up a set of library functions, several of which help me access other Office applications. I save these modules as .bas files (by using the Export function in the VBA Editor) and import them as needed. So if you'd like to use it, just save the code below in using a plain text editor (NOT in the VBA Editor!), then import that file into your project.
Suggested filename is Lib_MSWordSupport.bas:
Attribute VB_Name = "Lib_MSWordSupport"
Attribute VB_Description = "Variety of support functions operating on MS Word"
Option Explicit
Public Function IsMSWordRunning() As Boolean
Attribute IsMSWordRunning.VB_Description = "quick check to see if an instance of MS Word is running"
'--- quick check to see if an instance of MS Word is running
Dim msApp As Object
On Error Resume Next
Set msApp = GetObject(, "Word.Application")
If Err > 0 Then
'--- not running
IsMSWordRunning = False
Else
'--- running
IsMSWordRunning = True
End If
End Function
Public Function AttachToMSWordApplication() As Word.Application
Attribute AttachToMSWordApplication.VB_Description = "finds an existing and running instance of MS Word, or starts the application if one is not already running"
'--- finds an existing and running instance of MS Word, or starts
' the application if one is not already running
Dim msApp As Word.Application
On Error Resume Next
Set msApp = GetObject(, "Word.Application")
If Err > 0 Then
'--- we have to start one
' an exception will be raised if the application is not installed
Set msApp = CreateObject("Word.Application")
End If
Set AttachToMSWordApplication = msApp
End Function
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
I have a user-form that pastes folder-paths into a list. I then have the code below that is supposed to loop through that list and list all the sub-folders (then I'll probably have another code loop through the sub-folders to get the excel workbooks).
I know it's inelegant, because ultimately what I want is have my list of paths be looked in one a time, through each folder and subfolder to find and list the excel files. But there was a question like that and it was taken down. The question was then referred to a different q&a that I did not understand, that had to do with individual FILE NAMES, typed in a single cell not a range, nor as a path. I speak Russian, which some of his code was in, and still couldn't quite understand what his code meant and was referring to, and when I tried it, it kept telling met that "GetData" was undefined? so I've tried to ask a different but similar question in the hope that someone can explain to me what I need to do, as I've gone as far as I can and have tried to adapt both codes from the links in this post as well as many others. I have several modules with broken code that doesn't work, and the closest I've come is the code below. At this point I'd settle simply for a way to list the excel file names from a list of paths.
Option Explicit
Dim i As Long, j As Long
Dim searchfolders As Variant
Dim FileSystemObject
Sub ListOfFolders77()
Dim LookInTheFolder As String
'Dim ws As Worksheet: Set ws = Sheets("Output4")
Dim ws2 As Worksheet: Set ws2 = Sheets("Output3")
Dim rng As Range: Set rng = ws2.Range("A1:A" & Rows.Count).End(xlUp)
Dim mypath As Range
'Dim Region As Range: Set Region = ws.Range("A2")
'Dim district As Range: Set district = ws.Range("B2")
'Dim city As Range: Set city = ws.Range("C2")
'Dim atlas As Range: Set atlas = ws.Range("D2")
i = 1
For Each mypath In rng
LookInTheFolder = mypath.Value
Set FileSystemObject = CreateObject("Scripting.FileSystemObject")
For Each searchfolders In FileSystemObject.GetFolder(LookInTheFolder).subfolders
Sheets("Subfolders").Cells(i, 1) = searchfolders
i = i + 1
SearchWithin searchfolders
Next searchfolders
Next mypath
End Sub
Sub SearchWithin(searchfolders)
On Error GoTo exits
For Each searchfolders In FileSystemObject.GetFolder(searchfolders).subfolders
j = UBound(Split(searchfolders, "\"))
Cells(i, j) = searchfolders
i = i + 1
SearchWithin searchfolders
Next searchfolders
exits:
End Sub
Ideally I want to get all the excel files in the folders and subfolders, and copy paste the data on the first sheet into one long list, but I'm still on step 1. I posted a more detailed explanation here last week and have yet to receive any feedback or potential tips.
I apologize if this doesn't make sense or seems half-hazard. I am self taught in excel VBA and am struggling to understand if what I need is even possible. I attempted using Directory but I've little success putting directory in a for each loop.
I also tried using an array, which almost crashed by computer as it went to list ALL the folders and files in my entire computer.
If I understand correctly, your requirements are as follows:
Begin with a set of root paths
Iterate recursively through all the files in each root path
For each file in the resulting collection, if it's an Excel file, add to final list for further processing
Let's start with the first two points. I would suggest the following code (make sure to add a reference to Microsoft Scripting Runtime via Tools -> References... in the VBA editor menus):
Public Function GetFiles(ByVal roots As Variant) As Collection
Select Case TypeName(roots)
Case "String", "Folder"
roots = Array(roots)
End Select
Dim results As New Collection
Dim fso As New Scripting.FileSystemObject
Dim root As Variant
For Each root In roots
AddFilesFromFolder fso.GetFolder(root), results
Next
Set GetFiles = results
End Function
Private Sub AddFilesFromFolder(folder As Scripting.folder, results As Collection)
Dim file As Scripting.file
For Each file In folder.Files
results.Add file
Next
Dim subfolder As Scripting.folder
For Each subfolder In folder.SubFolders
AddFilesFromFolder subfolder, results
Next
End Sub
The GetFiles function can be called by passing in a single string (or Folder):
Debug.Print GetFiles("c:\users\win8\documents").Count
or anything that can be iterated over with For Each -- an array, collection, Dictionary, or even an Excel Range object:
Dim allFiles As Collection
Set allFiles = GetFiles(ws2.Range("A1:A" & Rows.Count).End(xlUp)) 'from question
GetFiles as it stands is flexible for many use cases, and doesn't use any Excel-specific objects. In order to limit the results to Excel files only, you can create a new collection, and only add the Excel files into the new collection:
'You could filter by the File object's Type property
Sub GetExcelFilesByType()
Dim allFiles As Collection
Set allFiles = GetFiles(ws2.Range("A1:A" & Rows.Count).End(xlUp)) 'from question
Dim excelFiles As New Collection
Dim file As Scripting.File
For Each file In allFiles
If file.Type = "Microsoft Excel Worksheet" Then excelFiles.Add file
Next
End Sub
' Or you could filter by extension, using the FileSystemObject.GetExtensionName method
Sub GetExcelFilesByExtensionName()
Dim allFiles As Collection
Set allFiles = GetFiles(ws2.Range("A1:A" & Rows.Count).End(xlUp)) 'from question
Dim excelFiles As New Collection
Dim fso As New Scripting.FileSystemObject
Dim file As Scripting.File
For Each file In allFiles
Select Case fso.GetExtensionName(file.path)
Case "xls", "xlsb", "xlsm"
excelFiles.Add file
End Select
Next
End Sub
Either will get you a Collection of File objects, of only Excel files, from the set of root folders.
Notes
This code is recursively adding all the files (not just Excel files) into one collection (in GetFiles) and then filtering out the non-Excel files into a new collection. This might be less performant than adding only Excel files into the original collection, but that would limit GetFiles to only this scenario.
If you want to paste the results into an Excel worksheet, you could iterate through excelFiles and paste each path into the sheet. Alternatively, you might convert excelFiles into an array, and use the Excel Range object's Value property to set all the values from the array, without using a For Each.
References
Microsoft Scripting Runtime
FileSystemObject object, GetExtensionName method
File object
Folder object
VBA
Collection object
Here's a quick way, slightly adapted from this answer.
Just add in your folder locations to the path() = ... list and it should work for you. It outputs, in the current excel sheet, the paths of all Excel files in folders you provide.
From there, you can do what you please. (Perhaps throw the file paths in to an array, so you have an array of files you want to open. From there you can do the copying of data).
'Force the explicit delcaration of variables
Option Explicit
Sub ListFiles()
'http://www.xl-central.com/list-the-files-in-a-folder-and-subfolders.html
'Set a reference to Microsoft Scripting Runtime by using
'Tools > References in the Visual Basic Editor (Alt+F11)
'Declare the variables
Dim objFSO As Scripting.FileSystemObject
Dim objTopFolder As Scripting.Folder
Dim strTopFolderName As String
Dim path() As Variant ' EDIT THE BELOW PATH LIST FOR WHATEVER YOU NEED!
path() = Array("C:\Users\USERNAME\Desktop\Stuff\New folder", "C:\Users\USERNAME\Desktop\Other Stuff\")
'Insert the headers for Columns
Range("A1").Value = "File Name"
Range("D1").Value = "File Path"
Dim i As Long
For i = LBound(path) To UBound(path)
strTopFolderName = path(i)
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the top folder
Set objTopFolder = objFSO.GetFolder(strTopFolderName)
'Call the RecursiveFolder routine
Call RecursiveFolder(objTopFolder, True)
'Change the width of the columns to achieve the best fit
Columns.AutoFit
Next i
End Sub
Sub RecursiveFolder(objFolder As Scripting.Folder, _
IncludeSubFolders As Boolean)
'Declare the variables
Dim objFile As Scripting.File
Dim objSubFolder As Scripting.Folder
Dim NextRow As Long
'Find the next available row
NextRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
'Loop through each file in the folder
For Each objFile In objFolder.Files
Debug.Print (objFile)
If objFile.Type = "Microsoft Excel Worksheet" Then
Cells(NextRow, "A").Value = objFile.Name
Cells(NextRow, "D").Value = objFile.path
NextRow = NextRow + 1
End If
Next objFile
'Loop through files in the subfolders
If IncludeSubFolders Then
For Each objSubFolder In objFolder.SubFolders
Call RecursiveFolder(objSubFolder, True)
Next objSubFolder
End If
End Sub
I'm trying to search an MS Word doc for embedded Excel files and save them to a different location.
1) I want to record the page number and or section name (based on header style) the embedded file was located in the Word Doc. How can I extract this info?
2) Is there anyway to get the original filename of the embedded Excel file?
Here is the code I'm using to search for embedded files. Originally
Working off the code first presented here: Extract Embeded Excel Workseet Data
Sub TestMacro2()
Application.ScreenUpdating = False
Application.DisplayAlerts = wdAlertsNone
Dim lNumShapes As Long
Dim lShapeCnt As Long
Dim xlApp As Object
Dim wrdActDoc As Document
Dim iRow As Integer
Dim iCol As Integer
Set wrdActDoc = ActiveDocument
For lShapeCnt = 1 To wrdActDoc.InlineShapes.Count
If wrdActDoc.InlineShapes(lShapeCnt).Type = wdInlineShapeEmbeddedOLEObject Then
If wrdActDoc.InlineShapes(lShapeCnt).OLEFormat.ProgID = "Excel.Sheet.8" Then
wrdActDoc.InlineShapes(lShapeCnt).OLEFormat.Edit
Set xlApp = GetObject(, "Excel.Application")
cpath = "location of interest"
xlApp.Workbooks(1).SaveAs cpath & " " & lShapeCnt
xlApp.Workbooks(1).Close
xlApp.Quit
Set xlApp = Nothing
End If
End If
Next lShapeCnt
End Sub
Note: Your code would be more efficient (and easier to read) if you assign an object that's re-used to a variable:
Dim ils as Word.InlineShape
Set ils = wrdActDoc.InlineShapes(lShapeCnt)
(1) The Range.Information method can return the page number. Something like:
Dim pageNumber as Long
pageNumber = ils.Range.Information(wdwdActiveEndPageNumber)
The other option is not as straight forward... I expect you really mean Heading style, not Header style. There is a built-in bookmark that will get the Heading preceding the current selection. That would be something like:
Dim secName as String
ils.Range.Select
secName = ActiveDocument.Bookmarks("\HeadingLevel").Range.Text
(2) If the file is not linked then your chances are slim. There's nothing VBA can get at directly, that's certain. Possibly, something might be stored in the WordOpenXML. You can check that by downloading the Open XML SDK Productivity Tool, opening such a document in it and inspecting that part of the Open XML. If it's in there then you can get at it in VBA using ils.Range.WordOpenXML to get the Open XML for the InlineShape, then parse that.