troubleshooting Question

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

Avatar of Flora Edwards
Flora EdwardsFlag for Sweden asked on
VBAMicrosoft Word
8 Comments2 Solutions183 ViewsLast Modified:
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
ASKER CERTIFIED SOLUTION
GrahamSkan
Retired

Our community of experts have been thoroughly vetted for their expertise and industry experience.

Top Expert 2012

The Distinguished Expert awards are presented to the top veteran and rookie experts to earn the most points in the top 50 topics.

Join our community to see this answer!
Unlock 2 Answers and 8 Comments.
Start Free Trial
Learn from the best

Network and collaborate with thousands of CTOs, CISOs, and IT Pros rooting for you and your success.

Andrew Hancock - VMware vExpert
See if this solution works for you by signing up for a 7 day free trial.
Unlock 2 Answers and 8 Comments.
Try for 7 days

”The time we save is the biggest benefit of E-E to our team. What could take multiple guys 2 hours or more each to find is accessed in around 15 minutes on Experts Exchange.

-Mike Kapnisakis, Warner Bros