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

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

LVL 6
FloraAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

aikimarkCommented:
Do you want to put the data into a table in a Word document?
0
FloraAuthor Commented:
Yes. if the pdf has table.  but if it is plain text then just plain text.  simply put just copy and paste.
0
GrahamSkanRetiredCommented:
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

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Cloud Class® Course: CompTIA Cloud+

The CompTIA Cloud+ Basic training course will teach you about cloud concepts and models, data storage, networking, and network infrastructure.

Start This Course
FloraAuthor 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
0
aikimarkCommented:
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

0
FloraAuthor Commented:
thank you both.
0
GrahamSkanRetiredCommented:
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.
0
FloraAuthor Commented:
thank you GrahamSkan.

Yes, I managed to get something working from your code.  Much appreciated.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
VBA

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.