Option Compare Database
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
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 GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal Hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, _
RefIID As Guid, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Const VK_MENU = &H12
Private Const VK_SNAPSHOT = &H2C
Private Const KEYEVENTF_KEYUP = &H2
Private Const CF_BITMAP = 2
Private Type PicBmp
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type
Private Type Guid
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Public strFormName As String

Public Function SaveBitmap()
Dim Pic As PicBmp, IPic As IPicture, IID_IDispatch As Guid, strFileName As String
Dim theCnt As Integer, theMsg As String
theCnt = 0
strFileName = "C:\Test.bmp" ' Set the filename variable.
startOver:
theCnt = theCnt + 1
keybd_event VK_MENU, 0, 0, 0                    'press Alt
keybd_event VK_SNAPSHOT, 0, 0, 0                'press PrintScrn
keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0  'release it
keybd_event VK_MENU, 0, KEYEVENTF_KEYUP, 0      'release it
DoEvents
With IID_IDispatch
    .Data1 = &H20400
    .Data4(0) = &HC0
    .Data4(7) = &H46
End With
With Pic
Call OpenClipboard(0&)
    .Size = Len(Pic)
    .Type = 1
    .hBmp = GetClipboardData(CF_BITMAP)
End With
OleCreatePictureIndirect Pic, IID_IDispatch, 1, IPic ' Create the picture object
If theCnt = 1 Then
'    theMsg = MsgBox("Click ok to save the file.", vbOKOnly + vbInformation)
    DoEvents
'    If theMsg = 1 Then GoTo startOver
End If
On Error GoTo errorEncountered
stdole.SavePicture IPic, strFileName ' Save the file
errorEncountered:
If Err.Number <> 0 Then
MsgBox " Error# " & Err & " " & """" & Err.Description & """"
End If
Call EmptyClipboard ' Empty the clipboard
Call CloseClipboard ' Close the clipboard
End Function