fb:porticula NoPaste

Info / Hilfe Liste
Übersicht / Liste Neu
Datei hochladen Suche
Quellcode suchen
Dateidownload
Screenshoot- Programm, das keine Screenshoots erstellt

Uploader:	raph ael
Datum/Zeit:	02.01.2009 18:01:29
#Include "windows.bi"

#Include "crt/string.bi"



Const BITSPIXEL = 12

Const RET_NOPE As Byte    = 0

Const RET_BUF As Byte     = 1

Const RET_BUF_BMP As Byte = 2

Const RET_FILE As Byte    = 4



Declare Function screenshoot(outpath As String = "", retmeth As Byte = RET_NOPE) As Any Ptr

Declare Sub Get24BitBmp(w As Integer, h As Integer, hbitmap As HBITMAP, lpdestbits As Byte Ptr)

Declare Function SaveBmpToBuf(w As Integer, h As Integer, bpp As Byte, src As Byte Ptr) As Byte Ptr



'Teilweise abgeänderter Code von

'http://www.codeguru.com/cpp/g-m/gdi/capturingimages/article.php/c11231/

Function screenshoot(outpath As String = "", retmeth As Byte = RET_NOPE) As Any Ptr

    Dim rc As RECT, hwnd As HWND

    Dim As Integer w, h, bpp, size

    Dim As HDC hdc, memdc

    Dim As HBITMAP membm, oldbm, hbmp

    Dim As Byte Ptr lpbits1, lpbits2



    hwnd = GetDesktopWindow

    GetWindowRect(hwnd, @rc)

    w = rc.right - rc.left

    h = rc.bottom - rc.top

    hdc = GetDC(0)

    memdc = CreateCompatibleDC(hdc)

    membm = CreateCompatibleBitmap(hdc, w, h)

    oldbm = Cast(HBITMAP, SelectObject(memdc, membm))

    BitBlt(memdc, 0, 0, w, h, hdc, rc.left, rc.top, SRCCOPY)

    bpp = GetDeviceCaps(hdc, BITSPIXEL)

    size = bpp/8 * w * h

    lpbits1 = Allocate(size)

    GetBitmapBits(membm, size, lpbits1)

    hbmp = CreateBitmap(w, h, 1, bpp, lpbits1)

    lpbits2 = Allocate(w*h*3)

    Get24BitBmp(w, h, hbmp, lpbits2)



    Function = Cast(Any Ptr, 1)

    If retmeth = RET_FILE Then

        lpbits2 = SaveBmpToBuf(w, h, 24, lpbits2)

        Dim x As Integer = FreeFile

        Open outpath For Binary As #x

        For i As Integer = 0 To w*h*bpp/8-1

            Put #x,, lpbits2[i]

        Next

        Close #x

    EndIf



    If retmeth And RET_BUF Then

        Function = lpbits2

    EndIf



    If retmeth And RET_BUF_BMP Then

        lpbits2 = SaveBmpToBuf(w, h, 24, lpbits2)

        Function = lpbits2

    EndIf



    DeAllocate(lpbits1)

    If Not ((retmeth And RET_BUF) Or (retmeth And RET_BUF_BMP)) Then

        DeAllocate(lpbits2)

    EndIf

    SelectObject(hdc, oldbm)

    DeleteObject(membm)

    DeleteObject(hbmp)

    DeleteDC(memdc)

    ReleaseDC(0, hdc)

End Function



Sub Get24BitBmp(w As Integer, h As Integer, hbitmap As HBITMAP, lpdestbits As Byte Ptr)

    Dim As hdc hdc, mdc1, mdc2

    Dim As HBITMAP hdibmembm, holdbmp1, holdbmp2

    Dim lpbits As Byte Ptr, bmi As BITMAPINFO



    hdc = GetDC(0)

    mdc1 = CreateCompatibleDC(hdc)

    mdc2 = CreateCompatibleDC(hdc)

    With bmi.bmiHeader

        .biSize        = SizeOf(BITMAPINFOHEADER)

        .biWidth       = w

        .biHeight      = h

        .biPlanes      = 1

        .biBitCount    = 24

        .biCompression = BI_RGB

    End With

    hdibmembm = CreateDIBSection(0, @bmi, DIB_RGB_COLORS, @lpbits, NULL, NULL)

    holdbmp1 = SelectObject(mdc1, hdibmembm)

    holdbmp2 = SelectObject(mdc2, hbitmap)

    BitBlt(mdc1, 0, 0, w, h, mdc2, 0, 0, SRCCOPY)



    For i As Integer = 0 To h - 1

        CopyMemory(@lpdestbits[i*3*w], @lpbits[w*3*(h-1-i)], w*3)

    Next



    SelectObject(mdc1, holdbmp1)

    SelectObject(mdc2, holdbmp2)

    ReleaseDC(0, hdc)

    DeleteObject(hdibmembm)

    DeleteObject(holdbmp1)

    DeleteObject(holdbmp2)

    DeleteDC(mdc1)

    DeleteDC(mdc2)

End Sub



Function SaveBmpToBuf(w As Integer, h As Integer, bpp As Byte, src As Byte Ptr) As Byte Ptr

    Dim bmi As BITMAPINFO, bmf As BITMAPFILEHEADER, estsize As UInteger

    Dim buffer As Byte Ptr

    Dim As Integer nh, nw

    estsize = SizeOf(bmi) + SizeOf(bmf) + w*h*bpp/8

    With bmi.bmiHeader

        .biSize        = SizeOf(BITMAPINFOHEADER)

        .biWidth       = w

        .biHeight      = h

        .biPlanes      = 1

        .biBitCount    = bpp

        .biCompression = BI_RGB

        .biSizeImage   = w*h*bpp/8

    End With

    With bmf

        .bfType =19778

        .bfOffBits = SizeOf(bmi)+SizeOf(BITMAPFILEHEADER)

        .bfSize = estsize

    End With

    nw = bmi.bmiHeader.biWidth

    nh = bmi.bmiHeader.biHeight

    bmi.bmiHeader.biWidth = nw

    bmi.bmiHeader.biHeight = -nh

    buffer = Allocate(estsize)

    memcpy(buffer, @bmf, SizeOf(bmf))

    memcpy(buffer + SizeOf(bmf)+1, @bmi, SizeOf(bmi))

    memcpy(buffer + SizeOf(bmf)+SizeOf(bmi)+1, src, w*h*bpp/8)

    Return buffer

End Function



'----

screenshoot("test.bmp", RET_FILE)