home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / l / l040 / 11.ddi / OWLDEMOS.ZIP / STRETCH.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-10-27  |  9.7 KB  |  332 lines
  1. {************************************************}
  2. {                                                }
  3. {   Demo program                                 }
  4. {   Copyright (c) 1991 by Borland International  }
  5. {                                                }
  6. {************************************************}
  7.  
  8. program Stretch;
  9.  
  10. {$R STRETCH.RES}
  11.  
  12. uses
  13.   WinTypes, WinProcs, WinDos, Strings, OWindows, ODialogs, OMemory,
  14.     OStdDlgs;
  15.  
  16. const
  17.   idm_Load    = 100;
  18.   idm_Fixed   = 101;
  19.   idm_Stretch = 102;
  20.   idm_About   = 103;
  21.  
  22. type
  23.   TApp = object(TApplication)
  24.     procedure InitMainWindow; virtual;
  25.   end;
  26.  
  27.   PStretchWindow = ^TStretchWindow;
  28.   TStretchWindow = object(TWindow)
  29.     BitMapHandle: HBitmap;
  30.     IconizedBits: HBitmap;
  31.     IconImageValid: Boolean;
  32.     Stretch: Boolean;
  33.     Width, Height: LongInt;
  34.     constructor Init(AParent: PWindowsObject; Title: PChar);
  35.     destructor Done; virtual;
  36.     procedure About(var Message: TMessage); Virtual cm_first + idm_About;
  37.     procedure Fixed(var Message: TMessage); Virtual cm_first + idm_Fixed;
  38.     procedure GetBitmapData(var TheFile: File; BitsHandle: THandle;
  39.       BitsByteSize: Longint);
  40.     procedure GetWindowClass(var WndClass: TWndClass); virtual;
  41.     function LoadBitmapFile(Name: PChar): Boolean;
  42.     procedure LoadImage(var Message: TMessage); virtual cm_first + idm_Load;
  43.     function OpenDIB(var TheFile: File): Boolean;
  44.     procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;
  45.     procedure SetUpWindow; virtual;
  46.     procedure SetWindowSize;
  47.     procedure StretchOption(var Message: TMessage); virtual
  48.       cm_first + idm_Stretch;
  49.     procedure WMSize(var Message: TMessage); virtual wm_Size;
  50.   end;
  51.  
  52. { __ahIncr, ordinal 114, is a 'magic' function. Defining this
  53.   function causes Windows to patch the value into the passed
  54.   reference.  This makes it a type of global variable. To use
  55.   the value of AHIncr, use Ofs(AHIncr). }
  56. procedure AHIncr; far; external 'KERNEL' index 114;
  57.  
  58. { TStretchWindow }
  59.  
  60. constructor TStretchWindow.Init(AParent: PWindowsObject; Title: PChar);
  61. var
  62.   DC: HDC;
  63. begin
  64.   TWindow.Init(AParent, Title);
  65.   BitMapHandle := 0;
  66.   DC := GetDC(GetFocus);
  67.   IconizedBits := CreateCompatibleBitmap(DC, 64, 64);
  68.   ReleaseDC(GetFocus, DC);
  69.   IconImageValid := False;
  70.   Stretch := True;
  71. end;
  72.  
  73. destructor TStretchWindow.Done;
  74. begin
  75.   if BitMapHandle <> 0 then DeleteObject(BitMapHandle);
  76.   DeleteObject(IconizedBits);
  77.   TWindow.Done;
  78. end;
  79.  
  80. procedure TStretchWindow.About(var Message: TMessage);
  81. var
  82.   Dialog: TDialog;
  83. begin
  84.   Dialog.Init(@Self, 'About');
  85.   Dialog.Execute;
  86.   Dialog.Done;
  87. end;
  88.  
  89. procedure TStretchWindow.Fixed(var Message: TMessage);
  90. begin
  91.   CheckMenuItem(GetMenu(HWindow), idm_Fixed, mf_Checked or mf_ByCommand);
  92.   CheckMenuItem(GetMenu(HWindow), idm_Stretch, mf_UnChecked or mf_ByCommand);
  93.   Stretch := False;
  94.   SetWindowSize;
  95.   InvalidateRect(HWindow, nil, False);
  96. end;
  97.  
  98. { Copys the bitmap bit data from the file into memory. Since
  99.   copying cannot cross a segment (64K) boundary, we are forced
  100.   to do segment arithmetic to compute the next segment.  Created
  101.   a LongType type to simplify the process. }
  102. procedure TStretchWindow.GetBitmapData(var TheFile: File;
  103.   BitsHandle: THandle; BitsByteSize: Longint);
  104. type
  105.   LongType = record
  106.     case Word of
  107.       0: (Ptr: Pointer);
  108.       1: (Long: Longint);
  109.       2: (Lo: Word;
  110.       Hi: Word);
  111.   end;
  112. var
  113.   Count: Longint;
  114.   Start, ToAddr, Bits: LongType;
  115. begin
  116.   Start.Long := 0;
  117.   Bits.Ptr := GlobalLock(BitsHandle);
  118.   Count := BitsByteSize - Start.Long;
  119.   while Count > 0 do
  120.   begin
  121.     ToAddr.Hi := Bits.Hi + (Start.Hi * Ofs(AHIncr));
  122.     ToAddr.Lo := Start.Lo;
  123.     if Count > $4000 then Count := $4000;
  124.     BlockRead(TheFile, ToAddr.Ptr^, Count);
  125.     Start.Long := Start.Long + Count;
  126.     Count := BitsByteSize - Start.Long;
  127.   end;
  128.   GlobalUnlock(BitsHandle);
  129. end;
  130.  
  131. procedure TStretchWindow.GetWindowClass(var WndClass: TWndClass);
  132. begin
  133.   TWindow.GetWindowClass(WndClass);
  134.  
  135.  { With a 0 as hIcon the program can write to the Icon in the paint method }
  136.   WndClass.HIcon := 0;
  137.   WndClass.lpszMenuName := 'Menu';
  138. end;
  139.  
  140. { Test if the passed file is a Windows 3.0 DI bitmap and if so read it.
  141.   Report errors if unable to do so. Adjust the Scroller to the new
  142.   bitmap dimensions. }
  143. function TStretchWindow.LoadBitmapFile(Name: PChar): Boolean;
  144. var
  145.   TheFile: File;
  146.   TestWin30Bitmap: Longint;
  147. begin
  148.   LoadBitmapFile := False;
  149.   Assign(TheFile, Name);
  150.   Reset(TheFile, 1);
  151.   Seek(TheFile, 14);
  152.   BlockRead(TheFile, TestWin30Bitmap, SizeOf(TestWin30Bitmap));
  153.   if TestWin30Bitmap = 40 then
  154.     if OpenDIB(TheFile) then
  155.     begin
  156.       LoadBitmapFile := True;
  157.       IconImageValid := False;
  158.     end
  159.     else
  160.       MessageBox(HWindow, 'Unable to create Windows 3.0 bitmap from file.',
  161.     Name, mb_Ok)
  162.   else
  163.       MessageBox(HWindow, 'Not a Windows 3.0 bitmap file.  Convert using Paintbrush.', Name, mb_Ok);
  164.   Close(TheFile);
  165. end;
  166.  
  167. procedure TStretchWindow.LoadImage(var Message: TMessage);
  168. var
  169.   FileName: array[0..200] of Char;
  170. begin
  171.   if Application^.ExecDialog(New(PFileDialog,
  172.     Init(@Self, PChar(sd_FileOpen),
  173.     StrCopy(FileName, '*.bmp')))) = id_Ok then
  174.     if LoadBitmapFile(FileName) then
  175.       SetWindowSize;
  176.   InvalidateRect(HWindow, nil, False);
  177. end;
  178.  
  179. { Attempt to open a Windows 3.0 device independent bitmap. }
  180. function TStretchWindow.OpenDIB(var TheFile: File): Boolean;
  181. var
  182.   bitCount: Word;
  183.   size: Word;
  184.   longWidth: Longint;
  185.   DCHandle: HDC;
  186.   BitsPtr: Pointer;
  187.   BitmapInfo: PBitmapInfo;
  188.   BitsHandle, NewBitmapHandle: THandle;
  189.   NewPixelWidth, NewPixelHeight: Word;
  190. begin
  191.   OpenDIB := True;
  192.   Seek(TheFile, 28);
  193.   BlockRead(TheFile, bitCount, SizeOf(bitCount));
  194.   if bitCount <= 8 then
  195.   begin
  196.     size := SizeOf(TBitmapInfoHeader) + ((1 shl bitCount) * SizeOf(TRGBQuad));
  197.     BitmapInfo := MemAlloc(size);
  198.     Seek(TheFile, SizeOf(TBitmapFileHeader));
  199.     BlockRead(TheFile, BitmapInfo^, size);
  200.     NewPixelWidth := BitmapInfo^.bmiHeader.biWidth;
  201.     NewPixelHeight := BitmapInfo^.bmiHeader.biHeight;
  202.     longWidth := (((NewPixelWidth * bitCount) + 31) div 32) * 4;
  203.     BitmapInfo^.bmiHeader.biSizeImage := longWidth * NewPixelHeight;
  204.     GlobalCompact(-1);
  205.     BitsHandle := GlobalAlloc(gmem_Moveable or gmem_Zeroinit,
  206.       BitmapInfo^.bmiHeader.biSizeImage);
  207.     GetBitmapData(TheFile, BitsHandle, BitmapInfo^.bmiHeader.biSizeImage);
  208.     DCHandle := CreateDC('Display', nil, nil, nil);
  209.     BitsPtr := GlobalLock(BitsHandle);
  210.     NewBitmapHandle :=
  211.       CreateDIBitmap(DCHandle, BitmapInfo^.bmiHeader, cbm_Init, BitsPtr,
  212.       BitmapInfo^, 0);
  213.     DeleteDC(DCHandle);
  214.     GlobalUnlock(BitsHandle);
  215.     GlobalFree(BitsHandle);
  216.     FreeMem(BitmapInfo, size);
  217.     if NewBitmapHandle <> 0 then
  218.     begin
  219.       if BitmapHandle <> 0 then DeleteObject(BitmapHandle);
  220.       BitmapHandle := NewBitmapHandle;
  221.       Width := NewPixelWidth;
  222.       Height := NewPixelHeight;
  223.     end
  224.     else
  225.       OpenDIB := False;
  226.   end
  227.   else
  228.     OpenDIB := False;
  229. end;
  230.  
  231. procedure TStretchWindow.Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
  232. var
  233.   MemDC: HDC;
  234.   OldBitmap: HBitmap;
  235.   R: TRect;
  236. begin
  237.   if BitMapHandle <> 0 then
  238.   begin
  239.     MemDC := CreateCompatibleDC(PaintDC);
  240.     if IsIconic(HWindow) and IconImageValid then
  241.     begin
  242.       OldBitmap := SelectObject(MemDC, IconizedBits);
  243.       BitBlt(PaintDC, 0, 0, Width, Height, MemDC, 0, 0, SRCCopy);
  244.     end
  245.     else
  246.     begin
  247.       SelectObject(MemDC, BitMapHandle);
  248.       if Stretch then
  249.       begin
  250.     GetClientRect(HWindow, R);
  251.     SetCursor(LoadCursor(0, idc_Wait));
  252.     StretchBlt(PaintDC, 0, 0, R.Right, R.Bottom, MemDC, 0, 0,
  253.       Width, Height, SRCCopy);
  254.     SetCursor(LoadCursor(0, idc_Arrow));
  255.       end
  256.       else
  257.     BitBlt(PaintDC, 0, 0, Width, Height, MemDC, 0, 0, SRCCopy);
  258.     end;
  259.     DeleteDC(MemDC);
  260.   end;
  261. end;
  262.  
  263. procedure TStretchWindow.SetUpWindow;
  264. begin
  265.   TWindow.SetUpWindow;
  266.   Stretch := True;
  267. end;
  268.  
  269. procedure TStretchWindow.SetWindowSize;
  270. const
  271.    MinWindowWidth = 200;
  272. var
  273.   WindowHeight, WindowWidth: LongInt;
  274. begin
  275.   WindowWidth := Width + 2 * GetSystemMetrics(sm_CXFrame);
  276.   if WindowWidth < MinWindowWidth then WindowWidth := MinWindowWidth;
  277.   WindowHeight := Height + 2 * GetSystemMetrics(sm_CYFrame) +
  278.     GetSystemMetrics(sm_CYCaption) + GetSystemMetrics(sm_CYMenu);
  279.   SetWindowPos(HWindow, 0, 0, 0, WindowWidth, WindowHeight, swp_NoMove);
  280. end;
  281.  
  282. procedure TStretchWindow.StretchOption(var Message: TMessage);
  283. begin
  284.   CheckMenuItem(GetMenu(HWindow), idm_Stretch, mf_Checked or mf_ByCommand);
  285.   CheckMenuItem(GetMenu(HWindow), idm_Fixed, mf_UnChecked or mf_ByCommand);
  286.   Stretch := True;
  287.   InvalidateRect(HWindow, nil, False);
  288. end;
  289.  
  290. procedure TStretchWindow.WMSize(var Message: TMessage);
  291. var
  292.   DC, MemDC1, MemDC2: HDC;
  293.   OldBitmap1, OldBitmap2: HBitmap;
  294.   OldCursor: HCursor;
  295. begin
  296.   if not IconImageValid and (Message.wParam = sizeIconic) and
  297.     (BitmapHandle <> 0) then
  298.   begin
  299.     DC := GetDC(HWindow);
  300.     MemDC1 := CreateCompatibleDC(DC);
  301.     MemDC2 := CreateCompatibleDC(DC);
  302.     ReleaseDC(HWindow, DC);
  303.     OldBitmap1 := SelectObject(MemDC1, IconizedBits);
  304.     OldBitmap2 := SelectObject(MemDC2, BitmapHandle);
  305.     OldCursor := SetCursor(LoadCursor(0, idc_Wait));
  306.     StretchBlt(MemDC1, 0, 0, Message.lParamLo, Message.lParamHi, MemDC2,
  307.       0, 0, Width, Height, SrcCopy);
  308.     SetCursor(OldCursor);
  309.     SelectObject(MemDC1, OldBitmap1);
  310.     SelectObject(MemDC2, OldBitmap2);
  311.     DeleteDC(MemDC1);
  312.     DeleteDC(MemDC2);
  313.     IconImageValid := True;
  314.   end;
  315.   InvalidateRect(HWindow, nil, False);
  316. end;
  317.  
  318. { TApp }
  319.  
  320. procedure TApp.InitMainWindow;
  321. begin
  322.   MainWindow := New(PStretchWindow, Init(nil, 'Stretch'));
  323. end;
  324.  
  325. var
  326.   App: TApp;
  327. begin
  328.   App.Init('Stretch');
  329.   App.Run;
  330.   App.Done;
  331. end.
  332.