home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / tpw / owldemos / bscrlapp.pas < prev    next >
Pascal/Delphi Source File  |  1991-05-20  |  11KB  |  352 lines
  1. {************************************************}
  2. {                                                }
  3. {   Turbo Pascal for Windows                     }
  4. {   Demo program                                 }
  5. {   Copyright (c) 1991 by Borland International  }
  6. {                                                }
  7. {************************************************}
  8.  
  9. program BScrlApp;
  10.  
  11. {$R BSCRLAPP.RES}
  12.  
  13. uses WinTypes, WinProcs, WinDos, WObjects, StdDlgs, Strings;
  14.  
  15. const
  16.   bsa_Name =  'BitmapScroll';
  17.  
  18. type
  19.  
  20. { TBitScrollApp, a TApplication descendant }
  21.  
  22.   TBitScrollApp = object(TApplication)
  23.     procedure InitMainWindow; virtual;
  24.   end;
  25.  
  26. { TBitScrollWindow, a TWindow descendant }
  27.  
  28.   PScrollWindow = ^TBitScrollWindow;
  29.   TBitScrollWindow = object(TWindow)
  30.     FileName: array[0..fsPathName] of Char;
  31.     BitmapHandle: HBitmap;
  32.     IconizedBits: HBitmap;
  33.     IconImageValid: Boolean;
  34.     PixelHeight, PixelWidth: Word;
  35.     Mode: Longint;
  36.     constructor Init(ATitle: PChar);
  37.     destructor Done; virtual;
  38.     function GetClassName : PChar; virtual;
  39.     procedure GetWindowClass(var WndClass: TWndClass); virtual;
  40.     procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;
  41.     procedure CMFileOpen(var Msg: TMessage); virtual cm_First + cm_FileOpen;
  42.     procedure WMSize(var Msg: TMessage); virtual wm_First + wm_Size;
  43.     procedure AdjustScroller;
  44.     function LoadBitmapFile(Name: PChar): Boolean;
  45.     function OpenDIB(var TheFile: File): Boolean;
  46.     procedure GetBitmapData(var TheFile: File;
  47.       BitsHandle: THandle; BitsByteSize: Longint);
  48.   end;
  49.  
  50. { __ahIncr, ordinal 114, is a 'magic' function. Defining this
  51.   function causes Windows to patch the value into the passed
  52.   reference.  This makes it a type of global variable. To use
  53.   the value of AHIncr, use Ofs(AHIncr). }
  54.  
  55. procedure AHIncr; far; external 'KERNEL' index 114;
  56.  
  57. { Construct the TBitScrollApp's MainWindow of type TBitScrollWindow }
  58.  
  59. procedure TBitScrollApp.InitMainWindow;
  60. begin
  61.   MainWindow := New(PScrollWindow, Init(bsa_name));
  62. end;
  63.  
  64. { Constructor for a TBitScrollWindow, sets scroll styles and constructs
  65.   the Scroller object.  Also sets the Mode based on whether the display
  66.   is monochrome (two-color) or polychrome. }
  67.  
  68. constructor TBitScrollWindow.Init(ATitle: PChar);
  69. var
  70.   DCHandle: HDC;
  71. begin
  72.   TWindow.Init(nil, ATitle);
  73.   Attr.Style := Attr.Style or ws_VScroll or ws_HScroll;
  74.   Attr.Menu := LoadMenu(HInstance, bsa_Name);
  75.   BitmapHandle := 0;
  76.   IconImageValid := False;
  77.   Scroller := New(PScroller, Init(@Self, 1, 1, 200, 200));
  78.   DCHandle := CreateDC('Display', nil, nil, nil);
  79.   IconizedBits := CreateCompatibleBitmap(DCHandle, 64, 64);
  80.   if GetDeviceCaps(DCHandle, numColors) < 3 then Mode := notSrcCopy
  81.   else Mode := srcCopy;
  82.   DeleteDC(DCHandle);
  83. end;
  84.  
  85. { Change the class name to the application name. }
  86.  
  87. function TBitScrollWindow.GetClassName : PChar;
  88. begin
  89.   GetClassName := bsa_Name;
  90. end;
  91.  
  92. { Allow the iconic picture to be drawn from the client area. }
  93.  
  94. procedure TBitScrollWindow.GetWindowClass(var WndClass: TWndClass);
  95. begin
  96.   TWindow.GetWindowClass(WndClass);
  97.   WndClass.hIcon := 0; { Client area will be painted by the app. }
  98. end;
  99.  
  100. destructor TBitScrollWindow.Done;
  101. begin
  102.   if BitmapHandle <> 0 then DeleteObject(BitmapHandle);
  103.   TWindow.Done;
  104. end;
  105.  
  106. { If the the 'Open...' menu item is selected, then, using
  107.   the current TFileDlgRec we prompt the user for a new bitmap
  108.   file.  If the user selects one and it is one that we can
  109.   read, we display it in the window and change the window's
  110.   caption to reflect the new bitmap file.  It should be noted
  111.   that we save the old TFileDlgRec just in case we are unable
  112.   to display the bitmap.  This allows us to restore the old
  113.   search criteria. }
  114.  
  115. procedure TBitScrollWindow.CMFileOpen(var Msg: TMessage);
  116. var
  117.   TempName: array[0..fsPathName] of Char;
  118.   CaptionBuffer: array [0..fsPathName+12{bsa_Name} +2{': '} +1{#0}] of Char;
  119. begin
  120.   if Application^.ExecDialog(New(PFileDialog,
  121.     Init(@Self, PChar(sd_FileOpen), StrCopy(TempName, '*.bmp')))) = id_Ok then
  122.     if LoadBitmapFile(TempName) then
  123.     begin
  124.       StrCopy(FileName, TempName);
  125.       StrCopy(CaptionBuffer, bsa_Name);
  126.       StrCat(CaptionBuffer, ': ');
  127.       StrCat(CaptionBuffer, AnsiLower(FileName));
  128.       SetWindowText(HWindow, CaptionBuffer);
  129.     end;
  130. end;
  131.  
  132. { Adjust the Scroller range so that the the origin is the
  133.   upper-most scrollable point and the corner is the
  134.   bottom-most. }
  135.  
  136. procedure TBitScrollWindow.AdjustScroller;
  137. var
  138.   ClientRect: TRect;
  139. begin
  140.   GetClientRect(HWindow, ClientRect);
  141.   with ClientRect do
  142.     Scroller^.SetRange(PixelWidth - (right - left),
  143.       PixelHeight - (bottom - top));
  144.   Scroller^.ScrollTo(0, 0);
  145.   InvalidateRect(HWindow, nil, True);
  146. end;
  147.  
  148. { Reset scroller range. }
  149.  
  150. procedure TBitScrollWindow.WMSize(var Msg: TMessage);
  151. var
  152.   ClientRect: TRect;
  153.   DC, MemDC1, MemDC2: HDC;
  154.   OldBitmap1, OldBitmap2: HBitmap;
  155.   OldCursor: HCursor;
  156. begin
  157.   TWindow.WMSize(Msg);
  158.   Scroller^.AutoOrg := not (Msg.wParam = sizeIconic);
  159.   if not (Msg.WParam = sizeIconic) then AdjustScroller
  160.   else if not IconImageValid and (BitmapHandle <> 0) then
  161.   begin
  162.     DC := GetDC(HWindow);
  163.     MemDC1 := CreateCompatibleDC(DC);
  164.     MemDC2 := CreateCompatibleDC(DC);
  165.     ReleaseDC(HWindow, DC);
  166.     OldBitmap1 := SelectObject(MemDC1, IconizedBits);
  167.     OldBitmap2 := SelectObject(MemDC2, BitmapHandle);
  168.     OldCursor := SetCursor(LoadCursor(0, idc_Wait));
  169.     StretchBlt(MemDC1, 0, 0, Msg.lParamLo, Msg.lParamHi, MemDC2,
  170.       0, 0, PixelWidth, PixelHeight, SrcCopy);
  171.     SetCursor(OldCursor);
  172.     SelectObject(MemDC1, OldBitmap1);
  173.     SelectObject(MemDC2, OldBitmap2);
  174.     DeleteDC(MemDC1);
  175.     DeleteDC(MemDC2);
  176.     IconImageValid := True;
  177.   end;
  178. end;
  179.  
  180. { Copys the bitmap bit data from the file into memory. Since
  181.   copying cannot cross a segment (64K) boundary, we are forced
  182.   to do segment arithmetic to compute the next segment.  Created
  183.   a LongType type to simplify the process. }
  184.  
  185. procedure TBitScrollWindow.GetBitmapData(var TheFile: File;
  186.   BitsHandle: THandle; BitsByteSize: Longint);
  187. type
  188.   LongType = record
  189.     case Word of
  190.       0: (Ptr: Pointer);
  191.       1: (Long: Longint);
  192.       2: (Lo: Word;
  193.       Hi: Word);
  194.   end;
  195. var
  196.   Count: Longint;
  197.   Start, ToAddr, Bits: LongType;
  198. begin
  199.   Start.Long := 0;
  200.   Bits.Ptr := GlobalLock(BitsHandle);
  201.   Count := BitsByteSize - Start.Long;
  202.   while Count > 0 do
  203.   begin
  204.     ToAddr.Hi := Bits.Hi + (Start.Hi * Ofs(AHIncr));
  205.     ToAddr.Lo := Start.Lo;
  206.     if Count > $4000 then Count := $4000;
  207.     BlockRead(TheFile, ToAddr.Ptr^, Count);
  208.     Start.Long := Start.Long + Count;
  209.     Count := BitsByteSize - Start.Long;
  210.   end;
  211.   GlobalUnlock(BitsHandle);
  212. end;
  213.  
  214. { Attempt to open a Windows 3.0 device independent bitmap. }
  215.  
  216. function TBitScrollWindow.OpenDIB(var TheFile: File): Boolean;
  217. var
  218.   bitCount: Word;
  219.   size: Word;
  220.   longWidth: Longint;
  221.   DCHandle: HDC;
  222.   BitsPtr: Pointer;
  223.   BitmapInfo: PBitmapInfo;
  224.   BitsHandle, NewBitmapHandle: THandle;
  225.   NewPixelWidth, NewPixelHeight: Word;
  226. begin
  227.   OpenDIB := True;
  228.   Seek(TheFile, 28);
  229.   BlockRead(TheFile, bitCount, SizeOf(bitCount));
  230.   if bitCount <= 8 then
  231.   begin
  232.     size := SizeOf(TBitmapInfoHeader) + ((1 shl bitCount) * SizeOf(TRGBQuad));
  233.     BitmapInfo := MemAlloc(size);
  234.     Seek(TheFile, SizeOf(TBitmapFileHeader));
  235.     BlockRead(TheFile, BitmapInfo^, size);
  236.     NewPixelWidth := BitmapInfo^.bmiHeader.biWidth;
  237.     NewPixelHeight := BitmapInfo^.bmiHeader.biHeight;
  238.     longWidth := (((NewPixelWidth * bitCount) + 31) div 32) * 4;
  239.     BitmapInfo^.bmiHeader.biSizeImage := longWidth * NewPixelHeight;
  240.     GlobalCompact(-1);
  241.     BitsHandle := GlobalAlloc(gmem_Moveable or gmem_Zeroinit,
  242.       BitmapInfo^.bmiHeader.biSizeImage);
  243.     GetBitmapData(TheFile, BitsHandle, BitmapInfo^.bmiHeader.biSizeImage);
  244.     DCHandle := CreateDC('Display', nil, nil, nil);
  245.     BitsPtr := GlobalLock(BitsHandle);
  246.     NewBitmapHandle :=
  247.       CreateDIBitmap(DCHandle, BitmapInfo^.bmiHeader, cbm_Init, BitsPtr,
  248.       BitmapInfo^, 0);
  249.     DeleteDC(DCHandle);
  250.     GlobalUnlock(BitsHandle);
  251.     GlobalFree(BitsHandle);
  252.     FreeMem(BitmapInfo, size);
  253.     if NewBitmapHandle <> 0 then
  254.     begin
  255.       if BitmapHandle <> 0 then DeleteObject(BitmapHandle);
  256.       BitmapHandle := NewBitmapHandle;
  257.       PixelWidth := NewPixelWidth;
  258.       PixelHeight := NewPixelHeight;
  259.     end
  260.     else
  261.       OpenDIB := False;
  262.   end
  263.   else
  264.     OpenDIB := False;
  265. end;
  266.  
  267. { Test if the passed file is a Windows 3.0 DI bitmap and if so read it.
  268.   Report errors if unable to do so. Adjust the Scroller to the new
  269.   bitmap dimensions. }
  270.  
  271. function TBitScrollWindow.LoadBitmapFile(Name: PChar): Boolean;
  272. var
  273.   TheFile: File;
  274.   TestWin30Bitmap: Longint;
  275.   ErrorMsg: PChar;
  276.   OldCursor: HCursor;
  277. begin
  278.   ErrorMsg := nil;
  279.   OldCursor := SetCursor(LoadCursor(0, idc_Wait));
  280.   Assign(TheFile, Name);
  281.   {$I-}
  282.   Reset(TheFile, 1);
  283.   {$I+}
  284.   if IOResult = 0 then
  285.   begin
  286.     Seek(TheFile, 14);
  287.     BlockRead(TheFile, TestWin30Bitmap, SizeOf(TestWin30Bitmap));
  288.     if TestWin30Bitmap = 40 then
  289.       if OpenDIB(TheFile) then
  290.       begin
  291.     AdjustScroller;
  292.     IconImageValid := False;
  293.       end
  294.       else ErrorMsg := 'Unable to create Windows 3.0 bitmap from file'
  295.     else
  296.       ErrorMsg := 'Not a Windows 3.0 bitmap file';
  297.     Close(TheFile);
  298.   end
  299.   else
  300.     ErrorMsg := 'Cannot open bitmap file';
  301.   SetCursor(OldCursor);
  302.   if ErrorMsg = nil then LoadBitmapFile := True else
  303.   begin
  304.     MessageBox(HWindow, ErrorMsg, bsa_Name, mb_Ok);
  305.     LoadBitmapFile := False;
  306.   end;
  307. end;
  308.  
  309. { Responds to an incoming "paint" message by redrawing the bitmap.  (The
  310.   Scroller's BeginView method, which sets the viewport origin relative
  311.   to the present scroll position, has already been called. )  }
  312.  
  313. procedure TBitScrollWindow.Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
  314. var
  315.   MemoryDC: HDC;
  316.   OldBitmapHandle: THandle;
  317.   ClientRect: TRect;
  318. begin
  319.   if BitmapHandle <> 0 then
  320.   begin
  321.     MemoryDC := CreateCompatibleDC(PaintDC);
  322.     if IsIconic(HWindow) then
  323.       OldBitmapHandle := SelectObject(MemoryDC, IconizedBits)
  324.     else
  325.     begin
  326.       OldBitmapHandle := SelectObject(MemoryDC, BitmapHandle);
  327.       if Mode = srcCopy then
  328.       begin
  329.     SetBkColor(PaintDC, GetNearestColor(PaintDC, $800000));
  330.     SetTextColor(PaintDC, $FFFFFF);
  331.       end;
  332.     end;
  333.     BitBlt(PaintDC, 0, 0, PixelWidth, PixelHeight, MemoryDC, 0, 0,
  334.       Mode);
  335.     SelectObject(MemoryDC, OldBitmapHandle);
  336.     DeleteDC(MemoryDC);
  337.   end;
  338. end;
  339.  
  340. { Declare a variable of type TBitScrollApp }
  341.  
  342. var
  343.   ScrollApp: TBitScrollApp;
  344.  
  345. { Run the BitScrollApp }
  346.  
  347. begin
  348.   ScrollApp.Init(bsa_Name);
  349.   ScrollApp.Run;
  350.   ScrollApp.Done;
  351. end.
  352.