fb:porticula NoPaste

Info / Hilfe Liste
Übersicht / Liste Neu
Datei hochladen Suche
Quellcode suchen
Dateidownload
Screenshoot- Programm; NEU! Jetzt auch MIT SCREENSHOOTS!

Uploader:	raph ael
Datum/Zeit:	02.01.2009 21:28:40
'------------------------------------------------------------------------------

'Aufruf: screenshoot(dateiname, speicheroptionen) [byte ptr]

'dateiname[string]: Dateiname zum Speichern

'speicheroptionen[byte]: * RET_FILE: Am Sinnvollsten. Speichert den Screenshoot

'                          in der angegebenen Datei. Der Rückgabewert der

'                          Funktion sollte 1 sein.

'                        * RET_BUF: Gibt die Pixeldaten zurück.

'                        * RET_BUF_BMP: Gibt die Bitmap zurück, ohne sie zu

'                          speichern.

'                        * RET_NOPE: "Verschwende-unnötig-CPU-und-RAM"-Modus

'------------------------------------------------------------------------------

'(c) 2009 by Raphael R.

'Fragen+Feedback: raphaelr@f-m.fm



#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, ByRef outsize As Integer) As Byte Ptr



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

        Dim topcount As Integer

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

        Dim x As Integer = FreeFile

        Open outpath For Binary As #x

        For i As Integer = 0 To topcount-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, 0)

        Function = lpbits2

    EndIf



    DeAllocate(lpbits1)

    If Not (retmeth And RET_BUF) 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, ByRef outsize As Integer) As Byte Ptr

    Dim bmi As BITMAPINFOHEADER, bmf As BITMAPFILEHEADER

    Dim buffer As Byte Ptr



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

    With bmi

        .biSize        = SizeOf(bmi)

        .biWidth       = w

        .biHeight      = -h

        .biPlanes      = 1

        .biBitCount    = bpp

        .biCompression = BI_RGB

        .biSizeImage   = 0

    End With

    With bmf

        .bfType = 19778

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

        .bfSize = outsize

    End With



    buffer = Allocate(outsize)

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

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

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

    Return buffer

End Function