home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / tpw / owldemos / stretch.pas < prev    next >
Pascal/Delphi Source File  |  1991-05-20  |  10KB  |  334 lines
  1. {************************************************}
  2. {                                                }
  3. {   Turbo Pascal for Windows                     }
  4. {   Demo program                                 }
  5. {   Copyright (c) 1991 by Borland International  }
  6. {                                                }
  7. {************************************************}
  8.  
  9. program Stretch;
  10.  
  11. {$R STRETCH.RES}
  12.  
  13. uses
  14.   WinTypes, WinProcs, WinDos, WObjects, Strings, StdDlgs;
  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.   MemDC: HDC;
  148. begin
  149.   LoadBitmapFile := False;
  150.   Assign(TheFile, Name);
  151.   Reset(TheFile, 1);
  152.   Seek(TheFile, 14);
  153.   BlockRead(TheFile, TestWin30Bitmap, SizeOf(TestWin30Bitmap));
  154.   if TestWin30Bitmap = 40 then
  155.     if OpenDIB(TheFile) then
  156.     begin
  157.       LoadBitmapFile := True;
  158.       IconImageValid := False;
  159.     end
  160.     else
  161.       MessageBox(HWindow, 'Unable to create Windows 3.0 bitmap from file.',
  162.     Name, mb_Ok)
  163.   else
  164.       MessageBox(HWindow, 'Not a Windows 3.0 bitmap file.  Convert using Paintbrush.', Name, mb_Ok);
  165.   Close(TheFile);
  166. end;
  167.  
  168. procedure TStretchWindow.LoadImage(var Message: TMessage);
  169. var
  170.   FileName: array[0..200] of Char;
  171.   CaptionBuffer: array [0..200] of Char;
  172. begin
  173.   if Application^.ExecDialog(New(PFileDialog,
  174.     Init(@Self, PChar(sd_FileOpen),
  175.     StrCopy(FileName, '*.bmp')))) = id_Ok then
  176.     if LoadBitmapFile(FileName) then
  177.       SetWindowSize;
  178.   InvalidateRect(HWindow, nil, False);
  179. end;
  180.  
  181. { Attempt to open a Windows 3.0 device independent bitmap. }
  182. function TStretchWindow.OpenDIB(var TheFile: File): Boolean;
  183. var
  184.   bitCount: Word;
  185.   size: Word;
  186.   longWidth: Longint;
  187.   DCHandle: HDC;
  188.   BitsPtr: Pointer;
  189.   BitmapInfo: PBitmapInfo;
  190.   BitsHandle, NewBitmapHandle: THandle;
  191.   NewPixelWidth, NewPixelHeight: Word;
  192. begin
  193.   OpenDIB := True;
  194.   Seek(TheFile, 28);
  195.   BlockRead(TheFile, bitCount, SizeOf(bitCount));
  196.   if bitCount <= 8 then
  197.   begin
  198.     size := SizeOf(TBitmapInfoHeader) + ((1 shl bitCount) * SizeOf(TRGBQuad));
  199.     BitmapInfo := MemAlloc(size);
  200.     Seek(TheFile, SizeOf(TBitmapFileHeader));
  201.     BlockRead(TheFile, BitmapInfo^, size);
  202.     NewPixelWidth := BitmapInfo^.bmiHeader.biWidth;
  203.     NewPixelHeight := BitmapInfo^.bmiHeader.biHeight;
  204.     longWidth := (((NewPixelWidth * bitCount) + 31) div 32) * 4;
  205.     BitmapInfo^.bmiHeader.biSizeImage := longWidth * NewPixelHeight;
  206.     GlobalCompact(-1);
  207.     BitsHandle := GlobalAlloc(gmem_Moveable or gmem_Zeroinit,
  208.       BitmapInfo^.bmiHeader.biSizeImage);
  209.     GetBitmapData(TheFile, BitsHandle, BitmapInfo^.bmiHeader.biSizeImage);
  210.     DCHandle := CreateDC('Display', nil, nil, nil);
  211.     BitsPtr := GlobalLock(BitsHandle);
  212.     NewBitmapHandle :=
  213.       CreateDIBitmap(DCHandle, BitmapInfo^.bmiHeader, cbm_Init, BitsPtr,
  214.       BitmapInfo^, 0);
  215.     DeleteDC(DCHandle);
  216.     GlobalUnlock(BitsHandle);
  217.     GlobalFree(BitsHandle);
  218.     FreeMem(BitmapInfo, size);
  219.     if NewBitmapHandle <> 0 then
  220.     begin
  221.       if BitmapHandle <> 0 then DeleteObject(BitmapHandle);
  222.       BitmapHandle := NewBitmapHandle;
  223.       Width := NewPixelWidth;
  224.       Height := NewPixelHeight;
  225.     end
  226.     else
  227.       OpenDIB := False;
  228.   end
  229.   else
  230.     OpenDIB := False;
  231. end;
  232.  
  233. procedure TStretchWindow.Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
  234. var
  235.   MemDC: HDC;
  236.   OldBitmap: HBitmap;
  237.   R: TRect;
  238. begin
  239.   if BitMapHandle <> 0 then
  240.   begin
  241.     MemDC := CreateCompatibleDC(PaintDC);
  242.     if IsIconic(HWindow) and IconImageValid then
  243.     begin
  244.       OldBitmap := SelectObject(MemDC, IconizedBits);
  245.       BitBlt(PaintDC, 0, 0, Width, Height, MemDC, 0, 0, SRCCopy);
  246.     end
  247.     else
  248.     begin
  249.       SelectObject(MemDC, BitMapHandle);
  250.       if Stretch then
  251.       begin
  252.     GetClientRect(HWindow, R);
  253.     SetCursor(LoadCursor(0, idc_Wait));
  254.     StretchBlt(PaintDC, 0, 0, R.Right, R.Bottom, MemDC, 0, 0,
  255.       Width, Height, SRCCopy);
  256.     SetCursor(LoadCursor(0, idc_Arrow));
  257.       end
  258.       else
  259.     BitBlt(PaintDC, 0, 0, Width, Height, MemDC, 0, 0, SRCCopy);
  260.     end;
  261.     DeleteDC(MemDC);
  262.   end;
  263. end;
  264.  
  265. procedure TStretchWindow.SetUpWindow;
  266. begin
  267.   TWindow.SetUpWindow;
  268.   Stretch := True;
  269. end;
  270.  
  271. procedure TStretchWindow.SetWindowSize;
  272. const
  273.    MinWindowWidth = 200;
  274. var
  275.   WindowHeight, WindowWidth: LongInt;
  276. begin
  277.   WindowWidth := Width + 2 * GetSystemMetrics(sm_CXFrame);
  278.   if WindowWidth < MinWindowWidth then WindowWidth := MinWindowWidth;
  279.   WindowHeight := Height + 2 * GetSystemMetrics(sm_CYFrame) +
  280.     GetSystemMetrics(sm_CYCaption) + GetSystemMetrics(sm_CYMenu);
  281.   SetWindowPos(HWindow, 0, 0, 0, WindowWidth, WindowHeight, swp_NoMove);
  282. end;
  283.  
  284. procedure TStretchWindow.StretchOption(var Message: TMessage);
  285. begin
  286.   CheckMenuItem(GetMenu(HWindow), idm_Stretch, mf_Checked or mf_ByCommand);
  287.   CheckMenuItem(GetMenu(HWindow), idm_Fixed, mf_UnChecked or mf_ByCommand);
  288.   Stretch := True;
  289.   InvalidateRect(HWindow, nil, False);
  290. end;
  291.  
  292. procedure TStretchWindow.WMSize(var Message: TMessage);
  293. var
  294.   DC, MemDC1, MemDC2: HDC;
  295.   OldBitmap1, OldBitmap2: HBitmap;
  296.   OldCursor: HCursor;
  297. begin
  298.   if not IconImageValid and (Message.wParam = sizeIconic) and
  299.     (BitmapHandle <> 0) then
  300.   begin
  301.     DC := GetDC(HWindow);
  302.     MemDC1 := CreateCompatibleDC(DC);
  303.     MemDC2 := CreateCompatibleDC(DC);
  304.     ReleaseDC(HWindow, DC);
  305.     OldBitmap1 := SelectObject(MemDC1, IconizedBits);
  306.     OldBitmap2 := SelectObject(MemDC2, BitmapHandle);
  307.     OldCursor := SetCursor(LoadCursor(0, idc_Wait));
  308.     StretchBlt(MemDC1, 0, 0, Message.lParamLo, Message.lParamHi, MemDC2,
  309.       0, 0, Width, Height, SrcCopy);
  310.     SetCursor(OldCursor);
  311.     SelectObject(MemDC1, OldBitmap1);
  312.     SelectObject(MemDC2, OldBitmap2);
  313.     DeleteDC(MemDC1);
  314.     DeleteDC(MemDC2);
  315.     IconImageValid := True;
  316.   end;
  317.   InvalidateRect(HWindow, nil, False);
  318. end;
  319.  
  320. { TApp }
  321.  
  322. procedure TApp.InitMainWindow;
  323. begin
  324.   MainWindow := New(PStretchWindow, Init(nil, 'Stretch'));
  325. end;
  326.  
  327. var
  328.   App: TApp;
  329. begin
  330.   App.Init('Stretch');
  331.   App.Run;
  332.   App.Done;
  333. end.
  334.