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