Can't find anything out there on this.

I want to write code that basically does the equivalent of pressing Alt+PrintScreen (screenshot of the active window) and then saving it to an image file (preferrable jpg or bitmap, but I don't really care). Anyone know how to do this?

(I need to code it rather than do it manually because the frame will be changing and I will be producing around thirty images per execution.)

4/5/2007 2:53:45 PM

hahah, are you kidding?

4/5/2007 3:09:00 PM

^ wha?

4/5/2007 4:11:16 PM

i've already done this. stand by for a long post as soon as i find my code.

'############################################################
'##                                                        ##
'##                      Bitmap Types                      ##
'##                                                        ##
'############################################################
Public Type BITMAPFILEHEADER
    bfType As Integer
    bfSize As Long
    bfReserved1 As Integer
    bfReserved2 As Integer
    bfOffBits As Long
End Type
Public Type BITMAPINFOHEADER '40 bytes
        biSize As Long
        biWidth As Long
        biHeight As Long
        biPlanes As Integer
        biBitCount As Integer
        biCompression As Long
        biSizeImage As Long
        biXPelsPerMeter As Long
        biYPelsPerMeter As Long
        biClrUsed As Long
        biClrImportant As Long
End Type
Public Type RGBQUAD
        rgbBlue As Byte
        rgbGreen As Byte
        rgbRed As Byte
        rgbReserved As Byte
End Type
Public Type BITMAPINFO
        bmiHeader As BITMAPINFOHEADER
        bmiColors As RGBQUAD
End Type


Public Enum ScreenShots
    WholeScreen = 0
    ActiveWindow = 1
    TopWindow = 2
End Enum

Public Sub TakeScreenshot(FileName As String, Optional Window As ScreenShots = 0, Optional Width = -1, Optional Height = -1)
    
    Dim OutputX As Integer, OutputY As Integer, T As RECT
    Dim bi24BitInfo As BITMAPINFO, bmh As BITMAPFILEHEADER
    Dim OldDC As Long, newDC As Long, dtopdc As Long
    Dim bhwnd As Long, dtop As Long, pixels() As Byte
    If Window = WholeScreen Then
        dtop = GetDesktopWindow
    ElseIf Window = ActiveWindow Then
        dtop = GetActiveWindow
    ElseIf Window = TopWindow Then
        dtop = GetTopWindow(GetDesktopWindow)
    End If
    dtopdc = GetWindowDC(dtop)
    
    If Width = -1 Then
        GetWindowRect dtop, T
        OutputX = T.Right - T.Left
        OutputY = T.Bottom - T.Top
    Else
        OutputX = Width
        OutputY = Height
    End If
    
    With bmh
        .bfType = 19778
        .bfReserved1 = 0
        .bfReserved2 = 0
    End With
    With bi24BitInfo.bmiHeader
        .biBitCount = 24
        .biCompression = BI_RGB
        .biPlanes = 1
        .biSize = Len(bi24BitInfo.bmiHeader)
        .biWidth = OutputX
        .biHeight = OutputY
    End With
    bmh.bfOffBits = Len(bmh) + Len(bi24BitInfo)
    
    newDC = CreateCompatibleDC(0)
    bhwnd = CreateDIBSection(newDC, bi24BitInfo, DIB_RGB_COLORS, ByVal 0&, ByVal 0&, ByVal 0&)
    OldDC = SelectObject(newDC, bhwnd)
    
    
    StretchBlt newDC, 0, 0, bi24BitInfo.bmiHeader.biWidth, bi24BitInfo.bmiHeader.biHeight, dtopdc, 0, 0, T.Right - T.Left, T.Bottom - T.Top, vbSrcCopy
    
    ReDim pixels(1 To bi24BitInfo.bmiHeader.biWidth * bi24BitInfo.bmiHeader.biHeight * 3)
    GetDIBits newDC, bhwnd, 0, bi24BitInfo.bmiHeader.biHeight, pixels(1), bi24BitInfo, DIB_RGB_COLORS
    
    bmh.bfSize = bi24BitInfo.bmiHeader.biSizeImage
    
    Open FileName For Binary Access Write As #1
    
        Put #1, 1, bmh
        Put #1, , bi24BitInfo
        Put #1, , pixels
    
    Close #1
    
    SelectObject OldDC, bhwnd
    
    DeleteObject newDC
    DeleteObject bhwnd

    Erase pixels
End Sub

'Windows
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function GetTopWindow Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long

'Getting and Setting Device Contexts
Private Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long

'Working with bitmap images
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hDC As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, ByVal lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long

'Timer
Private Declare Function timeKillEvent Lib "winmm.dll" (ByVal uId As Long) As Long
Private Declare Function timeSetEvent Lib "winmm.dll" (ByVal uDelay As Long, ByVal uResolution As Long, ByVal lpFunction As Long, ByVal dwUser As Long, ByVal uFlags As Long) As Long

'Hotkeys
Private Declare Function RegisterHotKey Lib "user32" (ByVal hWnd As Long, ByVal id As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long
Public Declare Function UnregisterHotKey Lib "user32" (ByVal hWnd As Long, ByVal id As Long) As Long
Public Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As Msg, ByVal hWnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
Public Declare Function WaitMessage Lib "user32" () As Long

'System functions
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As RECT, ByVal fuWinIni As Long) As Long
Private Declare Function SystemParametersInfo2 Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As String, ByVal fuWinIni As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

4/5/2007 11:26:57 PM

^ Awesome! Thanks, will give it a try as soon as I get chance.

4/6/2007 8:40:15 AM

Hmm missing types "RECT" and "Msg"

Msg doesn't matter, I defined RECT as

Public Type RECT
Top as long
Bottom as long
Right as long
Left as long
End Type


It runs, but produces a bitmap that is -1600 x 1200 and fails to draw.

[Edited on April 6, 2007 at 10:42 AM. Reason : ]

4/6/2007 10:28:36 AM

Well for some reason it doesn't run any more, and I get a "subscript out of range" error on this line:

ReDim pixels(1 To bi24BitInfo.bmiHeader.biWidth * bi24BitInfo.bmiHeader.biHeight * 3)


...I assume everything you posted is supposed to go in one module, yes?

[Edited on April 6, 2007 at 11:06 AM. Reason : ]

4/6/2007 11:03:32 AM

Neva mind. Found a much easier way to do it. Just for the record, a simple form with two buttons on it:





Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Private Sub Command1_Click()

Const VK_SNAPSHOT As Byte = &H2C

Call keybd_event(VK_SNAPSHOT, 1, 0, 0)

End Sub

Private Sub Command2_Click()
Dim objPic As IPictureDisp

If Clipboard.GetFormat(vbCFBitmap) Then
Set objPic = Clipboard.GetData(vbCFBitmap)
SavePicture objPic, "test.bmp"
End If
End Sub




Command1 copies to clipboard, command2 saves clipboard to file. Thanks again!

4/6/2007 11:19:51 AM

Hey, sorry I haven't been online and sorry for the only semi-working code. I pulled it from a much bigger application with quite a bit of code. The reason it's messed up is I forgot to provide the constants. If you still want them, shoot me a PM. I'll send the whole application if you want. It's maybe 10,000 lines, you might learn something from it.

4/6/2007 2:36:45 PM