home *** CD-ROM | disk | FTP | other *** search
/ Mastering Visual Basic 5 / MasteringVisualBasic5.iso / olympus / ik32_15t / delphi2.shr / USCRCAP.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-08-01  |  3.5 KB  |  120 lines
  1. {  Project ScrCap.DPR Delphi 2.0 Demos
  2.  
  3.    Description:- ScrCap.Dpr Project:-
  4.  
  5.    Demonstrates the use of:
  6.  
  7.    1) 'Hdc'
  8.    2) 'BitBlt'
  9.    3) 'TImage'
  10.    4) 'BitmaptoDib'
  11.    5) API calls - GetDC
  12.  
  13.    Date of Origin: 18/04/96
  14.    Original Author: Andrew Hutchison
  15.    Modification History:
  16.  
  17.    Date        Person                            Change
  18.    ----------------------------------------------------
  19.    18/04/96    A Hutchison                       Created
  20.  
  21.    (c) Copyright Media Architects Inc. 1996.
  22.    All rights reserved.   No part of this program may be
  23.    photocopied, reproduced, translated to another programming
  24.    language or transported to any computer system without the
  25.    prior written consent of Media Architects Inc.}
  26.  
  27. unit UScrCap;
  28.  
  29. interface
  30.  
  31. uses
  32.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  33.   Buttons, OleCtrls, ImageKnife32, ExtCtrls, Menus;
  34.  
  35. type
  36.   TForm1 = class(TForm)
  37.     MainMenu1: TMainMenu;
  38.     File1: TMenuItem;
  39.     Exit1: TMenuItem;
  40.     Bevel1: TBevel;
  41.     Picbuf1: TPicbuf;
  42.     CapturePicbuf: TSpeedButton;
  43.     CaptureTImage: TSpeedButton;
  44.     Bevel2: TBevel;
  45.     ScrollBox1: TScrollBox;
  46.     Image: TImage;
  47.     procedure CapturePicbufClick(Sender: TObject);
  48.     procedure CaptureTImageClick(Sender: TObject);
  49.     procedure Exit1Click(Sender: TObject);
  50.     procedure FormCreate(Sender: TObject);
  51.   private
  52.     { Private declarations }
  53.   public
  54.     { Public declarations }
  55.   end;
  56.  
  57. var
  58.   Form1: TForm1;
  59.  
  60. implementation
  61.  
  62. {$R *.DFM}
  63.  
  64.  
  65. {--------------------------------------------------------------------------------}
  66. {Capture the Screen to the Picbuf Control - May Not be Supported under early OCX}
  67. procedure TForm1.CapturePicbufClick(Sender: TObject);
  68. var
  69. hDC,hmemdc,hbitmap,holdbitmap:Integer;
  70. begin
  71. hDC := CreateDC('DISPLAY', nil, nil, nil);
  72. hbitmap := CreateCompatibleBitmap(hDC, 200, 200);
  73. hmemdc := CreateCompatibleDC(hDC);
  74. holdbitmap := SelectObject(hmemdc, hbitmap);
  75. BitBlt(hmemdc, 0, 0, 200, 200, hDC, 0, 0, SRCCOPY);
  76. SelectObject(hmemdc, holdbitmap);
  77. Picbuf1.BitmapToDib(hbitmap);
  78. DeleteObject(hbitmap);
  79. DeleteDC(hDC);
  80. DeleteDC(hmemdc);
  81. end;
  82.  
  83.  
  84. {--------------------------------------------------------------------------------}
  85. {Capture the Screen to a TImage Component. Note the Use of 'GETDC'. If you pass
  86. '0' then the Device Context of your Screen is returned. If you wish to Capture
  87. a Specific Window just pass that Windows Hwnd}
  88. procedure TForm1.CaptureTImageClick(Sender: TObject);
  89. var
  90. HDC:THandle;                                                   {Handle to Bitmap}
  91. begin
  92. Image.Picture.Bitmap.Width:=Screen.Width;       {Set Bitmap to Screen Dimensions}
  93. Image.Picture.Bitmap.Height:=Screen.Height;     {Set Bitmap to Screen Dimensions}
  94. HDC := GetDc(0);                              {Get Handle to DC of Screen Object}
  95. {Use 'BitBlt' to Copy ScreenDC to Timage's Bitmap.Canvas}
  96. BitBlt(Image.Picture.Bitmap.Canvas.Handle, 0, 0,Screen.Width, Screen.Height, HDC,
  97. 0, 0, SRCCOPY);
  98. Image.refresh;                                 {Refresh Image to Paint in Result}
  99. DeleteDC(HDC);                                                         {DeleteDC}
  100. end;
  101.  
  102.  
  103. {-------------------------------------------------------------------------------}
  104. {Exit Application}
  105. procedure TForm1.Exit1Click(Sender: TObject);
  106. begin
  107. Halt;
  108. end;
  109.  
  110.  
  111. {-------------------------------------------------------------------------------}
  112. {Defaults}
  113. procedure TForm1.FormCreate(Sender: TObject);
  114. begin
  115. Application.HintPause:=10;
  116. Application.HintColor:=clAqua;
  117. end;
  118.  
  119. end.
  120.