Reading properties of a Word document

[Val68]

Hi, I have a file that contains two columns: A - file path and B - Title. To select a file, I double click in column A (let's say, A14), which opens an Explorer window. I make my selection and the path of the selected file is inserted in the double clicked cell. Now, to get the title of said file, I double click in column B (B14). If the file is a workbook, the title property is written in B14. However, if the file is a Word document, I get an error (424). I have tried to find a solution but I can't find one.
There are 4 codes:
- Dialog (opens the windows allowing me to select the file) - works smoothly
- Worksheet_BeforeDoubleClick - works for column A. As for column B, it works only if the file is a workbook
- GetTitleExcel (Function) - works as intended
- GetTitle word (Function)
Here are the codes:

Function GetTitleExcel()
GetTitleExcel = ThisWorkbook.BuiltinDocumentProperties(1)
End Function

Function GetTitleWord()
GetTitleWord = ActiveDocument.BuiltinDocumentProperties("Title")
End Function

Sub Dialog()
Dim lct As Long
Dim ac As Range
Set ac = ActiveCell
With Application.FileDialog(msoFileDialogOpen)
        .AllowMultiSelect = True
        .Show
    For lct = 1 To .SelectedItems.Count
        ac.Worksheet.Hyperlinks.Add _
        Anchor:=ac, Address:=.SelectedItems(lct), _
        TextToDisplay:=.SelectedItems(lct)
    Next lct
End With
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("A14:A20")) Is Nothing Then
    Call Dialog
End If

If Not Intersect(Target, Range("B14:B20")) Is Nothing Then
    Dim ext As String
    Dim title As String

    ext = ActiveCell.Offset(0, 1)
  
    Application.ScreenUpdating = False
    ActiveCell.Offset(0, -1).Select
    Selection.Hyperlinks(1).Follow NewWindow:=False
    
    If ext = "xls*" Then
        title = GetTitleExcel()
    Else
        title = GetTitleWord()
    End If
    ActiveWindow.Close
    ActiveCell.Offset(0, 1) = title
    Application.ScreenUpdating = True
End If
End Sub

I presume the problem is either with the GetTitleWord function or with the way the macro open/reads the Word file. Any suggestions? Thanks!

 

[Dan_W]

Hi. So when you get an error message, it usually offers you the option of either Ending the execution of the code or debugging it. If you debug it, VBA which actually tell you where the problematic code is (or at least on what line it can be found). I have a sneaking suspicion that it's on this one:

GetTitleWord = ActiveDocument.BuiltinDocumentProperties("Title")

The term ActiveDocument means nothing to Excel VBA - that's a Word concept. When you get the 424 error message, that's VBA saying to you it has no idea what ActiveDocument is.

Which leads me to the File Picker - The method you've adopted for trying to the document properties (BuiltInDocumentProperties) requires the file to be open, but the File Pickerdoesn't actually open any of the files. All it will do is return to you the a list of the file paths of the selected files. This explains why the data in column A is working, but the column B part is not.

Also, I'm reasonably certain that GetExcelTitle isn't working either - for the same reason as above, and also because:- although you are referencing an object that does in fact exist and one that Excel recognises, it is ThisWorkbook. Meaning it is the workbook containing the code you're executing. And only that workbook.

I took a go at rewriting your code. It has a single GetTitle function now that should work for either Word or Excel document. It does, however, require that you pass it the full path/filename of the document, and I couldn't quite work out from your code where that was. I'm guessing it's in Activecell, but it's not fully clear - anyway, I have made a new variablec called FullFilePath - you should make sure that has the proper information in it. The benefit to the method I have taken here is that it does not require you to open the documents - they can stay closed.

Let me know how it goes.

Sub Dialog()
Dim lct As Long
Dim ac As Range
Set ac = ActiveCell
With Application.FileDialog(msoFileDialogOpen)
        .AllowMultiSelect = True
        .Show
    For lct = 1 To .SelectedItems.Count
        ac.Worksheet.Hyperlinks.Add _
        Anchor:=ac, Address:=.SelectedItems(lct), _
        TextToDisplay:=.SelectedItems(lct)
    Next lct
End With
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("A14:A20")) Is Nothing Then
    Call Dialog
End If

If Not Intersect(Target, Range("B14:B20")) Is Nothing Then
    Dim ext As String
    Dim title As String
    Dim FullFilePath As String

    ext = ActiveCell.Offset(0, 1)
  
    Application.ScreenUpdating = False
    ActiveCell.Offset(0, -1).Select
    Selection.Hyperlinks(1).Follow NewWindow:=False
    
   FullFilePath = Activecell.Value
   title = GetTitle(FullFilePath)

    ActiveWindow.Close
    ActiveCell.Offset(0, 1) = title
    Application.ScreenUpdating = True
End If
End Sub

    Function GetTitle(FilePath As String)
        Dim Path As Variant, Filename As Variant, Ns As Object
        Path = GetTheFolderName(FilePath)
        Filename = GetTheFilename(FilePath)
        Set Ns = CreateObject("shell.application").Namespace(Path)
        GetTitle = Ns.getdetailsof(Ns.Items.Item(Filename), 21)
        Set Ns = Nothing
    End Function
 
    Function GetTheFilename(ByVal FilePath As String) As String
        Dim delim As String
        If InStr(FilePath, "\") Then delim = "\" Else delim = "/"
        If FilePath <> vbNullString Then GetTheFilename = StrReverse(Split(StrReverse(FilePath), delim)(0))
    End Function
    
    Function GetTheFolderName(ByVal FilePath As String) As String
        GetTheFolderName = Replace(FilePath, GetTheFilename(FilePath), "")
    End Function

 

[Val68]

Hi. So when you get an error message, it usually offers you the option of either Ending the execution of the code or debugging it. If you debug it, VBA which actually tell you where the problematic code is (or at least on what line it can be found). I have a sneaking suspicion that it's on this one:

GetTitleWord = ActiveDocument.BuiltinDocumentProperties("Title")

The term ActiveDocument means nothing to Excel VBA - that's a Word concept. When you get the 424 error message, that's VBA saying to you it has no idea what ActiveDocument is.

Which leads me to the File Picker - The method you've adopted for trying to the document properties (BuiltInDocumentProperties) requires the file to be open, but the File Pickerdoesn't actually open any of the files. All it will do is return to you the a list of the file paths of the selected files. This explains why the data in column A is working, but the column B part is not.

Also, I'm reasonably certain that GetExcelTitle isn't working either - for the same reason as above, and also because:- although you are referencing an object that does in fact exist and one that Excel recognises, it is ThisWorkbook. Meaning it is the workbook containing the code you're executing. And only that workbook.

I took a go at rewriting your code. It has a single GetTitle function now that should work for either Word or Excel document. It does, however, require that you pass it the full path/filename of the document, and I couldn't quite work out from your code where that was. I'm guessing it's in Activecell, but it's not fully clear - anyway, I have made a new variablec called FullFilePath - you should make sure that has the proper information in it. The benefit to the method I have taken here is that it does not require you to open the documents - they can stay closed.

Let me know how it goes.

Sub Dialog()
Dim lct As Long
Dim ac As Range
Set ac = ActiveCell
With Application.FileDialog(msoFileDialogOpen)
        .AllowMultiSelect = True
        .Show
    For lct = 1 To .SelectedItems.Count
        ac.Worksheet.Hyperlinks.Add _
        Anchor:=ac, Address:=.SelectedItems(lct), _
        TextToDisplay:=.SelectedItems(lct)
    Next lct
End With
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("A14:A20")) Is Nothing Then
    Call Dialog
End If

If Not Intersect(Target, Range("B14:B20")) Is Nothing Then
    Dim ext As String
    Dim title As String
    Dim FullFilePath As String

    ext = ActiveCell.Offset(0, 1)
 
    Application.ScreenUpdating = False
    ActiveCell.Offset(0, -1).Select
    Selection.Hyperlinks(1).Follow NewWindow:=False
   
   FullFilePath = Activecell.Value
   title = GetTitle(FullFilePath)

    ActiveWindow.Close
    ActiveCell.Offset(0, 1) = title
    Application.ScreenUpdating = True
End If
End Sub

    Function GetTitle(FilePath As String)
        Dim Path As Variant, Filename As Variant, Ns As Object
        Path = GetTheFolderName(FilePath)
        Filename = GetTheFilename(FilePath)
        Set Ns = CreateObject("shell.application").Namespace(Path)
        GetTitle = Ns.getdetailsof(Ns.Items.Item(Filename), 21)
        Set Ns = Nothing
    End Function
 
    Function GetTheFilename(ByVal FilePath As String) As String
        Dim delim As String
        If InStr(FilePath, "\") Then delim = "\" Else delim = "/"
        If FilePath <> vbNullString Then GetTheFilename = StrReverse(Split(StrReverse(FilePath), delim)(0))
    End Function
   
    Function GetTheFolderName(ByVal FilePath As String) As String
        GetTheFolderName = Replace(FilePath, GetTheFilename(FilePath), "")
    End Function

You are absolutely right. The problem was at the

GetTitleWord = ActiveDocument.BuiltinDocumentProperties

line, and I was well aware of that. However, I did not seem to find a viable solution to this. On the other hand, the GetTitleExcel function worked (surprisingly!) well.
I've tried your solution and works perfectly for the Word documents. However, it does not work for workbooks, but that doesn't bother me at all. What I did is, I used your GetTitle function to open Word documents and kept the GetTitleExcel for workbooks. Now everything works well. It may not be that clean but at the level I'm at I'm happy with it. Bottom line, your solution worked and I thank you for that!