home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
pascal
/
library
/
windows
/
om
/
bitmap.pas
next >
Wrap
Pascal/Delphi Source File
|
1992-04-08
|
7KB
|
236 lines
{BitMap - Extensions to ObjectWindows by BI - unit structure by D.Overmyer}
unit BitMap;
{************************ Interface ***********************}
interface
uses WinTypes, WinProcs, WinDos, Strings, WObjects;
type
PTBMP = ^TBMP;
TBMP = object
FileName: array[0..fsPathName] of Char;
BitmapHandle: HBitmap;
PixelHeight, PixelWidth: Word;
hPal:HPalette;
constructor Init(ATitle: PChar);
destructor Done; virtual;
function LoadBitmapFile(Name: PChar): Boolean;
procedure CopyDIBPalette(var bmi:TBitmapInfo);
function OpenDIB(var TheFile: File): Boolean;
procedure GetBitmapData(var TheFile: File;
BitsHandle: THandle; BitsByteSize: Longint);
procedure Draw(PaintDC:hDC;PictRect:TRect;Scale:Boolean);
end;
{************************ Implementation **********************}
Implementation
{ __ahIncr, ordinal 114, is a 'magic' function. Defining this
function causes Windows to patch the value into the passed
reference. This makes it a type of global variable. To use
the value of AHIncr, use Ofs(AHIncr). }
procedure AHIncr; far; external 'KERNEL' index 114;
constructor TBMP.Init(ATitle: PChar);
var
DCHandle: HDC;
begin
BitmapHandle := 0;
hPal := GetStockObject(Default_Palette);
end;
{Done}
destructor TBMP.Done;
begin
if BitmapHandle <> 0 then DeleteObject(BitmapHandle);
if hPal <> 0 then DeleteObject(hPal);
hPal := 0;
end;
{ Test if the passed file is a Windows 3.0 DI bitmap and if so read it.
Report errors if unable to do so. Adjust the Scroller to the new
bitmap dimensions. }
{LoadBitmapFile}
function TBMP.LoadBitmapFile(Name: PChar): Boolean;
var
TheFile: File;
TestWin30Bitmap: Longint;
ErrorMsg: PChar;
OldCursor: HCursor;
begin
ErrorMsg := nil;
OldCursor := SetCursor(LoadCursor(0, idc_Wait));
Assign(TheFile, Name);
{$I-}
Reset(TheFile, 1);
{$I+}
if IOResult = 0 then
begin
Seek(TheFile, 14);
BlockRead(TheFile, TestWin30Bitmap, SizeOf(TestWin30Bitmap));
if TestWin30Bitmap = 40 then
if OpenDIB(TheFile) then
else ErrorMsg := 'Unable to create Windows 3.0 bitmap from file'
else
ErrorMsg := 'Not a Windows 3.0 bitmap file';
Close(TheFile);
end
else
ErrorMsg := 'Cannot open bitmap file';
SetCursor(OldCursor);
if ErrorMsg = nil then
LoadBitmapFile := True ;
end;
{ Copys the bitmap bit data from the file into memory. Since
copying cannot cross a segment (64K) boundary, we are forced
to do segment arithmetic to compute the next segment. Created
a LongType type to simplify the process. }
{GetBitmapData}
procedure TBMP.GetBitmapData(var TheFile: File;
BitsHandle: THandle; BitsByteSize: Longint);
type
LongType = record
case Word of
0: (Ptr: Pointer);
1: (Long: Longint);
2: (Lo: Word;
Hi: Word);
end;
var
Count: Longint;
Start, ToAddr, Bits: LongType;
begin
Start.Long := 0;
Bits.Ptr := GlobalLock(BitsHandle);
Count := BitsByteSize - Start.Long;
while Count > 0 do
begin
ToAddr.Hi := Bits.Hi + (Start.Hi * Ofs(AHIncr));
ToAddr.Lo := Start.Lo;
if Count > $4000 then Count := $4000;
BlockRead(TheFile, ToAddr.Ptr^, Count);
Start.Long := Start.Long + Count;
Count := BitsByteSize - Start.Long;
end;
GlobalUnlock(BitsHandle);
end;
{CopyDIBPalette}
procedure TBMP.CopyDibPalette(var bmi:TBitMapInfo);
var
LogPal :PLogPalette;
i : Integer;
PalSize:Integer;
sz : Word;
begin
if hPal <> 0 then
begin
DeleteObject(hPal);
hPal := 0;
end;
PalSize := 1 shl bmi.bmiHeader.biBitCount;
sz := sizeof(TLogPalette)+Pred(Palsize)*sizeof(TPaletteEntry);
LogPal := MemAlloc(sz);
{$R-}
for i := 0 to Pred(PalSize) do
With LogPal^ do
begin
palNumEntries := PalSize;
palVersion := $0300;
With palPalEntry[i],bmi.bmicolors[i] do
begin
peRed := rgbRed;
peBlue := rgbBlue;
peGreen := rgbGreen;
peFlags := 0;
end;
end;
hPal := CreatePalette(LogPal^);
FreeMem(LogPal,sz);
end;
{ Attempt to open a Windows 3.0 device independent bitmap. }
{OpenDIB}
function TBMP.OpenDIB(var TheFile: File): Boolean;
var
bitCount: Word;
size: Word;
longWidth: Longint;
DCHandle: HDC;
BitsPtr: Pointer;
BitmapInfo: PBitmapInfo;
BitsHandle, NewBitmapHandle,OldPal: THandle;
NewPixelWidth, NewPixelHeight: Word;
begin
OpenDIB := True;
Seek(TheFile, 28);
BlockRead(TheFile, bitCount, SizeOf(bitCount));
if bitCount <= 8 then
begin
size := SizeOf(TBitmapInfoHeader) + ((1 shl bitCount) * SizeOf(TRGBQuad));
BitmapInfo := MemAlloc(size);
Seek(TheFile, SizeOf(TBitmapFileHeader));
BlockRead(TheFile, BitmapInfo^, size);
NewPixelWidth := BitmapInfo^.bmiHeader.biWidth;
NewPixelHeight := BitmapInfo^.bmiHeader.biHeight;
CopyDIBPalette(BitMapInfo^);
longWidth := (((NewPixelWidth * bitCount) + 31) div 32) * 4;
BitmapInfo^.bmiHeader.biSizeImage := longWidth * NewPixelHeight;
GlobalCompact(-1);
BitsHandle := GlobalAlloc(gmem_Moveable or gmem_Zeroinit,
BitmapInfo^.bmiHeader.biSizeImage);
GetBitmapData(TheFile, BitsHandle, BitmapInfo^.bmiHeader.biSizeImage);
DCHandle := CreateDC('Display', nil, nil, nil);
BitsPtr := GlobalLock(BitsHandle);
OldPal := Selectpalette(DCHandle,hPal,false);
UnRealizeObject(hPal);
RealizePalette(DCHandle);
NewBitmapHandle :=
CreateDIBitmap(DCHandle, BitmapInfo^.bmiHeader, cbm_Init, BitsPtr,
BitmapInfo^, 0);
SelectPalette(DCHandle,OldPal,false);
DeleteDC(DCHandle);
GlobalUnlock(BitsHandle);
GlobalFree(BitsHandle);
FreeMem(BitmapInfo, size);
if NewBitmapHandle <> 0 then
begin
if BitmapHandle <> 0 then DeleteObject(BitmapHandle);
BitmapHandle := NewBitmapHandle;
PixelWidth := NewPixelWidth;
PixelHeight := NewPixelHeight;
end
else
OpenDIB := False;
end
else
OpenDIB := False;
end;
procedure TBMP.Draw(PaintDC:hDC;PictRect:TRect;Scale:Boolean);
var
MemDC:hDC;
OldBitmap:hBitmap;
OldPal:HPalette;
begin
MemDC := CreateCompatibleDC(PaintDC);
OldBitmap := SelectObject(MemDC,BitmapHandle);
OldPal := SelectPalette(PaintDC,hPal,false);
RealizePalette(hPal);
If Scale = True then
StretchBlt(PaintDC,PictRect.Left,PictRect.Top,
PictRect.Right-PictRect.Left,PictRect.Bottom-PictRect.Top,
MemDC,0,0,PixelWidth,PixelHeight,SrcCopy)
else
BitBlt(PaintDC,PictRect.Left,PictRect.Top,
PictRect.Right-PictRect.Left,PictRect.Bottom-PictRect.Top,
MemDC,0,0,SrcCopy);
SelectObject(MemDC,OldBitmap);
SelectPalette(PaintDC,OldPal,false);
DeleteDC(MemDC);
end;
{************************ End **********************}
end.