4
\$\begingroup\$

In order to write some reports I have to manually copy the name of client, address, claim number, etc from a pdf that I receive. I want to automate this part of the report writing by using vba to copy the relevant information into my word file.

This is what my program does:

  1. open the pdf with adobe acrobat and copy the content of the file onto the clipboard
  2. open an excel worksheet and paste that content there.
  3. Loop through the worksheet and store the relevant information in variables
  4. In my word document find a replace some keywords by the information that I want to put in

I would like to know if my code follows best practices or if there's any recommendations to make it more robust. should I consider ditching the excel step or maybe using mailmerge instead of find and replace? that kind stuff.

There's also an issue with opening adobe to copy the content of the pdf, I had to put a delay but it looks clumsy and if the user changes window or starts clicking around then nothing is copied from the pdf.

Idk if I can ask this here but right now the macro just works on the same document, is it possible to make it make a copy of the document so that I don't have to manually save as and then discard the changes

Public Declare PtrSafe Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As LongPtr)
Sub fillTemplatePDF()

Dim strExcelFilename As String
Dim strAdobeReaderExePath As String

'filename to a excelfile that will be used to run the program
'path to acrobat.exe

strExcelFilename = "C:\Users\jonix\Desktop\test1.xlsx"
strAdobeReaderExePath = "C:\Program Files (x86)\Adobe\Acrobat DC\Acrobat\Acrobat.exe"

Dim cell As Excel.Range 'used to traverse the excel file
Dim S(13) As String 'Find in excel text
Dim R(15) As String 'Replacement text
Dim Q(15) As String 'Find in word text
Dim j As Integer 'j is a counter

'Find in excell text
S(0) = "RCC Project #"
S(1) = "Client Company Name"
S(2) = "Client Contact"
S(3) = "Client Address"
S(4) = "City"
S(5) = "State"
S(6) = "ZIP Code"
S(7) = "Claim #"
S(8) = "Name of Insured"
S(9) = "Address of Loss"
S(10) = "City"
S(11) = "State"
S(12) = "ZIP Code"


'Find in word text
Q(0) = "<<RCC Project #>>"
Q(1) = "<<Client Company Name>>"
Q(2) = "<<Client Contact>>"
Q(3) = "<<Client Address>>"
Q(4) = "<<Client City>>"
Q(5) = "<<Client State>>"
Q(6) = "<<Client ZIP Code>>"
Q(7) = "<<Claim #>>"
Q(8) = "<<Name of Insured>>"
Q(9) = "<<Address of Loss>>"
Q(10) = "<<Loss City>>"
Q(11) = "<<Loss State>>"
Q(12) = "<<Loss ZIP Code>>"
Q(13) = "<<Evaluation>>"
Q(14) = "<<Date>>"


'Variables

Dim xlsApplication As Excel.Application
Dim xlsWorkbook As Excel.Workbook
Dim xlsWorksheet As Excel.Worksheet
Dim xlsRange As Excel.Range
Dim boolExcelWasNotRunning As Boolean

Dim strPDFFilename As String
Dim strShellPathName As String

Dim fd As FileDialog
 Set fd = Application.FileDialog(msoFileDialogFilePicker)
 Dim vrtSelectedItem As Variant
 If fd.Show = -1 Then
 vrtSelectedItem = fd.SelectedItems(1)
 End If

'pdf filenames
strPDFFilename = vrtSelectedItem
strShellPathName = strAdobeReaderExePath & " """ & strPDFFilename & """"

'COPY FROM ADOBE
'Open adobe
Call Shell( _
    pathname:=strShellPathName, _
    windowstyle:=vbNormalFocus)

'Wait because the last command is asynchronous
Sleep 3000

'Select all, copy
SendKeys "^a"
SendKeys "^c"

'wait again.
Sleep 3000


'PASTE IN EXCEL
'if Excel is running, get a handle on it; otherwise start a new instance of Excel
    On Error Resume Next
    Set xlsApplication = GetObject(, "Excel.Application")
    
    If Err Then
       boolExcelWasNotRunning = True
       Set xlsApplication = New Excel.Application
    End If
    
    On Error GoTo Err_Handler

'open excel visibly for debug
'xlsApplication.Visible = True


'Open the workbook/worksheet
Set xlsWorkbook = xlsApplication.Workbooks.Open(FileName:=strExcelFilename)
Set xlsWorksheet = ActiveWorkbook.Worksheets("Sheet1")

Cells.Clear
With xlsWorksheet
    
    'paste
    .Range("A1").Select
    .PasteSpecial Format:="Text"
    
    'FIND IN EXCEL
    'find the words saved in S and store the values in R
    j = 0
    For Each a In .Range("A1:A30").Cells

        If Left(a, Len(S(j))) = S(j) Then
            R(j) = Mid(a, Len(S(j)) + 3)
            j = j + 1
        End If
        If j = 13 Then
            Exit For
        End If
    Next a
   
    
    If Range("A8").Value Like "*EVALUATION" Then
   
    R(13) = StrConv(.Range("A8").Value, vbProperCase)
    MsgBox R(13)
    Else
    R(13) = Q(13)
    End If
    
    R(14) = Format(Date, "MMMM DD, YYYY ")
End With

'FIND IN WORD AND REPLACE
'Word: replace in the template
With ActiveDocument.Content.Find
    For j = 0 To 15
        .Replacement.Font.Color = wdColorBlack
        .Text = Q(j)
        .Replacement.Text = R(j)
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
    Next j
End With


'CLOSE STUFF
'Call Shell("TaskKill /F /IM AcroRd32.exe", vbHide)

'Close excel
If xlsApplication.Workbooks.Count > 1 Then
  xlsWorkbook.Close
Else
  xlsWorkbook.Saved = True
  xlsApplication.Quit
End If

'Make sure you release object references.
Set xlsRange = Nothing
Set xlsWorksheet = Nothing
Set xlsWorkbook = Nothing
Set xlsApplication = Nothing
Set fd = Nothing



'quit
Exit Sub

Err_Handler:
   MsgBox strExcelFilename & " caused a problem. " & Err.Description, vbCritical, _
           "Error: " & Err.Number
   If boolExcelWasNotRunning Then
       xlsApplication.Quit
   End If



End Sub



Here is a sample pdf of what I'm working with pdf

And the word document would have something like this:

<<Date>>

<<Client Company Name>>
<<Client Address>>
<<Client City>>, <<Client State>> <<Client ZIP Code>>
Attention: Mr./Mrs. <<Client Contact>>
Re: <<Evaluation>>
<<Name of Insured>> Residence
<<Address of Loss>>
<<Loss City>>, <<Loss State>> <<Loss ZIP Code>>
RCC Project #: <<RCC Project #>>
Claim #: <<Claim #>>
Dear Mr./Mrs. <<Client Contact>>,

\$\endgroup\$
5
  • 3
    \$\begingroup\$ is it possible to make it make a copy of the document - of course it's possible =) I'm not very familiar with the Word object model but have you tried Document.SaveAs2? That said you are correct to doubt this being the right place to ask - everything else in your post is 100% top-notch, congratulations on passing "first post" with flying colors! \$\endgroup\$ Commented Feb 10, 2021 at 17:31
  • 1
    \$\begingroup\$ @joniponi Are you using a free version of Acrobat like Acrobat Reader or do you have a paid version like Acrobat Acrobat DC or Pro? I ask because the paid versions come with a library that you can use in VBA directly and there would be no need for using shell to copy contents. That library gives you a lot of functionality. \$\endgroup\$ Commented Feb 18, 2021 at 9:33
  • \$\begingroup\$ @CristianBuse thank you! I was using the free version but I do have Adobe Acrobat DC. I had not looked into that yet. Are you referring to Acrobat SDK? and do you have any suggestion on how to tackle it? \$\endgroup\$
    – joniponi
    Commented Feb 23, 2021 at 4:17
  • \$\begingroup\$ @janiponi I've added a response on how to read the file without shell. If I will have time I will expand on the rest of you code in the following days. \$\endgroup\$ Commented Feb 23, 2021 at 11:32
  • \$\begingroup\$ @joniponi I've added a longer solution in the Edit #1 section of the answer. Hope it helps. \$\endgroup\$ Commented Feb 24, 2021 at 14:06

1 Answer 1

1
\$\begingroup\$

If Adobe Acrobat DC is available then to convert a PDF file to an Excel .xlsx file use (code in a standard .bas module):

Option Explicit
Option Private Module

'*******************************************************************************
'Save a PDF file as XLSX
'*******************************************************************************
Public Function PDFToXlsx(ByVal inPDFFilePath As String, ByVal outXLSXFilePath) As Boolean
    If inPDFFilePath = vbNullString Then Exit Function
    If outXLSXFilePath = vbNullString Then Exit Function
    '
    On Error GoTo ErrorHandler
    Dim pdDoc As Object: Set pdDoc = CreateObject("AcroExch.PDDoc")
    '
    pdDoc.Open inPDFFilePath
    pdDoc.GetJSObject.SaveAs outXLSXFilePath, "com.adobe.acrobat.xlsx", True
    '
    PDFToXlsx = True
CleanExit:
    On Error Resume Next
    pdDoc.Close
    On Error GoTo 0
Exit Function
ErrorHandler:
    PDFToXlsx = False
    Resume CleanExit
End Function

'*******************************************************************************
'Get a file path by using an Excel FilePicker FileDialog
'*******************************************************************************
Public Function BrowseForFile(Optional ByVal initialPath As String _
    , Optional title As String _
    , Optional filterDesc As String _
    , Optional filters As String _
) As String
    Const dialogTypeFilePicker As Integer = 3
    '
    With Application.FileDialog(dialogTypeFilePicker)
        If title <> vbNullString Then .title = title
        If initialPath <> vbNullString Then .InitialFileName = initialPath
        .AllowMultiSelect = False
        If filterDesc <> vbNullString And filters <> vbNullString Then
            On Error Resume Next
            'Add first on top of the default filters
            .filters.Add filterDesc, filters
            'If not failed then remove all filters and add only the new filters
            If Err.Number = 0 Then
                .filters.Clear
                .filters.Add filterDesc, filters
            End If
            On Error GoTo 0
        End If
        .Show
        If .SelectedItems.Count > 0 Then
            BrowseForFile = CStr(.SelectedItems(1))
        End If
    End With
End Function

And a quick demo:

Public Sub Demo()
    Dim tempPDFPath As String
    Dim tempXLSXPath As String
    Dim book As Workbook
    '
    tempPDFPath = BrowseForFile(initialPath:=vbNullString _
                              , title:="Please select PDF file!" _
                              , filterDesc:="PDF Files" _
                              , filters:="*.pdf")
    If tempPDFPath = vbNullString Then Exit Sub
    '
    tempXLSXPath = VBA.Environ$("Temp") & "\XL_" & CLng(VBA.Timer * 1000) & ".xlsx"
    If PDFToXlsx(tempPDFPath, tempXLSXPath) Then
        Set book = Application.Workbooks.Open(tempXLSXPath, False, True)
        '
        'Do whatever you want with the Excel file
        Stop
        '
        '
        '
    End If
CleanExit:
    On Error Resume Next
    book.Close False
    Kill tempXLSXPath
    On Error GoTo 0
End Sub

The demo is written for Excel but it can be written for Word as well.

EDIT #1

Using the previous code to convert a PDF file to an XLSX file we can encapsulate all the logic of reading the data into a single method:

'*******************************************************************************
'Returns a Keyed Collection of Collections containing data
'*******************************************************************************
Private Function GetAssigmentDataFromPDF() As Collection
    Dim tempPDFPath As String
    Dim tempXLSXPath As String
    '
    tempPDFPath = BrowseForFile(initialPath:=vbNullString _
                              , title:="Please select PDF file!" _
                              , filterDesc:="PDF Files" _
                              , filters:="*.pdf")
    If tempPDFPath = vbNullString Then Exit Function
    '
    tempXLSXPath = VBA.Environ$("Temp") & "\XL_" & CLng(VBA.Timer * 1000) & ".xlsx"
    If Not PDFToXlsx(tempPDFPath, tempXLSXPath) Then GoTo CleanExit
    '
    'Note we run in a separate app in case there is one open but is busy
    Dim xlApp As Object: Set xlApp = CreateObject("Excel.Application") 'late-binded so no need for reference to Microsoft Excel XX.X Object Library
    Dim book As Object
    Dim arrValues() As Variant
    '
    Dim collData As Collection
    Dim v As Variant
    Dim colonIndex As Long
    Const COLON_CHAR As String = ":"
    Dim key_ As String
    '
    On Error GoTo CleanExit
    Set book = xlApp.Workbooks.Open(tempXLSXPath, False, True)
    arrValues = book.Worksheets(1).UsedRange.Value2
    '
    Set collData = New Collection
    For Each v In arrValues
        If VarType(v) = vbString Then
            colonIndex = InStr(1, v, COLON_CHAR)
            If colonIndex > 0 Then
                key_ = Left$(v, colonIndex - 1)
                If Not CollectionHasKey(collData, key_) Then
                    collData.Add New Collection, key_
                End If
                collData.Item(key_).Add Trim$(Right$(v, Len(v) - colonIndex))
            ElseIf v Like "*EVALUATION" Then
                If Not CollectionHasKey(collData, "Evaluation") Then
                    collData.Add StrConv(v, vbProperCase), "Evaluation"
                End If
            End If
        End If
    Next
    Set GetAssigmentDataFromPDF = collData
CleanExit:
    On Error Resume Next
    If Not book Is Nothing Then book.Close False
    Kill tempXLSXPath
    On Error GoTo 0
End Function

it uses an utility:

'*******************************************************************************
'Returns a boolean indicating if a Collection has a specific key
'Parameters:
'   - coll: a collection to check for key
'   - key_: the key being searched for
'Does not raise errors
'*******************************************************************************
Public Function CollectionHasKey(ByVal coll As Collection, ByVal key_ As String) As Boolean
    On Error Resume Next
    coll.Item key_
    CollectionHasKey = (Err.Number = 0)
    On Error GoTo 0
End Function

The GetAssigmentDataFromPDF returns a collection of collections. Why? Because you have duplicates (e.g. City, State and Zip Code) and there could be more duplicates in the future depending on the source PDF and how your needs evolve. So, for each unique key the main collection will have a sub-collection with as many occurences it can find for that key (e.g. you can now have 5 Zip Codes in the pdf and this will still work).

One other thing it does, it retrieves all key-value pairs from the PDF. In your case, the colon (:) character is found then the text is split into 2 parts, the key for fast retrieval and the actual value.

Consider this method running on top of the previous:

Option Explicit
Option Private Module

Private Type CLIENT_INFO
    ciCompanyName As String
    ciContact As String
    ciAddress As String
    ciCity As String
    ciState As String
    ciZipCode As String
    ciClaimNo As String
End Type
Private Type LOSS_INFO
    liNameOfInsured As String
    liAddressOfLoss As String
    liCity As String
    liState As String
    liZipCode As String
End Type
Private Type ASSIGNMENT_DATA
    adRccProjectNo As String
    adEvaluation As String
    adClientInfo As CLIENT_INFO
    adLossInfo As LOSS_INFO
    isInitialized As Boolean
End Type

'*******************************************************************************
'Returns an ASSIGNMENT_DATA structure
'*******************************************************************************
Private Function GetAssigmentData() As ASSIGNMENT_DATA
    Dim collData As Collection: Set collData = GetAssigmentDataFromPDF()
    If collData Is Nothing Then Exit Function
    '
    On Error GoTo CleanExit 'In case keys are missing
    With GetAssigmentData
        .adRccProjectNo = collData("RCC Project #")(1)
        If CollectionHasKey(collData, "Evaluation") Then
            .adEvaluation = collData("Evaluation")
        End If
        With .adClientInfo
            .ciCompanyName = collData("Client Company Name")(1)
            .ciContact = collData("Client Contact")(1)
            .ciAddress = collData("Client Address")(1)
            .ciCity = collData("City")(1)
            .ciState = collData("State")(1)
            .ciZipCode = collData("ZIP Code")(1)
            .ciClaimNo = collData("Claim #")(1)
        End With
        With .adLossInfo
            .liNameOfInsured = collData("Name of Insured")(1)
            .liAddressOfLoss = collData("Address of Loss")(1)
            .liCity = collData("City")(2)
            .liState = collData("State")(2)
            .liZipCode = collData("ZIP Code")(2)
        End With
        .isInitialized = True
    End With
CleanExit:
End Function

This method is only concerned with retrieving the minimum data you need but this can evolve without needing to change the GetAssigmentDataFromPDF method. For example you might want to capture the Email next time and all you need to do is to call collData("Email")(1).

The text replace part could sit in it's own method:

'*******************************************************************************
'Replaces a text in Ms Word
'*******************************************************************************
Private Sub ReplaceTextInDoc(ByVal doc As Document _
                           , ByVal searchText As String _
                           , ByVal replacementText As String _
)
    With doc.Content.Find
        .Replacement.Font.Color = wdColorBlack
        .Text = searchText
        .Replacement.Text = replacementText
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
    End With
End Sub

so that the main method can be simplified to:

'*******************************************************************************
'Main method
'*******************************************************************************
Public Sub FillTemplatePDF()
    Dim assignmentData As ASSIGNMENT_DATA
    '
    assignmentData = GetAssigmentData()
    If Not assignmentData.isInitialized Then
        MsgBox "Could not retrieve assignment data!", vbInformation, "Cancelled"
        Exit Sub
    End If
    '
    Dim newDoc As Document
    '
    Set newDoc = Application.Documents.Add()
    newDoc.Range.InsertFile ThisDocument.FullName 'Copy contents into new book
    '
    ReplaceTextInDoc newDoc, "<<RCC Project #>>", assignmentData.adRccProjectNo
    With assignmentData.adClientInfo
        ReplaceTextInDoc newDoc, "<<Client Company Name>>", .ciCompanyName
        ReplaceTextInDoc newDoc, "<<Client Contact>>", .ciContact
        ReplaceTextInDoc newDoc, "<<Client Address>>", .ciAddress
        ReplaceTextInDoc newDoc, "<<Client City>>", .ciCity
        ReplaceTextInDoc newDoc, "<<Client State>>", .ciState
        ReplaceTextInDoc newDoc, "<<Client ZIP Code>>", .ciZipCode
        ReplaceTextInDoc newDoc, "<<Claim #>>", .ciClaimNo
    End With
    With assignmentData.adLossInfo
        ReplaceTextInDoc newDoc, "<<Name of Insured>>", .liNameOfInsured
        ReplaceTextInDoc newDoc, "<<Address of Loss>>", .liAddressOfLoss
        ReplaceTextInDoc newDoc, "<<Loss City>>", .liCity
        ReplaceTextInDoc newDoc, "<<Loss State>>", .liState
        ReplaceTextInDoc newDoc, "<<Loss ZIP Code>>", .liZipCode
    End With
    If assignmentData.adEvaluation <> vbNullString Then
        ReplaceTextInDoc newDoc, "<<Evaluation>>", assignmentData.adEvaluation
    End If
    ReplaceTextInDoc newDoc, "<<Date>>", Format(Now, "MMMM DD, YYYY")
End Sub

I separated the tasks in individual methods to make code easier to follow and maintain. Each method builds on top of other(s) method(s).

Full code

Add this code to your Word file and run FillTemplatePDF (your original method name) to generate a new Word Document (unsaved):

Option Explicit
Option Private Module

Private Type CLIENT_INFO
    ciCompanyName As String
    ciContact As String
    ciAddress As String
    ciCity As String
    ciState As String
    ciZipCode As String
    ciClaimNo As String
End Type
Private Type LOSS_INFO
    liNameOfInsured As String
    liAddressOfLoss As String
    liCity As String
    liState As String
    liZipCode As String
End Type
Private Type ASSIGNMENT_DATA
    adRccProjectNo As String
    adEvaluation As String
    adClientInfo As CLIENT_INFO
    adLossInfo As LOSS_INFO
    isInitialized As Boolean
End Type

'*******************************************************************************
'Main method
'*******************************************************************************
Public Sub FillTemplatePDF()
    Dim assignmentData As ASSIGNMENT_DATA
    '
    assignmentData = GetAssigmentData()
    If Not assignmentData.isInitialized Then
        MsgBox "Could not retrieve assignment data!", vbInformation, "Cancelled"
        Exit Sub
    End If
    '
    Dim newDoc As Document
    '
    Set newDoc = Application.Documents.Add()
    newDoc.Range.InsertFile ThisDocument.FullName 'Copy contents into new book
    '
    ReplaceTextInDoc newDoc, "<<RCC Project #>>", assignmentData.adRccProjectNo
    With assignmentData.adClientInfo
        ReplaceTextInDoc newDoc, "<<Client Company Name>>", .ciCompanyName
        ReplaceTextInDoc newDoc, "<<Client Contact>>", .ciContact
        ReplaceTextInDoc newDoc, "<<Client Address>>", .ciAddress
        ReplaceTextInDoc newDoc, "<<Client City>>", .ciCity
        ReplaceTextInDoc newDoc, "<<Client State>>", .ciState
        ReplaceTextInDoc newDoc, "<<Client ZIP Code>>", .ciZipCode
        ReplaceTextInDoc newDoc, "<<Claim #>>", .ciClaimNo
    End With
    With assignmentData.adLossInfo
        ReplaceTextInDoc newDoc, "<<Name of Insured>>", .liNameOfInsured
        ReplaceTextInDoc newDoc, "<<Address of Loss>>", .liAddressOfLoss
        ReplaceTextInDoc newDoc, "<<Loss City>>", .liCity
        ReplaceTextInDoc newDoc, "<<Loss State>>", .liState
        ReplaceTextInDoc newDoc, "<<Loss ZIP Code>>", .liZipCode
    End With
    If assignmentData.adEvaluation <> vbNullString Then
        ReplaceTextInDoc newDoc, "<<Evaluation>>", assignmentData.adEvaluation
    End If
    ReplaceTextInDoc newDoc, "<<Date>>", Format(Now, "MMMM DD, YYYY")
End Sub

'*******************************************************************************
'Replaces a text in Ms Word
'*******************************************************************************
Private Sub ReplaceTextInDoc(ByVal doc As Document _
                           , ByVal searchText As String _
                           , ByVal replacementText As String _
)
    With doc.Content.Find
        .Replacement.Font.Color = wdColorBlack
        .Text = searchText
        .Replacement.Text = replacementText
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=wdReplaceAll
    End With
End Sub

'*******************************************************************************
'Returns an ASSIGNMENT_DATA structure
'*******************************************************************************
Private Function GetAssigmentData() As ASSIGNMENT_DATA
    Dim collData As Collection: Set collData = GetAssigmentDataFromPDF()
    If collData Is Nothing Then Exit Function
    '
    On Error GoTo CleanExit 'In case keys are missing
    With GetAssigmentData
        .adRccProjectNo = collData("RCC Project #")(1)
        If CollectionHasKey(collData, "Evaluation") Then
            .adEvaluation = collData("Evaluation")
        End If
        With .adClientInfo
            .ciCompanyName = collData("Client Company Name")(1)
            .ciContact = collData("Client Contact")(1)
            .ciAddress = collData("Client Address")(1)
            .ciCity = collData("City")(1)
            .ciState = collData("State")(1)
            .ciZipCode = collData("ZIP Code")(1)
            .ciClaimNo = collData("Claim #")(1)
        End With
        With .adLossInfo
            .liNameOfInsured = collData("Name of Insured")(1)
            .liAddressOfLoss = collData("Address of Loss")(1)
            .liCity = collData("City")(2)
            .liState = collData("State")(2)
            .liZipCode = collData("ZIP Code")(2)
        End With
        .isInitialized = True
    End With
CleanExit:
End Function

'*******************************************************************************
'Returns a Keyed Collection of Collections containing data
'*******************************************************************************
Private Function GetAssigmentDataFromPDF() As Collection
    Dim tempPDFPath As String
    Dim tempXLSXPath As String
    '
    tempPDFPath = BrowseForFile(initialPath:=vbNullString _
                              , title:="Please select PDF file!" _
                              , filterDesc:="PDF Files" _
                              , filters:="*.pdf")
    If tempPDFPath = vbNullString Then Exit Function
    '
    tempXLSXPath = VBA.Environ$("Temp") & "\XL_" & CLng(VBA.Timer * 1000) & ".xlsx"
    If Not PDFToXlsx(tempPDFPath, tempXLSXPath) Then GoTo CleanExit
    '
    'Note we run in a separate app in case there is one open but is busy
    Dim xlApp As Object: Set xlApp = CreateObject("Excel.Application") 'late-binded so no need for reference to Microsoft Excel XX.X Object Library
    Dim book As Object
    Dim arrValues() As Variant
    '
    Dim collData As Collection
    Dim v As Variant
    Dim colonIndex As Long
    Const COLON_CHAR As String = ":"
    Dim key_ As String
    '
    On Error GoTo CleanExit
    Set book = xlApp.Workbooks.Open(tempXLSXPath, False, True)
    arrValues = book.Worksheets(1).UsedRange.Value2
    '
    Set collData = New Collection
    For Each v In arrValues
        If VarType(v) = vbString Then
            colonIndex = InStr(1, v, COLON_CHAR)
            If colonIndex > 0 Then
                key_ = Left$(v, colonIndex - 1)
                If Not CollectionHasKey(collData, key_) Then
                    collData.Add New Collection, key_
                End If
                collData.Item(key_).Add Trim$(Right$(v, Len(v) - colonIndex))
            ElseIf v Like "*EVALUATION" Then
                If Not CollectionHasKey(collData, "Evaluation") Then
                    collData.Add StrConv(v, vbProperCase), "Evaluation"
                End If
            End If
        End If
    Next
    Set GetAssigmentDataFromPDF = collData
CleanExit:
    On Error Resume Next
    If Not book Is Nothing Then book.Close False
    Kill tempXLSXPath
    On Error GoTo 0
End Function

'*******************************************************************************
'Save a PDF file as XLSX
'*******************************************************************************
Public Function PDFToXlsx(ByVal inPDFFilePath As String, ByVal outXLSXFilePath) As Boolean
    If inPDFFilePath = vbNullString Then Exit Function
    If outXLSXFilePath = vbNullString Then Exit Function
    '
    On Error GoTo ErrorHandler
    Dim pdDoc As Object: Set pdDoc = CreateObject("AcroExch.PDDoc")
    '
    pdDoc.Open inPDFFilePath
    pdDoc.GetJSObject.SaveAs outXLSXFilePath, "com.adobe.acrobat.xlsx", True
    '
    PDFToXlsx = True
CleanExit:
    On Error Resume Next
    pdDoc.Close
    On Error GoTo 0
Exit Function
ErrorHandler:
    PDFToXlsx = False
    Resume CleanExit
End Function

'*******************************************************************************
'Get a file path by using an Excel FilePicker FileDialog
'*******************************************************************************
Public Function BrowseForFile(Optional ByVal initialPath As String _
    , Optional title As String _
    , Optional filterDesc As String _
    , Optional filters As String _
) As String
    Const dialogTypeFilePicker As Integer = 3
    '
    With Application.FileDialog(dialogTypeFilePicker)
        If title <> vbNullString Then .title = title
        If initialPath <> vbNullString Then .InitialFileName = initialPath
        .AllowMultiSelect = False
        If filterDesc <> vbNullString And filters <> vbNullString Then
            On Error Resume Next
            'Add first on top of the default filters
            .filters.Add filterDesc, filters
            'If not failed then remove all filters and add only the new filters
            If Err.Number = 0 Then
                .filters.Clear
                .filters.Add filterDesc, filters
            End If
            On Error GoTo 0
        End If
        .Show
        If .SelectedItems.Count > 0 Then
            BrowseForFile = CStr(.SelectedItems(1))
        End If
    End With
End Function

'*******************************************************************************
'Returns a boolean indicating if a Collection has a specific key
'Parameters:
'   - coll: a collection to check for key
'   - key_: the key being searched for
'Does not raise errors
'*******************************************************************************
Public Function CollectionHasKey(ByVal coll As Collection, ByVal key_ As String) As Boolean
    On Error Resume Next
    coll.Item key_
    CollectionHasKey = (Err.Number = 0)
    On Error GoTo 0
End Function

You do not need any references for this code to work. The Acrobat and the Excel objects are all late-binded.

\$\endgroup\$
1
  • \$\begingroup\$ Thank you! it works great! thank you \$\endgroup\$
    – joniponi
    Commented Feb 24, 2021 at 3:25

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.