VBA Take a Screenshot of a PDF and Paste into Workbook

Video:

Tools — References in VBE:

Code:

Private Declare PtrSafe Sub mouse_event Lib "user32" (ByVal dwflags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwextrainfo As Long)
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long

 Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" _
            (ByVal vKey As Long) As Integer
            
Private Const VK_LBUTTON = &H1
Private Const VK_F9 = &H78
Private Const keyeventf_keyup = 2

Public Declare PtrSafe Sub keybd_event Lib "user32" (ByVal BYK As Byte, ByVal bscan As Byte, dwflags As Long, ByVal dwextrainfo As Long)

Const MOUSEEVENTF_LEFTDOWN = &H2
Const MOUSEEVENTF_LEFTUP = &H4
Const MOUSEEVENTF_MIDDLEDOWN = &H20
Const MOUSEEVENTF_MIDDLEUP = &H40
Const MOUSEEVENTF_MOVE = &H1
Const MOUSEEVENTF_ABSOLUTE = &H8000
Const MOUSEEVENTF_RIGHTDOWN = &H8
Const MOUSEEVENTF_RIGHTUP = &H10

Private Type POINTAPI
X As Long
Y As Long
End Type


Sub FolderAndFileMacro()

Dim Point As POINTAPI
Dim Text As String


Dim mypath As String
Dim myfile As String
Dim myfile2
Dim myextension As String
Dim wb As Workbook
Dim FldrPicker As FileDialog


Dim xx As Double

 Dim oFSO As Object
 Dim folder As Object
 Dim subfolders As Object
 
 Set oFSO = CreateObject("Scripting.FileSystemObject")
 Set folder = oFSO.GetFolder("C:\Users\18622\OneDrive\Desktop\auto-read\")
 Set subfolders = folder.subfolders
 xx = subfolders.Count
 
 Set oFSO = Nothing
 Set folder = Nothing
 Set subfolders = Nothing
 'release memory

Dim X As Double

X = 1

Do Until X > xx






mypath = "C:\Users\18622\OneDrive\Desktop\auto-read\" & X & "\"

'pull file names from Module 2 called GrabFilenamesfromFolder. It pulls the file names from the folder you select and set to mypath variable.
GrabFilenamesfromFolder (mypath)


erow = Range("A" & Rows.Count).End(xlUp).Row
Range("B1").Select
ActiveCell.FormulaR1C1 = "=SEARCH(""*5*.pdf"",RC[-1],1)"
Range("B1").Select
Selection.AutoFill Destination:=Range("B1" & ":" & "B" & erow), Type:=xlFillDefault
Columns("B").Select
Selection.Copy
Columns("B").Select
Selection.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=False
 Columns("B").Select

 Selection.Replace What:="#VALUE!", Replacement:="0", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
Dim counter As Double
counter = 1
      


'Target File Extension (must include wildcard "*")


'Loop through each Excel file in folder
Do Until counter > erow
line15:
If Range("B" & counter).Value <> 0 Then
myfile2 = Range("A" & counter).Value
counter = counter + 1
GoTo line11:
End If
counter = counter + 1
Loop
line11:
'Set variable equal to opened workbook


Dim objIE As Object
  
  
Dim nextrow As Integer

If myfile2 = "" Then
GoTo line33:
End If

Set objIE = CreateObject("InternetExplorer.Application")





  With objIE
   .Top = 0
    .Left = 0
.Height = 1000
.Width = 1000
    .Navigate mypath & myfile2

  End With
  Application.Wait (Now + TimeValue("00:00:01"))

SetCursorPos 200, 200 'x and y position
Application.Wait (Now + TimeValue("00:00:01"))
mouse_event MOUSEEVENTF_LEFTDOWN, 0&, 0&, 0&, 0&
mouse_event MOUSEEVENTF_LEFTUP, 0&, 0&, 0&, 0&
Application.Wait (Now + TimeValue("00:00:01"))

Application.SendKeys "(%{1068})"


'Set Keys = CreateObject("WScript.Shell")

'Keys.SendKeys ("^{Esc}+s")
  

'Call Shell("TaskKill /F /PID " & CStr(objIE), vbHide)



 Dim objWMI As Object, objProcess As Object, objProcesses As Object
   Set objWMI = GetObject("winmgmts://.")
    Set objProcesses = objWMI.ExecQuery( _
        "SELECT * FROM Win32_Process WHERE Name = 'iexplore.exe'")
    For Each objProcess In objProcesses
        Call objProcess.Terminate
        On Error GoTo ErrorHandler

    Next
    
ErrorHandler:
    Set objProcesses = Nothing: Set objWMI = Nothing




 'add actions to do to this workbook
      
'switch back to workbook that has this macro
Workbooks("PDF SCREENS.xlsm").Activate
'close myfile
Range("z1").Select
ActiveSheet.Paste

Range("P" & X).Value = InputBox("What category is it?")

line33:

Workbooks("PDF SCREENS.xlsm").Activate
Columns("A:B").Select
Selection.ClearContents
X = X + 1
Loop

End Sub

Sub GrabFilenamesfromFolder(path As String)
    Dim currentPath As String, directory As Variant
    Dim dirCollection As Collection
    Set dirCollection = New Collection
    Dim counter As Double
    counter = 1
    currentPath = Dir(path, vbDirectory)
    
    'Explore current directory
    Do Until currentPath = vbNullString
        Debug.Print currentPath
        'If Left(currentPath, 1) <> "." And _
            '(GetAttr(path & currentPath) And vbDirectory) = vbDirectory Then
            dirCollection.Add currentPath
        'End If
        currentPath = Dir()
        Range("A" & counter).Value = currentPath
        counter = counter + 1
    Loop
    
   
End Sub