The CompTIA Cloud+ Basic training course will teach you about cloud concepts and models, data storage, networking, and network infrastructure.
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.
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
Do more with
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Yes. if the pdf has table. but if it is plain text then just plain text. simply put just copy and paste.
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.
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
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
i added Word reference from the library and then ran the macro
debugger stop at line 21 Set doc = Documents.Add
It should resemble something like this.
Note: This is untested code.
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
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.
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.
Premium Content
You need an Expert Office subscription to comment.Start Free Trial