We help IT Professionals succeed at work.

how can this code be modified, so that instead of putting the data in Excel, it puts it in Word

Flora Edwards
Flora Edwards asked
on
i found this code in one of the forums.

how can this be modified that instead of putting the data into excel, it puts them into word document.

thanks.

Sub ExtractPDFs()
'Note: Requires reference to Acrobat object library, via Tools|References
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, xlBook As Workbook, xlSheet As Worksheet
Dim AcroApp As CAcroApp, AcroAVDoc As CAcroAVDoc, AcroPDDoc As CAcroPDDoc
Dim AcroTextSelect As CAcroPDTextSelect, PageNumber As Object, PageContent As Object
Dim i As Long, j As Long, k As Long, StrContent As String
strFolder = GetFolder
If strFolder = "" Then Exit Sub
Set xlBook = ActiveWorkbook 'Workbooks.Open(Filename:="", AddToMRU:=False)
Set AcroAVDoc = CreateObject("AcroExch.AVDoc")
Set AcroApp = CreateObject("AcroExch.App")
strFile = Dir(strFolder & "\*.pdf", vbNormal)
While strFile <> ""
  If AcroAVDoc.Open(strFolder & "\" & strFile, vbNull) = True Then
    Set xlSheet = xlBook.Sheets.Add
    xlSheet.Name = Split(strFile, ".pdf")(0)
    Application.ScreenUpdating = True
    Application.ScreenUpdating = False
    While AcroAVDoc Is Nothing
      Set AcroAVDoc = AcroApp.GetActiveDoc
    Wend
    StrContent = ""
    Set AcroPDDoc = AcroAVDoc.GetPDDoc
    For i = 0 To AcroPDDoc.GetNumPages - 1
      Set PageNumber = AcroPDDoc.AcquirePage(i)
      Set PageContent = CreateObject("AcroExch.HiliteList")
      If PageContent.Add(0, 9000) = True Then
        Set AcroTextSelect = PageNumber.CreatePageHilite(PageContent)
        ' The next line is needed to avoid errors with protected PDFs that can't be read
        On Error Resume Next
        For j = 0 To AcroTextSelect.GetNumText - 1
          StrContent = StrContent & AcroTextSelect.GetText(j)
        Next j
        With xlSheet
          j = .UsedRange.Rows.Count + 1
          For k = 0 To UBound(Split(StrContent, vbCr))
            .Range("A" & j + k).Value = Split(StrContent, vbCr)(k)
          Next
          .Range("A1").Value = strFile
          .UsedRange.WrapText = False
        End With
      End If
    Next i
    AcroAVDoc.Close True
  End If
  strFile = Dir()
Wend
Set xlSheet = Nothing: Set xlBook = Nothing
Set PageContent = Nothing: Set PageNumber = Nothing
Set AcroTextSelect = Nothing: Set AcroAVDoc = Nothing: Set AcroApp = Nothing
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

Open in new window

Comment
Watch Question

View Solutions Only

aikimark
Top Expert 2014

Commented:
Do you want to put the data into a table in a Word document?
Flora EdwardsMedicine

Author

Commented:
Yes. if the pdf has table.  but if it is plain text then just plain text.  simply put just copy and paste.
Retired
Top Expert 2012
Commented:
This Word macro is untested because I can't find an Acrobat library that has all the properties used.
Also, it would help to have at least one PDF of the required format.
Option Explicit

Sub ExtractPDFsToWordTable()
'Note: Requires reference to Acrobat object library, via Tools|References
Dim strFolder As String, strFile As String, xlBook As Workbook, xlSheet As Worksheet
Dim AcroApp As CAcroApp, AcroAVDoc As CAcroAVDoc, AcroPDDoc As CAcroPDDoc
Dim AcroTextSelect As CAcroPDTextSelect, PageNumber As Object, PageContent As Object
Dim i As Long, j As Long, k As Long, StrContent As String
Dim doc As Word.Document
Dim strContents() As String
Dim tbl As Word.Table
Dim rw As Word.row
Dim c As Integer

strFolder = GetFolder
If strFolder = "" Then Exit Sub

Set AcroAVDoc = CreateObject("AcroExch.AVDoc")
Set AcroApp = CreateObject("AcroExch.App")
strFile = Dir(strFolder & "\*.pdf", vbNormal)
Set doc = Documents.Add
Set tbl = doc.Tables.Add(doc.Range, 1, 1)

Application.ScreenUpdating = False

    Do Until strFile = ""
      If AcroAVDoc.Open(strFolder & "\" & strFile, vbNull) = True Then
        Set rw = tbl.Rows.Add
        rw.Cells(1).Range.Text = Split(strFile, ".pdf")(0)
        While AcroAVDoc Is Nothing
          Set AcroAVDoc = AcroApp.GetActiveDoc
        Wend
        StrContent = ""
        Set AcroPDDoc = AcroAVDoc.GetPDDoc
        For i = 0 To AcroPDDoc.GetNumPages - 1
          Set PageNumber = AcroPDDoc.AcquirePage(i)
          Set PageContent = CreateObject("AcroExch.HiliteList")
          If PageContent.Add(0, 9000) = True Then
            Set AcroTextSelect = PageNumber.CreatePageHilite(PageContent)
            ' The next line is needed to avoid errors with protected PDFs that can't be read
            On Error Resume Next
            For j = 0 To AcroTextSelect.GetNumText - 1
              StrContent = StrContent & AcroTextSelect.GetText(j)
            Next j
            On Error GoTo 0 'resume error checking
            If Len(StrContent) > 0 Then
                strContents = Split(StrContent, vbCr)
                Do While (UBound(strContents) + 2) > tbl.Columns.Count
                    tbl.Columns.Add
                Loop
                For c = 0 To UBound(strContents)
                    rw.Cells(c + 2).Range.Text = strContents(c)
                Next c
            End If
          End If
        Next i
        AcroAVDoc.Close True
      End If
      strFile = Dir()
    Loop
    
Application.ScreenUpdating = True
End Sub

Open in new window

Flora EdwardsMedicine

Author

Commented:
Thanks very much GrahamSkan

i added Word reference from the library and then ran the macro

debugger stop at line 21 Set doc = Documents.Add

2017-12-01-16_25_05-Microsoft-Visual.png
aikimark
Top Expert 2014
Commented:
It should resemble something like this.  
Note: This is untested code.
Option Explicit

Sub ExtractPDFs()
    'Note: Requires reference to Acrobat object library, via Tools|References
    Dim strFolder As String, strFile As String
    'xlBook As Workbook, xlSheet As Worksheet
    Dim AcroApp As CAcroApp, AcroAVDoc As CAcroAVDoc, AcroPDDoc As CAcroPDDoc
    Dim AcroTextSelect As CAcroPDTextSelect, PageNumber As Object, PageContent As Object
    Dim i As Long, j As Long, k As Long, StrContent As String
    
    strFolder = GetFolder
    If strFolder = "" Then Exit Sub
    
    Set xlBook = ActiveWorkbook 'Workbooks.Open(Filename:="", AddToMRU:=False)
    Set AcroAVDoc = CreateObject("AcroExch.AVDoc")
    Set AcroApp = CreateObject("AcroExch.App")
    
    strFile = Dir(strFolder & "\*.pdf", vbNormal)
    While strFile <> ""
      If AcroAVDoc.Open(strFolder & "\" & strFile, vbNull) = True Then
        'Set xlSheet = xlBook.Sheets.Add
        'xlSheet.Name = Split(strFile, ".pdf")(0)
        'Application.ScreenUpdating = True
        Application.ScreenUpdating = False
        While AcroAVDoc Is Nothing
          Set AcroAVDoc = AcroApp.GetActiveDoc
        Wend
        StrContent = ""
        Set AcroPDDoc = AcroAVDoc.GetPDDoc
        For i = 0 To AcroPDDoc.GetNumPages - 1
          Set PageNumber = AcroPDDoc.AcquirePage(i)
          Set PageContent = CreateObject("AcroExch.HiliteList")
          If PageContent.Add(0, 9000) = True Then
            Set AcroTextSelect = PageNumber.CreatePageHilite(PageContent)
            ' The next line is needed to avoid errors with protected PDFs that can't be read
            On Error Resume Next
            For j = 0 To AcroTextSelect.GetNumText - 1
              StrContent = StrContent & AcroTextSelect.GetText(j)
            Next j
            
            ActiveDocument.Range.Text = strFile & vbCrLf
            ActiveDocument.Range.Text = StrContent
            ActiveDocument.Content.InsertBreak wdPageBreak
          End If
          
        Next i
        AcroAVDoc.Close True
      End If
      strFile = Dir()
    Wend
    
    Set PageContent = Nothing
    Set PageNumber = Nothing
    Set AcroTextSelect = Nothing
    Set AcroAVDoc = Nothing
    Set AcroApp = Nothing
    
    Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
    Dim oFolder As Object
    GetFolder = ""
    Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
    If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
    Set oFolder = Nothing
End Function

Open in new window

Flora EdwardsMedicine

Author

Commented:
thank you both.
GrahamSkanRetired
Top Expert 2012

Commented:
Sorry, Flora. I had my 'Comments' notification turned off.  I see that you've managed to get something working so you probably don't need this information.
My code is a Word macro, so the reference is set by the application. You will also see that there is no attempt to create or get the Word Application object in the code.
Flora EdwardsMedicine

Author

Commented:
thank you GrahamSkan.

Yes, I managed to get something working from your code.  Much appreciated.