******************************************************************************
******************************************************************************
*** ***
*** Copyright (c) 1995 - 2002 by -=Assarbad [GoP]=- ***
*** Portions Copyright (c) 1991 -2000 by Microsoft Corp. ***
*** ____________ ___________ ***
*** /\ ________\ /\ _____ \ UIN: 281645 ***
*** / \ \ / __________/ \ \ \ \ AIM: nixlosheute ***
*** \ \ \ __/___ /\ _____ \ \ \____\ \ nixahnungnicht ***
*** \ \ \ /\___ \ \ \ \ \ \ _______\ ***
*** \ \ \ / \ \ \ \ \ \ \ \ / Assarbad@gmx.info ***
*** \ \ \_____\ \ \ \____\ \ \ \____/ ***
*** \ \___________\ \__________\ \__\ ***
*** \ / / / / / / ***
*** \/___________/ \/__________/ \/__/ ***
*** ***
*** May the source be
with you, stranger ... ;) ***
*** Snizhok, eto ne tolko fruktovij kefir, snizhok, eto stil zhizn. ***
*** Privet iz Germanij ***
*** ***
*** Greets from -=Assarbad=- fly
to YOU =) ***
*** Special greets fly 2 Nico, Casper, SA, Pizza, Navarion, Eugen, Zhenja, ***
*** Xandros, Melkij, Strelok etc pp. ***
*** ***
*** Thanks
to: ***
*** W.A. Mozart, Vivaldi, Beethoven, Poeta Magica, Kurtzweyl, Manowar, ***
*** Blind Guardian, Weltenbrand,
In Extremo, Wolfsheim, Carl Orff, Zemfira ***
*** ... most
of my work was done
with their music
in the background ;) ***
*** ***
*** [
for questions/proposals drop me a mail] ***
***********************************************************
ASCII by Assa ****
******************************************************************************)
{~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
_\\|//_
(` * * ')
______________________________ooO_(_)_Ooo_____________________________________
LEGAL STUFF:
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Copyright (c) 1995-2002, -=Assarbad=- ["copyright holder(s)"]
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
1. Redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
3. The name(s) of the copyright holder(s) may not be used to endorse or
promote products derived from this software without specific prior written
permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY
DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
.oooO Oooo.
____________________________( )_____( )___________________________________
\ ( ) /
\_) (_/
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~}
(******************************************************************************
Version History:
----------------
v.1.1 [30.10.2002]
- added to lower level functions that split the functionality of the function
ScreenShotThis() into two parts.
-> ScreenShotThisInit()
-> ScreenShotThisFinit()
v.1.0 [14.10.2002]
- Initial release. This is roughly speaking a conversion of big parts of an
example from the August 2002 PSDK. Since writing BMP is very tricky (mostly
because of the bit depth below 16), this was the easiest to do.
******************************************************************************)
unit ScreenShot;
interface
uses Windows;
{$INCLUDE .\Include\CompilerSwitches.Pas}
{$IFNDEF DELPHI4UP}
{$INCLUDE .\Include\Delphi3compat.pas}
{$ENDIF}
type
LPSTR = PChar;
const
PALVERSION = $300;
//* Print Area selection */
PW_WINDOW = 1;
PW_CLIENT = 2;
const
// Dib Header Marker - used in writing DIBs to files
DIB_HEADER_MARKER = (ord('
M')
shl 8)
or ord('
B');
//------------------------------------------------------------------------------
function ScreenShotThis(hwnd: HWND; fname:
string; noCompress: Boolean): Boolean;
function ScreenShotThisInit(hwnd: HWND; noCompress: Boolean): THandle;
function ScreenShotThisFinit(DIB:THandle; fname:
string): Boolean;
//------------------------------------------------------------------------------
function WIDTHBYTES(bits: Integer): Integer;
function IS_WIN30_DIB(lpbi: PChar): BOOL;
function RECTWIDTH(Rect: TRect): Integer;
function RECTHEIGHT(Rect: TRect): Integer;
//------------------------------------------------------------------------------
function MyDIBNumColors(lpDIB: LPSTR): WORD;
function MyPaletteSize(lpDIB: LPSTR): WORD;
function MyFindDIBBits(lpDIB: LPSTR): LPSTR;
function MyDIBWidth(lpDIB: LPSTR): DWORD;
function MyDIBHeight(lpDIB: LPSTR): DWORD;
function CreateDIB(dwWidth: DWORD; dwHeight: DWORD; wBitCount: WORD): THandle;
function CreateDIBPalette(DIB: THandle): HPALETTE;
function DIBToBitmap(DIB: THandle; hPal: HPALETTE): HBITMAP;
function BitmapToDIB(hbmp: HBITMAP; hPal: HPALETTE): THandle;
function PalEntriesOnDevice(
DC: HDC): Integer;
function GetSystemPalette: HPALETTE;
function AllocRoomForDIB(bi: BITMAPINFOHEADER; hBmp: HBITMAP): THandle;
function ChangeDIBFormat(DIB: THandle; wBitCount: WORD; dwCompression: DWORD): THandle;
function ChangeBitmapFormat(hBmp: HBITMAP; wBitCount: WORD; dwCompression: DWORD; hPal: HPALETTE): THandle;
function CopyWindowToDIB(Wnd: HWND; fPrintArea: WORD): THandle;
function CopyScreenToDIB(
const Rect: TRect): THandle;
function CopyWindowToBitmap(Wnd: HWND; fPrintArea: WORD): HBITMAP;
function CopyScreenToBitmap(Rect: TRect): HBITMAP;
function PaintDIB(
DC: HDC; DCRect: TRect; DIB: THandle; DIBRect: TRect; hPal: HPALETTE): BOOL;
function PaintBitmap(
DC: HDC; DCRect: TRect; hDDB: HBITMAP; DDBRect: TRect; hPal: HPALETTE): BOOL;
//function MyLoadDIB(lpFileName: LPSTR): THandle;
//function MySaveDIB(hDib: THandle; lpFileName: LPSTR): DWORD;
function DestroyDIB(hDib: THandle): WORD;
function ReadDIBFile(hFile: THandle): THandle;
//------------------------------------------------------------------------------
implementation
(* DIB Macros*)
// WIDTHBYTES performs DWORD-aligning of DIB scanlines. The "bits"
// parameter is the bit count for the scanline (biWidth * biBitCount),
// and this macro returns the number of DWORD-aligned bytes needed
// to hold those bits.
function WIDTHBYTES(bits: Integer): Integer;
begin
result := (((bits) + 31)
div 32 * 4)
end;
function IS_WIN30_DIB(lpbi: PChar): BOOL;
begin
result := PDWORD(lpbi)^ = sizeof(BITMAPINFOHEADER);
end;
function RECTWIDTH(Rect: TRect): Integer;
begin
result := Rect.right - Rect.left;
end;
function RECTHEIGHT(Rect: TRect): Integer;
begin
result := Rect.bottom - Rect.top;
end;
(*************************************************************************
*
* MyDIBNumColors()
*
* Parameter:
*
* LPSTR lpDIB - pointer to packed-DIB memory block
*
* Return Value:
*
* WORD - number of colors in the color table
*
* Description:
*
* This function calculates the number of colors in the DIB's color table
* by finding the bits per pixel for the DIB (whether Win3.0 or OS/2-style
* DIB). If bits per pixel is 1: colors=2, if 4: colors=16, if 8: colors=256,
* if 24, no colors in color table.
*
************************************************************************)
function MyDIBNumColors(lpDIB: LPSTR): WORD;
var
wBitCount: WORD;
// DIB bit count
dwClrUsed: DWORD;
begin
result := 0;
if Assigned(lpDIB)
then
begin
// If this is a Windows-style DIB, the number of colors in the
// color table can be less than the number of bits per pixel
// allows for (i.e. lpbi->biClrUsed can be set to some value).
// If this is the case, return the appropriate value.
if (IS_WIN30_DIB(lpDIB))
then
begin
dwClrUsed := PBITMAPINFOHEADER(lpDIB)^.biClrUsed;
if (dwClrUsed) <> 0
then
begin
result := dwClrUsed;
exit;
end;
end;
// Calculate the number of colors in the color table based on
// the number of bits per pixel for the DIB.
case IS_WIN30_DIB(lpDIB)
of
TRUE: wBitCount := PBITMAPINFOHEADER(lpDIB)^.biBitCount;
else wBitCount := PBITMAPCOREHEADER(lpDIB)^.bcBitCount;
end;
// return number of colors based on bits per pixel
case wBitCount
of
1:
result := 2;
4:
result := 16;
8:
result := 256;
else
result := 0;
end;
end;
end;
(*************************************************************************
*
* MyPaletteSize()
*
* Parameter:
*
* LPSTR lpDIB - pointer to packed-DIB memory block
*
* Return Value:
*
* WORD - size of the color palette of the DIB
*
* Description:
*
* This function gets the size required to store the DIB's palette by
* multiplying the number of colors by the size of an RGBQUAD (for a
* Windows 3.0-style DIB) or by the size of an RGBTRIPLE (for an OS/2-
* style DIB).
*
************************************************************************)
function MyPaletteSize(lpDIB: LPSTR): WORD;
begin
result := 0;
if assigned(lpDIB)
then
begin
// calculate the size required by the palette
case IS_WIN30_DIB(lpDIB)
of
TRUE:
result := MyDIBNumColors(lpDIB) * sizeof(RGBQUAD);
else
result := MyDIBNumColors(lpDIB) * sizeof(RGBTRIPLE);
end;
end;
end;
... und soweiter