PDF to Modules (1 Viewer)

Function EnclosureText(sFile As String)
'1. To save time Extract specific page: MEMORANDUM (page 1)
'2. Open with Word to locate the Enclosure: text at bottom of page 1.
'3. Return the text
'based on Review test code
'Word Constants
'https://docs.microsoft.com/en-us/previous-versions/office/developer/office-2003/aa211923(v%3Doffice.11)
'Word VBA to find string and then obtain the entire sentence containing that string
'Look at Ron's post 01-12-2005 09:37 am as starting point for setting up the range
'and the find structure.
'Don't really need rest of code since not putting into Excel.
'http://www.vbaexpress.com/forum/archive/index.php/t-1322.html
'20190423
    Dim WordApp             As Object
    Dim worddoc             As Object
    Dim WordRange           As Object
    Dim sFileName           As String
    Dim bAppAlreadyOpen     As Boolean
    Dim stEnclosure         As String
    Dim found               As Integer
    
    bAppAlreadyOpen = True
    'Get an instance of word to work with
    'See if Word is already running
    On Error Resume Next
    Set WordApp = GetObject(, "Word.Application")
    If Err.Number <> 0 Then
        'Launch a new instance of Word
        Err.Clear
        On Error GoTo Error_Handler
        Set WordApp = CreateObject("Word.Application")
        bAppAlreadyOpen = False
    End If
    
    'Determine the Word doc filename without the path or extension
    sFileName = FileNameNoExt(sFile)
    'Open the document
    Set worddoc = WordApp.Documents.Open(sFile)
    Set WordRange = worddoc.Range
    worddoc.ActiveWindow.View.ReadingLayout = False
    WordApp.Application.Visible = True
    
    With WordApp
        'This gets all the text in the document and then function to extract phrase
        'stEnclosure = TrimAll(Mid(WordRange.Text, InStr(WordRange.Text, "Enclosure:") + 10))
        
        'This gets only the sentence containing the word to find.  Using this so less text
        'to go through. --Tested without function to verify picking what we are searching for--
        'Since not sure if can only grab text from the Found to the end of sentence, using the
        'Access mid function for that purpose.
        '20190424
        With WordRange.Find
            .Text = "Enclosure:"
            .Execute
            If .found Then
                WordRange.expand unit:=3 'wdSentence
                stEnclosure = TrimAll(Mid(WordRange.Text, InStr(WordRange.Text, "Enclosure:") + 10))
            End If
        End With
        EnclosureText = stEnclosure
    End With
     
Error_Handler_Exit:
    worddoc.Close False
    Set worddoc = Nothing
    If bAppAlreadyOpen = False Then WordApp.Quit
    Set WordApp = Nothing
    Exit Function

Error_Handler:
     MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
               "Error Number: " & Err.Number & vbCrLf & _
               "Error Source: PrintWordDoc" & vbCrLf & _
               "Error Description: " & Err.Description _
               , vbOKOnly + vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function

Function ExtractEnclosure(FileName As String, Optional pageno As Integer = 1)
'Grab the enclosure text from 1st page or other page as specified
'20190425
    Dim stfile As String
    Dim stExtractPages As String
    Dim stFolderName As String
    Dim stfilename As String
    Dim stPDFName As String
    Dim stEnclosure As String
    Dim retVal As Variant
    Dim yesno
    
    If InStr(Environ("Path"), "pdftk") = 0 Then
        MsgBox "It appears that PDF tool kit is not installed on this computer.  " & _
                "Please refer to user guide for instructions on how to install it. " & _
                "This program is needed in order to merge pdf files.", vbExclamation + vbOKOnly, "Missing Program PDFtk"
        Exit Function
    End If
    stFolderName = FILEPATH(FileName)
    stfilename = FileNameNoExt(FileName)
    stPDFName = stFolderName & stfilename & "_Enc.pdf"
    stExtractPages = Chr(34) & FileName & Chr(34) & " cat " & pageno & " output " & Chr(34) & stPDFName & Chr(34)
    If Len(Nz(stExtractPages, "")) > 0 Then
        retVal = Shell("pdftk " & stExtractPages, vbMaximizedFocus)
        MsgBox "Please wait for pdftk 'BLACK SCREEN' to close and then press OK to continue." & vbCrLf & vbCrLf & "Note:Big files may take longer to merge.  Please be patient", vbOKOnly + vbExclamation, "Files Merged"
        DoEvents
    End If
    ExtractEnclosure = EnclosureText(stPDFName)
End Function

Function ExtractReviewCode(sFile As String)
'This isn't being actively used, only set up to see
'if it could be done...
'1. To save time Extract specific page: EOR Review (page 2)
'2. Open with Word to locate the Engineer Review Code(s) within the table.
'   Visually, appears to be row 5 col 2, but there must be a hidden col as
'   location is row 5 col 3
'3. Gather cell data from the other 2 Engineer Review Codes on the page
'   in case they differ and a decision needs to be made as to which Code to use.
'Learned can convert pdf to word simply by opening the pdf in word from:
'https://social.msdn.microsoft.com/Forums/office/en-US/2d3a5cd3-38c3-4811-b3df-4f60848aec54/can-i-use-vba-to-convert-pdf-files-to-word-docs-or-text-files?forum=worddev
'Open word and the file, since no need to save
'or convert the file after it is opened, close the file without saving.  Only
'issue is that not sure how to by-pass the prompt to convert to Word.  Seems this
'popup doesn't always come to the front, so if not aware of it, may give the
'impression that the program is stuck/hanging/freezing when in fact is waiting
'for user to click on OK
'20190422
'The code in this link indicates a method to suppress the popup message
'https://social.msdn.microsoft.com/Forums/en-US/57f49b29-58cf-45e5-97cc-985fdd9a8c17/open-pdf-in-word-without-conversion-message?forum=isvvba
'On that page, search for:  Graham MayorMVP Sunday, March 13, 2016 9:55 AM (above that is the code)
'20190422
    Dim WordApp             As Object
    Dim worddoc             As Object
    Dim sFileName           As String
    Dim bAppAlreadyOpen     As Boolean
    Dim stReviewCode1       As String
    Dim stReviewCode2       As String
    Dim stReviewCode3       As String
    Dim stComments          As String
    
    bAppAlreadyOpen = True
    'Get an instance of word to work with
    'See if Word is already running
    On Error Resume Next
    Set WordApp = GetObject(, "Word.Application")
    If Err.Number <> 0 Then
        'Launch a new instance of Word
        Err.Clear
        On Error GoTo Error_Handler
        Set WordApp = CreateObject("Word.Application")
        bAppAlreadyOpen = False
    End If
    
    'Determine the Word doc filename without the path or extension
    sFileName = FileNameNoExt(sFile)
    'Open the document
    Set worddoc = WordApp.Documents.Open(sFile)
    worddoc.ActiveWindow.View.ReadingLayout = False
    WordApp.Application.Visible = True
    If worddoc.Tables.Count = 1 Then
        With worddoc.Tables(1)
            stReviewCode1 = .cell(5, 3).Range.Text
            stReviewCode2 = .cell(14, 3).Range.Text
            stReviewCode3 = .cell(23, 3).Range.Text
        End With
        SubmittalReviewCode = RegExData(stReviewCode1, "[a-zA-Z]+") & ", " & RegExData(stReviewCode2, "[a-zA-Z]+") & ", " & RegExData(stReviewCode3, "[a-zA-Z]+")
    End If
Error_Handler_Exit:
    worddoc.Close False
    Set worddoc = Nothing
    If bAppAlreadyOpen = False Then WordApp.Quit
    Set WordApp = Nothing
    Exit Function

Error_Handler:
     MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
               "Error Number: " & Err.Number & vbCrLf & _
               "Error Source: PrintWordDoc" & vbCrLf & _
               "Error Description: " & Err.Description _
               , vbOKOnly + vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function

Function FileNameNoExt(strPath As String) As String
 'https://sqlaccxl.wordpress.com/2013/03/06/vba-function-to-extract-file-name-withwithout-file-extension-or-path-only/
    Dim strTemp As String
    strTemp = Mid$(strPath, InStrRev(strPath, "\") + 1)
    FileNameNoExt = Left$(strTemp, InStrRev(strTemp, ".") - 1)
End Function
 
'The following function returns the filename with the extension from the file's full path:
Function FileNameWithExt(strPath As String) As String
    FileNameWithExt = Mid$(strPath, InStrRev(strPath, "\") + 1)
End Function
 
'the following function will get the path only (i.e. the folder) from the file's full path:
Function FILEPATH(strPath As String) As String
    FILEPATH = Left$(strPath, InStrRev(strPath, "\"))
End Function

Public Function RegExData(txt As String, Optional pttrn As String) 'MyNumber(txt)
'https://www.experts-exchange.com/questions/26503365/Regular-Expression-to-extract-decimal-number-from-text-string.html
'Keeps only the pattern from the string
'20180823
    Dim regEx As Object, myMatch As Variant

    Set regEx = CreateObject("vbscript.regexp")
    On Error GoTo notFound
    If regEx.Test(txt) = True Then
        With regEx
            .IgnoreCase = True
            .Multiline = False
            .Global = True
            '.Pattern = "\d+\.?\d*"

            'Match 3 digits; a dash; 3 digits; and an optional non space character
            '[0-9]{3}-[0-9]{3}\S?
            'Input: 2018.02.20 Pay App 903-014 Feb 2018.pdf
            'Result:903-014

            'Input: 2018.02.20 Pay App 903-014A Feb 2018.pdf
            'Result:903-014A
            If Len(pttrn) = 0 Then
                .Pattern = "[0-9]{3}-[0-9]{3}[a-zA-Z]?"
            Else
                .Pattern = pttrn
            End If
        End With

    Set myMatch = regEx.Execute(txt)
        RegExData = myMatch(0)
    End If
    Exit Function
notFound:
    RegExData = "Not Found"
    
End Function