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