VB6 - Automaticall save screenshot to MS Paint and save with a timestamp filename

[RobDog888]

Here is how to perform a screenshot and save it to Paint automatically
with a timestamp file name. I dont know if anyone find this useful,
but it shows the mechanics of automating a program on the same
calling thread.

Option Explicit
 
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, _
ByVal dwExtraInfo As Long)
 
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
 
Private Declare Function FindWindowEx Lib "user32.dll" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, _
ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
 
Private 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
 
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
 
Private Const WM_CLOSE As Long = &H10
Private Const WM_QUIT As Long = &H12
 
Private Const VK_SNAPSHOT As Byte = 44
Private Const VK_LCONTROL As Long = &HA2
Private Const VK_V = &H56
Private Const VK_F = &H46
Private Const VK_S = &H53
Private Const VK_MENU = &H12
Private Const KEYEVENTF_KEYUP = &H2
Private Const BM_CLICK As Long = &HF5
Private Const WM_SETTEXT As Long = &HC
 
Private Sub Command1_Click()
 
    Dim strFilePathName As String
    Dim lHwnd As Long
    Dim lHwndC As Long
    Dim lHwndC1 As Long
    Dim lHwndC2 As Long
    Dim dDelay As Date
    Dim sFileName As String
    
    Clipboard.Clear
    DoEvents
    Call keybd_event(VK_SNAPSHOT, 0, 0, 0)
    DoEvents
    'PATH DEPENDS UPON OS (WIN2K AND BELOW - XP = C:\Windows\System32\mspaint.exe)
    strFilePathName = "C:\Winnt\System32\mspaint.exe"
    Shell strFilePathName, vbNormalFocus
    lHwnd = 0
    lHwndC = 0
    'WAIT FOR PAINT TO STARTUP
    Do Until lHwnd <> 0
        DoEvents
        lHwnd = FindWindow("MSPaintApp", "untitled - Paint")
    Loop
    keybd_event VK_LCONTROL, 0, 0, 0  'PRESS CTL
    keybd_event VK_V, 0, 0, 0  'PRESS V
    keybd_event VK_V, 0, KEYEVENTF_KEYUP, 0  'RELEASE V
    keybd_event VK_LCONTROL, 0, KEYEVENTF_KEYUP, 0  'RELEASE CTL
    
    'WAIT FOR PROMPT TO ASK TO ENLARGE CANVAS (WIN2K AND BELOW ONLY)
    lHwnd = 0
    lHwndC = 0
    Do Until lHwnd <> 0
        DoEvents
        lHwnd = FindWindow("#32770", "Paint")
    Loop
    lHwndC = FindWindowEx(lHwnd, 0&, "BUTTON", "&Yes")
    SendMessage lHwndC, BM_CLICK, 0&, 0&
    'WAIT FOR MESSAGEBOX TO CLOSE
    Do Until lHwnd = 0
        DoEvents
        lHwnd = FindWindow("#32770", "Paint")
    Loop
    '/WAIT FOR PROMPT TO ASK TO ENLARGE CANVAS (WIN2K AND BELOW ONLY)
    
    'SAVE FILE
    keybd_event VK_MENU, 0, 0, 0  'PRESS ATL
    keybd_event VK_F, 0, 0, 0  'PRESS F
    keybd_event VK_F, 0, KEYEVENTF_KEYUP, 0  'RELEASE V
    keybd_event VK_MENU, 0, KEYEVENTF_KEYUP, 0  'RELEASE ATL
    keybd_event VK_S, 0, 0, 0  'PRESS S
    keybd_event VK_S, 0, KEYEVENTF_KEYUP, 0  'RELEASE S
    'ENTER FILENAME TO SAVE AS
    lHwnd = 0
    lHwndC = 0
    Do Until lHwnd <> 0
        DoEvents
        lHwnd = FindWindow("#32770", "Save As")
    Loop
    lHwndC = FindWindowEx(lHwnd, 0&, "COMBOBOXEX32", vbNullString)
    Do Until lHwndC <> 0
        lHwndC = FindWindowEx(lHwnd, 0&, "COMBOBOXEX32", vbNullString)
    Loop
    lHwndC1 = FindWindowEx(lHwndC, 0&, "COMBOBOX", vbNullString)
    Do Until lHwndC1 <> 0
        lHwndC1 = FindWindowEx(lHwndC, 0&, "COMBOBOX", vbNullString)
    Loop
    lHwndC2 = FindWindowEx(lHwndC1, 0&, "EDIT", vbNullString)
    Do Until lHwndC2 <> 0
        lHwndC2 = FindWindowEx(lHwndC1, 0&, "EDIT", vbNullString)
    Loop
    'FORMAT A UNIQUE FILENAME TO AVOID THE OVERWRITE PROMPT MESSAGE
    sFileName = "Screenshot_" & Format(Now, "MM-DD-YYYY_HH-MM-SS_AMPM") & ".bmp"
    'ONE SECOND DELAY TO ALLOW PROCESSING
    dDelay = Now
    Do While DateDiff("s", dDelay, Now) < 1
        DoEvents
    Loop
    'ENTER THE FILENAME TEXT INTO THE COMBO BOX
    SendMessage lHwndC, WM_SETTEXT, 0&, ByVal sFileName
    'ONE SECOND DELAY TO ALLOW SENDMESSAGE PROCESSING
    dDelay = Now
    Do While DateDiff("s", dDelay, Now) < 1
        DoEvents
    Loop
    lHwndC = FindWindowEx(lHwnd, 0&, "BUTTON", "&Save")
    'CLICK THE SAVE BUTTON
    SendMessage lHwndC, BM_CLICK, 0&, 0&
    'ONE SECOND DELAY TO ALLOW SENDMESSAGE PROCESSING
    dDelay = Now
    Do While DateDiff("s", dDelay, Now) < 1
        DoEvents
    Loop
    'WAIT FOR PAINT TO SAVE AND GET NEW HANDEL
    lHwnd = 0
    Do Until lHwnd <> 0
        DoEvents
        lHwnd = FindWindow("MSPaintApp", sFileName & " - Paint")
    Loop
    'QUIT PAINT
    PostMessage lHwnd, WM_QUIT, 0&, 0&
    
End Sub

VB/Outlook Guru