'-Begin-----------------------------------------------------------------
'-
'- Ermittlung aller Titel aller PDF-Dateien in einem Verzeichnis-
'- baum
'-
'-----------------------------------------------------------------------

Option Explicit

Const FILE_ATTRIBUTE_ARCHIVE As Long = &H20&
Const FILE_ATTRIBUTE_COMPRESSED As Long = &H800&
Const FILE_ATTRIBUTE_DIRECTORY As Long = &H10&
Const FILE_ATTRIBUTE_HIDDEN As Long = &H2&
Const FILE_ATTRIBUTE_NORMAL As Long = &H80&
Const FILE_ATTRIBUTE_READONLY As Long = &H1&
Const FILE_ATTRIBUTE_SYSTEM As Long = &H4&
Const FILE_ATTRIBUTE_TEMPORARY As Long = &H100&

Const MAX_PATH = 260

Private Type FILETIME
  dwLowDateTime As Long
  dwHighDateTime As Long
End Type

Private Type WIN32_FIND_DATA
  dwFileAttributes As Long
  ftCreationTime As FILETIME
  ftLastAccessTime As FILETIME
  ftLastWriteTime As FILETIME
  nFileSizeHigh As Long
  nFileSizeLow As Long
  dwReserved0 As Long
  dwReserved1 As Long
  cFileName As String * MAX_PATH
  cAlternate As String * 14
End Type

'-External Functions----------------------------------------------------
Private Declare Function FindFirstFile Lib "kernel32" Alias _
  "FindFirstFileA" (ByVal lpFileName As String, _
  lpFindFileData As WIN32_FIND_DATA) As Long

Private Declare Function FindNextFile Lib "kernel32" Alias _
  "FindNextFileA" (ByVal hFindFile As Long, _
  lpFindFileData As WIN32_FIND_DATA) As Long

Private Declare Function FindClose Lib "kernel32" (ByVal _
  hFindFile As Long) As Long

'-GlobalVariables-------------------------------------------------------
Private glFolderPath As String

'-FindPDFFile-----------------------------------------------------------
'-
'- Findet alle PDF-Dateien in einer Verzeichnisstruktur, schreibt
'- deren Titel in das aktive Word-Dokument und setzt einen Link
'- auf die PDF-Datei
'-
'-----------------------------------------------------------------------
Sub FindPDFFile(ByVal FolderPath As String, ByVal Relative As Boolean)

  Dim WFD As WIN32_FIND_DATA
  Dim hSearch As Long
  Dim strFileName As String
  Dim relPath As String
  Dim aDoc As Acrobat.AcroPDDoc

  If Right$(FolderPath, 1) <> "\" Then
    FolderPath = FolderPath & "\"
  End If
  
  hSearch = FindFirstFile(FolderPath & "*.*", WFD)
  If hSearch <> INVALID_HANDLE_VALUE Then
    Do
      strFileName = Left(WFD.cFileName, InStr(WFD.cFileName, _
        Chr(0)) - 1)
      If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) _
        = FILE_ATTRIBUTE_DIRECTORY Then
        If (strFileName <> ".") And (strFileName <> "..") Then
          '-Rekursiver Funktionsaufruf, wenn neuer Ordner---------------
            FindPDFFile FolderPath & strFileName, Relative
        End If
      Else
        If LCase(Right(strFileName, 3)) = "pdf" Then
          '-PDF-Dokument oeffnen----------------------------------------
            Set aDoc = CreateObject("AcroExch.PDDoc")
            aDoc.Open FolderPath & strFileName
          '-Titel des PDF-Dokumentes in Word schreiben------------------
            Selection.TypeText aDoc.GetInfo("Title")
          '-Verlinkung zum PDF-Dokument herstellen----------------------
            Selection.HomeKey
            Selection.EndKey wdLine, wdExtend
            If Relative Then
              '-Relativer Pfad------------------------------------------
                relPath = Right(FolderPath, Len(FolderPath) - _
                  Len(glFolderPath))
                Hyperlinks.Add Selection.Range, relPath & _
                  strFileName
            Else
              '-Absoluter Pfad------------------------------------------
                Hyperlinks.Add Selection.Range, FolderPath & _
                  strFileName
            End If
            Selection.TypeParagraph
          '-PDF-Dokument schliessen-------------------------------------
            aDoc.Close
            Set aDoc = Nothing
        End If
      End If
    Loop While FindNextFile(hSearch, WFD)
    FindClose hSearch
  End If

End Sub

'-RelativeStub----------------------------------------------------------
'-
'- Vorgelagerte Prozedur von FindPDFFile zur Beruecksichtigung
'- relativer Pfade
'-
'-----------------------------------------------------------------------
Sub RelativeStub(ByVal FolderPath As String, _
  ByVal Relative As Boolean)

  '-Set global variable-------------------------------------------------
  glFolderPath = FolderPath

  '-Save document in folder---------------------------------------------
  ActiveDocument.SaveAs FolderPath & "Index.doc"

  FindPDFFile FolderPath, Relative

  '-Save and close document---------------------------------------------
  ActiveDocument.Close wdSaveChanges

End Sub

'-GetAllPDFFilesTitles--------------------------------------------------
Sub GetAllPDFFilesTitles()

  '-Here flag for using relative path-----------------------------------
  Dim Relative As Boolean
  Relative = True
  '-Here path to the root of the PDF files------------------------------
  Dim FolderPath As String
  FolderPath = "D:\Dummy"

  If Right$(FolderPath, 1) <> "\" Then
    FolderPath = FolderPath & "\"
  End If

  RelativeStub FolderPath, Relative

End Sub

'-End-------------------------------------------------------------------