Открыть PDF-файл и скопировать путь к файлу и распечатать страницы VBA

Question

В настоящее время у меня есть макрос, который просматривает список и находит файлы PDF на основе ключевых слов. Макрос работает так, как должен, но я бы хотел пойти немного дальше. Макрос ищет правильный PDF-файл на основе номера отчета на элемент.

Я хотел бы l oop и:

1. Гиперссылка на файл в столбце "M".

2. Проверьте правильность открытия файла и поместите статус в столбец «K»

3. Сверните все открытые PDF windows.

4. Если возможно найдите номер товара в PDF и соответствующую ему страницу. Каждая страница также помечена номером позиции, чтобы ее можно было искать таким же образом. Я хотел бы как-то напечатать правильные страницы.

Существуют сотни отчетов, и это очень утомительный процесс. У меня также есть Adobe Pro. Я открыт для всех предложений.

Текущий рабочий код для поиска PDF на основе подстановочного знака:

`Sub Open_PDF()
Dim filePath As String, fileName As String, iName As String
Dim lrow As Long
Dim i As Long

lrow = Cells(Rows.Count, 10).End(xlUp).Row
For i = 5 To lrow
iName = Cells(i, 10)
FileType = Range("FileType")

filePath = Range("B6")
fileName = Dir(filePath & iName & "*" & "." & FileType)
If fileName <> "" Then
    openAnyFile filePath & fileName
    End If
Next i

End Sub

Function openAnyFile(strPath As String)
Dim objShell As Object
Set objShell = CreateObject("Shell.Application")
objShell.Open (strPath)
End Function

`

Я нашел следующие коды, но не смог понять, как чтобы заставить его работать.

Option Explicit

'Retrieves a handle to the top-level window whose class name and window name match the 
specified strings.
'This function does not search child windows. This function does not perform a case- 
sensitive search.
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

`'Retrieves a handle to a window whose class name and window name match the specified 
strings.
'The function searches child windows, beginning with the one following the specified 
child window.
'This function does not perform a case-sensitive search.
Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long

'Brings the thread that created the specified window into the foreground and activates 
the window.
'Keyboard input is directed to the window, and various visual cues are changed for the 
user.
'The system assigns a slightly higher priority to the thread that created the 
foreground
'window than it does to other threads.
Public Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long

'Sends the specified message to a window or windows. The SendMessage function calls 
the window procedure
'for the specified window and does not lParenturn until the window procedure has 
processed the message.
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

'Places (posts) a message in the message queue associated with the thread that created 
the specified
'window and lParenturns without waiting for the thread to process the message.
Public Declare Function PostMessage Lib "user32.dll" Alias "PostMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long)  
As Long

'Constants used in API functions.
Public Const WM_SETTEXT = &HC
Public Const VK_RETURN = &HD
Public Const WM_KEYDOWN = &H100

Private Sub OpenPDF(strPDFPath As String, strPageNumber As String, strZoomValue As String)

'Opens a PDF file to a specific page and with a specific zoom
'using Adobe Reader Or Adobe Professional.
'API functions are used to specify the necessary windows
'and send the page and zoom info to the Adobe window.

'By Christos Samaras
'https://myengineeringworld.net/////

Dim strPDFName                  As String
Dim lParent                     As Long
Dim lFirstChildWindow           As Long
Dim lSecondChildFirstWindow     As Long
Dim lSecondChildSecondWindow    As Long
Dim dtStartTime               As Date

'Check if the PDF path is correct.
If FileExists(strPDFPath) = False Then
    MsgBox "The PDF path is incorect!", vbCritical, "Wrong path"
    Exit Sub
End If

'Get the PDF file name from the full path.
On Error Resume Next
strPDFName = Mid(strPDFPath, InStrRev(strPDFPath, "") + 1, Len(strPDFPath))
On Error GoTo 0

'The following line depends on the apllication you are using.
'For Word:
'ThisDocument.FollowHyperlink strPDFPath, NewWindow:=True
'For Power Point:
'ActivePresentation.FollowHyperlink strPDFPath, NewWindow:=True
'Note that both Word & Power Point pop up a security window asking
'for access to the specified PDf file.
'For Access:
'Application.FollowHyperlink strPDFPath, NewWindow:=True
'For Excel:
ThisWorkbook.FollowHyperlink strPDFPath, NewWindow:=True
'Find the handle of the main/parent window.
dtStartTime = Now()
Do Until Now() > dtStartTime + TimeValue("00:00:05")
    lParent = 0
    DoEvents
    'For Adobe Reader.
    'lParent = FindWindow("AcrobatSDIWindow", strPDFName & " - Adobe Reader")
    'For Adobe Professional.
    lParent = FindWindow("AcrobatSDIWindow", strPDFName & " - Adobe Acrobat Pro")
    If lParent <> 0 Then Exit Do
Loop

If lParent <> 0 Then

    'Bring parent window to the foreground (above other windows).
    SetForegroundWindow (lParent)

    'Find the handle of the first child window.
    dtStartTime = Now()
    Do Until Now() > dtStartTime + TimeValue("00:00:05")
        lFirstChildWindow = 0
        DoEvents
        lFirstChildWindow = FindWindowEx(lParent, ByVal 0&, vbNullString, "AVUICommandWidget")
        If lFirstChildWindow <> 0 Then Exit Do
    Loop

    'Find the handles of the two subsequent windows.
    If lFirstChildWindow <> 0 Then
        dtStartTime = Now()
        Do Until Now() > dtStartTime + TimeValue("00:00:05")
            lSecondChildFirstWindow = 0
            DoEvents
            lSecondChildFirstWindow = FindWindowEx(lFirstChildWindow, ByVal 0&, "Edit", vbNullString)
            If lSecondChildFirstWindow <> 0 Then Exit Do
        Loop

        If lSecondChildFirstWindow <> 0 Then

            'Send the zoom value to the corresponding window.
            SendMessage lSecondChildFirstWindow, WM_SETTEXT, 0&, ByVal strZoomValue
            PostMessage lSecondChildFirstWindow, WM_KEYDOWN, VK_RETURN, 0

            dtStartTime = Now()
            Do Until Now() > dtStartTime + TimeValue("00:00:05")
                lSecondChildSecondWindow = 0
                DoEvents
                'Notice the difference in syntax between lSecondChildSecondWindow and lSecondChildFirstWindow.
                'lSecondChildSecondWindow is the handle of the next child window after lSecondChildFirstWindow,
                'while both windows have as parent window the lFirstChildWindow.
                lSecondChildSecondWindow = FindWindowEx(lFirstChildWindow, lSecondChildFirstWindow, "Edit", vbNullString)
                If lSecondChildSecondWindow <> 0 Then Exit Do
            Loop
            If lSecondChildSecondWindow <> 0 Then

                'Send the page number to the corresponding window.
                SendMessage lSecondChildSecondWindow, WM_SETTEXT, 0&, ByVal strPageNumber
                PostMessage lSecondChildSecondWindow, WM_KEYDOWN, VK_RETURN, 0

            End If

        End If

    End If

End If

End Sub

Function FileExists(strFilePath As String) As Boolean

'Checks if a file exists.

'By Christos Samaras
'https://myengineeringworld.net/////

On Error Resume Next
If Not Dir(strFilePath, vbDirectory) = vbNullString Then FileExists = True
On Error GoTo 0

End Function

Sub TestPDF()

OpenPDF ThisWorkbook.Path & "" & "Sample File.pdf", 6, 143

End Sub

Answer 1

Обновление: я успешно нашел нужные мне коды. Я опубликую их здесь чуть позже, если они понадобятся кому-то еще. Мне нужна помощь с еще одной вещью. Следующий код ищет документ PDF и возвращает номер страницы. Он работает хорошо, за исключением того, что он открывает и закрывает PDF между каждым l oop. Я объединил все PDF в один и буду искать в одном PDF. Может ли кто-нибудь изменить это, чтобы открыть только один раз и закрыть в конце?

Sub FetchMultiplePDF()
Dim SearchResult As String
Dim i As Integer, weld As Integer, report As Integer
Dim search As String, iName As String, Filepath As String, FileName As String

weld = Range("Weld").Column
lrow = Cells(Rows.Count, weld).End(xlUp).Row
For i = 5 To lrow
search = Cells(i, weld)

FileType = Range("FileType")
report = Range("SearchFor").Column
iName = Cells(i, report)
Filepath = Range("File_Path")

FileName = (Filepath & iName & "." & FileType)

SearchResult = AdobePdfSearch(search, FileName)
Range("N" & i) = SearchResult
'MsgBox SearchResult

Next i
End Sub

Function AdobePdfSearch(SearchString As String, strFileName As String) As 
String
'Note: A Reference to the Adobe Library must be set in Tools|References!
'Note! This only works with Acrobat Pro installed on your PC, will not 
work with Reader
Dim AcroApp As CAcroApp, AcroAVDoc As CAcroAVDoc, AcroPDDoc As CAcroPDDoc
Dim AcroHiliteList As CAcroHiliteList, AcroTextSelect As CAcroPDTextSelect
Dim PageNumber, PageContent, Content, i, j, iNumPages
Dim strResult As String

Set AcroApp = CreateObject("AcroExch.App")
Set AcroAVDoc = CreateObject("AcroExch.AVDoc")
If AcroAVDoc.Open(strFileName, vbNull) <> True Then Exit Function

Set AcroPDDoc = AcroAVDoc.GetPDDoc
iNumPages = AcroPDDoc.GetNumPages
For i = 0 To iNumPages - 1

Set PageNumber = AcroPDDoc.AcquirePage(i)
Set PageContent = CreateObject("AcroExch.HiliteList")
If PageContent.Add(0, 9000) <> True Then Exit Function
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
    Content = Content & AcroTextSelect.GetText(j)
Next j
If InStr(1, LCase(Content), LCase(SearchString)) > 0 Then
    strResult = IIf(strResult = "", i + 1, strResult & "," & i + 1)
End If
Content = ""
Next i

AdobePdfSearch = strResult

'Uncomment the lines below if you want to close the PDF when done.
AcroAVDoc.Close True
AcroApp.Exit
End Function

Answer 2

Я могу вам частично помочь:

Sub Open_PDF()
    Dim filePath As String, fileName As String, iName, disptxt As String
    Dim lrow As Long
    Dim i As Long
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")

    lrow = Cells(Rows.Count, 10).End(xlUp).Row

    For i = 5 To lrow
        iName = Cells(i, 10)
        FileType = Range("FileType")
        filePath = Range("B6")
        fileName = Dir(filePath & iName & "*" & "." & FileType)

        If fileName <> "" Then
            disptxt = filePath & iName ' whatever you want the hyperlink to show
            ws.Hyperlinks.Add Anchor:=ws.Range("M" & i), Address:=filePath & fileName, ScreenTip:="hover message", TextToDisplay:=disptxt
            Range("K" & i) = "Success"
            openAnyFile filePath & fileName
        Else
            Range("K" & i) = "Failed"
        End If
    Next i
End Sub