PDF_Metadata.vb

Function GetProperty(fileFolder As String, fileName As String, strName As String)
    'All properties are saved in an array so that the actual name of the _
    'property can be found in lieu of using the numbered index of the property.
    'REFERENCE: https://social.msdn.microsoft.com/forums/en-US/873cfe9f-13fe-4d2f-ad52-af020eaa0f7f/find-the-title-of-a-pdf-document
    '
    'AVAILABLE PROPERTIES:
    'SIZE
    'ITEM TYPE
    'DATE MODIFIED
    'DATE CREATED
    'DATE ACCESSED
    'ATTRIBUTES
    'PERCEIVED TYPE
    'OWNER
    'KIND
    'RATING
    'COMPUTER
    'FILENAME
    'SHARED
    'FOLDER NAME
    'FOLDER PATH
    'FOLDER
    'PATH
    'TYPE
    'LINK STATUS
    'SHARING STATUS
    
    Dim objShell As Shell32.Shell
    Dim objFolder As Shell32.Folder
    Dim objItem As Shell32.FolderItem
    Dim ws As Worksheet
    Dim r As Long
    Dim j As Long
    Dim varTemp As Variant
    Dim strTemp As String
    Dim arrProperties()
    
    Set objShell = New Shell
    Set objFolder = objShell.Namespace(fileFolder)
    Set objItem = objFolder.ParseName(fileName)
    
    With objFolder
        For r = 1 To 1000
            strTemp = .GetDetailsOf(objItem.Name, r)
            If strTemp = "" Then Exit For   'At end of properties
            varTemp = .GetDetailsOf(objItem, r)
            If varTemp <> "" Then   'Ignores properties with no value
                j = j + 1
                ReDim Preserve arrProperties(1 To 2, 1 To j)
                arrProperties(1, j) = strTemp
                arrProperties(2, j) = varTemp
            End If
        Next r
    End With
    
    Set objItem = Nothing
    Set objFolder = Nothing
    Set objShell = Nothing

    For j = LBound(arrProperties, 2) To UBound(arrProperties, 2)
        
        If UCase(arrProperties(1, j)) = UCase(strName) Then     'Ignore case for search
            GetProperty = arrProperties(2, j)
            Exit For
        End If
    Next j
    If j > UBound(arrProperties, 2) Then
        GetProperty = Chr(34) & strName & Chr(34) & _
                    " has no property or is an invalid property name."
    End If
    
End Function

Sub Test()
    Data = GetProperty("D:\Temp\RhinoV6_PDFPrintTest\PDF_bzip", "CAS-ARMA-P02.A.pdf", "SHARING STATUS")
    'Debug.Print Data
    ReadPDFMetaData "D:\Temp\RhinoV6_PDFPrintTest\PDF_bzip\CAS-ARMA-P02.A.pdf"
End Sub

Function ReadPDFMetaData(ByVal sFile As String)
    'Read metadata of a PDF file.
    'REFERENCE: http://vbcity.com/forums/t/170532.aspx
    '
    'Requires Acrobat Pro
    'Available Properties:
    'File Name:
    'Pages:
    'Page Mode:
    'Title
    'Subject:
    'Author:
    'Keywords:
    'Creator:
    'Producer:
    Dim oApp As Object
    Dim oDoc As Object
    Dim strFileName As String, strNumPages As Long, strPageMode As String
    Dim strTitle As String, strSubject As String, strAuthor As String
    Dim strKeywords As String, strCreator As String, strProducer As String
      
    Set oApp = CreateObject("AcroExch.App")
    Set oDoc = CreateObject("AcroExch.PDDoc")
      
    With oDoc
      If .Open(sFile) Then
        strFileName = .GetFileName
        Debug.Print "File Name:", strFileName
        strNumPages = .GetNumPages
        Debug.Print "Pages: ", strNumPages
        strPageMode = .GetPageMode
        Debug.Print "Page Mode: ", strPageMode
        strTitle = .GetInfo("Title")
        Debug.Print "Title ", strTitle
        strSubject = .GetInfo("Subject")
        Debug.Print "Subject: ", strSubject
        strAuthor = .GetInfo("Author")
        Debug.Print "Author: ", strAuthor
        strKeywords = .GetInfo("Keywords")
        Debug.Print "Keywords: ", strKeywords
        strCreator = .GetInfo("Creator")
        Debug.Print "Creator: ", strCreator
        strProducer = .GetInfo("Producer")
        Debug.Print "Producer: ", strProducer
        .Close
      End If
    End With
      
    Set oDoc = Nothing
    Set oApp = Nothing
      
End Function