Turbo Pascal 7.0 / TP7 / OWLDEMOS / BSCRLAPP

{************************************************}
{ }
{ Turbo Pascal for Windows }
{ Demo program }
{ Copyright (c) 1991 by Borland International }
{ }
{************************************************}

program BScrlApp;

{$R BSCRLAPP.RES}

uses WinTypes, WinProcs, WinDos, WObjects, StdDlgs, Strings;

const
bsa_Name = 'BitmapScroll';

type

{ TBitScrollApp, a TApplication descendant }

TBitScrollApp = object(TApplication)
procedure InitMainWindow; virtual;
end;

{ TBitScrollWindow, a TWindow descendant }

PScrollWindow = ^TBitScrollWindow;
TBitScrollWindow = object(TWindow)
FileName: array[0..fsPathName] of Char;
BitmapHandle: HBitmap;
IconizedBits: HBitmap;
IconImageValid: Boolean;
PixelHeight, PixelWidth: Word;
Mode: Longint;
constructor Init(ATitle: PChar);
destructor Done; virtual;
function GetClassName : PChar; virtual;
procedure GetWindowClass(var WndClass: TWndClass); virtual;
procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;
procedure CMFileOpen(var Msg: TMessage); virtual cm_First + cm_FileOpen;
procedure WMSize(var Msg: TMessage); virtual wm_First + wm_Size;
procedure AdjustScroller;
function LoadBitmapFile(Name: PChar): Boolean;
function OpenDIB(var TheFile: File): Boolean;
procedure GetBitmapData(var TheFile: File;
BitsHandle: THandle; BitsByteSize: Longint);
end;

{ __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;

{ Construct the TBitScrollApp's MainWindow of type TBitScrollWindow }

procedure TBitScrollApp.InitMainWindow;
begin
MainWindow := New(PScrollWindow, Init(bsa_name));
end;

{ Constructor for a TBitScrollWindow, sets scroll styles and constructs
the Scroller object. Also sets the Mode based on whether the display
is monochrome (two-color) or polychrome. }

constructor TBitScrollWindow.Init(ATitle: PChar);
var
DCHandle: HDC;
begin
TWindow.Init(nil, ATitle);
Attr.Style := Attr.Style or ws_VScroll or ws_HScroll;
Attr.Menu := LoadMenu(HInstance, bsa_Name);
BitmapHandle := 0;
IconImageValid := False;
Scroller := New(PScroller, Init(@Self, 1, 1, 200, 200));
DCHandle := CreateDC('Display', nil, nil, nil);
IconizedBits := CreateCompatibleBitmap(DCHandle, 64, 64);
if GetDeviceCaps(DCHandle, numColors) < 3 then Mode := notSrcCopy
else Mode := srcCopy;
DeleteDC(DCHandle);
end;

{ Change the class name to the application name. }

function TBitScrollWindow.GetClassName : PChar;
begin
GetClassName := bsa_Name;
end;

{ Allow the iconic picture to be drawn from the client area. }

procedure TBitScrollWindow.GetWindowClass(var WndClass: TWndClass);
begin
TWindow.GetWindowClass(WndClass);
WndClass.hIcon := 0; { Client area will be painted by the app. }
end;

destructor TBitScrollWindow.Done;
begin
if BitmapHandle <> 0 then DeleteObject(BitmapHandle);
TWindow.Done;
end;

{ If the the 'Open...' menu item is selected, then, using
the current TFileDlgRec we prompt the user for a new bitmap
file. If the user selects one and it is one that we can
read, we display it in the window and change the window's
caption to reflect the new bitmap file. It should be noted
that we save the old TFileDlgRec just in case we are unable
to display the bitmap. This allows us to restore the old
search criteria. }

procedure TBitScrollWindow.CMFileOpen(var Msg: TMessage);
var
TempName: array[0..fsPathName] of Char;
CaptionBuffer: array [0..fsPathName+12{bsa_Name} +2{': '} +1{#0}] of Char;
begin
if Application^.ExecDialog(New(PFileDialog,
Init(@Self, PChar(sd_FileOpen), StrCopy(TempName, '*.bmp')))) = id_Ok then
if LoadBitmapFile(TempName) then
begin
StrCopy(FileName, TempName);
StrCopy(CaptionBuffer, bsa_Name);
StrCat(CaptionBuffer, ': ');
StrCat(CaptionBuffer, AnsiLower(FileName));
SetWindowText(HWindow, CaptionBuffer);
end;
end;

{ Adjust the Scroller range so that the the origin is the
upper-most scrollable point and the corner is the
bottom-most. }

procedure TBitScrollWindow.AdjustScroller;
var
ClientRect: TRect;
begin
GetClientRect(HWindow, ClientRect);
with ClientRect do
Scroller^.SetRange(PixelWidth - (right - left),
PixelHeight - (bottom - top));
Scroller^.ScrollTo(0, 0);
InvalidateRect(HWindow, nil, True);
end;

{ Reset scroller range. }

procedure TBitScrollWindow.WMSize(var Msg: TMessage);
var
ClientRect: TRect;
DC, MemDC1, MemDC2: HDC;
OldBitmap1, OldBitmap2: HBitmap;
OldCursor: HCursor;
begin
TWindow.WMSize(Msg);
Scroller^.AutoOrg := not (Msg.wParam = sizeIconic);
if not (Msg.WParam = sizeIconic) then AdjustScroller
else if not IconImageValid and (BitmapHandle <> 0) then
begin
DC := GetDC(HWindow);
MemDC1 := CreateCompatibleDC(DC);
MemDC2 := CreateCompatibleDC(DC);
ReleaseDC(HWindow, DC);
OldBitmap1 := SelectObject(MemDC1, IconizedBits);
OldBitmap2 := SelectObject(MemDC2, BitmapHandle);
OldCursor := SetCursor(LoadCursor(0, idc_Wait));
StretchBlt(MemDC1, 0, 0, Msg.lParamLo, Msg.lParamHi, MemDC2,
0, 0, PixelWidth, PixelHeight, SrcCopy);
SetCursor(OldCursor);
SelectObject(MemDC1, OldBitmap1);
SelectObject(MemDC2, OldBitmap2);
DeleteDC(MemDC1);
DeleteDC(MemDC2);
IconImageValid := True;
end;
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. }

procedure TBitScrollWindow.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;

{ Attempt to open a Windows 3.0 device independent bitmap. }

function TBitScrollWindow.OpenDIB(var TheFile: File): Boolean;
var
bitCount: Word;
size: Word;
longWidth: Longint;
DCHandle: HDC;
BitsPtr: Pointer;
BitmapInfo: PBitmapInfo;
BitsHandle, NewBitmapHandle: 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;
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);
NewBitmapHandle :=
CreateDIBitmap(DCHandle, BitmapInfo^.bmiHeader, cbm_Init, BitsPtr,
BitmapInfo^, 0);
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;

{ 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. }

function TBitScrollWindow.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
begin
AdjustScroller;
IconImageValid := False;
end
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 else
begin
MessageBox(HWindow, ErrorMsg, bsa_Name, mb_Ok);
LoadBitmapFile := False;
end;
end;

{ Responds to an incoming "paint" message by redrawing the bitmap. (The
Scroller's BeginView method, which sets the viewport origin relative
to the present scroll position, has already been called. ) }

procedure TBitScrollWindow.Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
var
MemoryDC: HDC;
OldBitmapHandle: THandle;
ClientRect: TRect;
begin
if BitmapHandle <> 0 then
begin
MemoryDC := CreateCompatibleDC(PaintDC);
if IsIconic(HWindow) then
OldBitmapHandle := SelectObject(MemoryDC, IconizedBits)
else
begin
OldBitmapHandle := SelectObject(MemoryDC, BitmapHandle);
if Mode = srcCopy then
begin
SetBkColor(PaintDC, GetNearestColor(PaintDC, $800000));
SetTextColor(PaintDC, $FFFFFF);
end;
end;
BitBlt(PaintDC, 0, 0, PixelWidth, PixelHeight, MemoryDC, 0, 0,
Mode);
SelectObject(MemoryDC, OldBitmapHandle);
DeleteDC(MemoryDC);
end;
end;

{ Declare a variable of type TBitScrollApp }

var
ScrollApp: TBitScrollApp;

{ Run the BitScrollApp }

begin
ScrollApp.Init(bsa_Name);
ScrollApp.Run;
ScrollApp.Done;
end.