Option Explicit
'
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassname As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
'
Private Const WM_CLOSE As Integer = &H10
'-----------------------
'Returns a PDF file text
'-----------------------
Function GetPDFText(FichierPDF As String) As String
Dim Clipboard As New MSForms.DataObject 'Reference Microsoft Forms 2.0 Object Library (or add and delete a USerForm)
Dim ChromeExe As String
Dim NomPDF As String
Dim hWnd As LongPtr
'
Const Chrome64 = "C:\Program Files\Google\Chrome\Application\chrome.exe"
Const Chrome32 = "C:\Program Files (x86)\Google\Chrome\Application\chrome.exe"
Const SleepTime = 500
'Check file
If Len(Dir(FichierPDF)) = 0 Then
MsgBox "Fichier <" & FichierPDF & "> non trouvé !"
Exit Function
End If
'Check Chrome
If Len(Dir(Chrome64)) > 0 Then
ChromeExe = Chrome64
ElseIf Len(Dir(Chrome32)) > 0 Then
ChromeExe = Chrome32
Else
MsgBox "Chrome.exe non trouvé !"
Exit Function
End If
'PDF file name
NomPDF = Mid(FichierPDF, InStrRev(FichierPDF, "\") + 1)
'Empty the Clipboard
With Clipboard
.SetText ""
.PutInClipboard
End With
'Kill possible existing Windows
Do While 1
hWnd = FindWindow(vbNullString, NomPDF & " - Google Chrome")
If Not hWnd = 0 Then
Call SendMessage(hWnd, WM_CLOSE, 0, 0)
DoEvents
Else
Exit Do
End If
Loop
'Run Chrome and wait for the Window to be ready
Call Shell(ChromeExe & " --new-window -url " & """" & FichierPDF & """", vbNormalFocus)
Do While hWnd = 0
hWnd = FindWindow(vbNullString, NomPDF & " - Google Chrome")
Temporisation 1000
Loop
Sleep SleepTime
'Send keys to Select All / Copy / Kill the application
Call SendKeysSelectCopyClose
'Get Clipboard data
With Clipboard
.GetFromClipboard
On Error Resume Next
GetPDFText = .GetText
On Error GoTo 0
End With
End Function
'----------------------------
'Envoi des touches sur Chrome
'----------------------------
Private Sub SendKeysSelectCopyClose()
Const Tempo = 1000
SendKeybd "A", "ctrl" 'Touche Ctrl A
Temporisation Tempo
SendKeybd &H9 'Touche TAB
Temporisation Tempo
SendKeybd "C", "ctrl" 'Touche CTRL C
Temporisation Tempo
SendKeybd &H73, "alt" 'Touche ALT F4
End Sub
'--------------------------------------------
'Wrap keybd_event
'Alter = "down", "up", "shift", "ctrl", "alt"
'E.g. SendKeybd &H43, "ctrl" 'Send Ctrl C
'https://learn.microsoft.com/en-us/windows/win32/inputdev/virtual-key-codes
'--------------------------------------------
Sub SendKeybd(ByVal Key As Variant, Optional ByVal Alter As String = "")
Dim AlterValue As Byte
If VarType(Key) = vbString Then Key = Asc(Key)
Select Case UCase(Alter)
Case "DOWN"
keybd_event Key, 1, 0, 0
Case "UP"
keybd_event Key, 0, 2, 0
Case "SHIFT"
AlterValue = &H10
GoSub AlterKey
Case "CTRL"
AlterValue = &H11
GoSub AlterKey
Case "ALT"
AlterValue = &H12
GoSub AlterKey
Case Else
GoSub DownUp
End Select
Exit Sub
AlterKey:
keybd_event AlterValue, 1, 0, 0
GoSub DownUp
keybd_event AlterValue, 0, 2, 0
Return
DownUp:
keybd_event Key, 1, 0, 0
keybd_event Key, 0, 2, 0
Return
End Sub
'-------------
'Temporisation
'-------------
Private Sub Temporisation(NbDoEvents As Integer)
Dim k As Integer
For k = 1 To NbDoEvents
DoEvents
Next k
End Sub
