udemo.pas

Delphi 使用 Mirro driver 编写的屏幕截屏

{=======================================================}
{                                                       }
{     <<Mirro For Delphi>>  Demo － Local Display       }
{                                                       }
{        (c)Copyright 2007,www.jingtaolab.com           }
{                                                       }
{=======================================================}

unit UDemo;

{=======================================================
  Project : <Mirro For Delphi>>  Demo － Local Display
  Module  : Main Form
  Describe: (None)
  Version : 1.0
  Data    : 2005-11-12
  Author  : JingTao Chen,http://www.jingtaolab.com,[e-mail]
  Update  : 2007-11-23
=======================================================}

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls;

const
  WM_CHANGE = WM_USER + 1001;

type
  TFrmMain = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormActivate(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure FormCanResize(Sender: TObject; var NewWidth,
      NewHeight: Integer; var Resize: Boolean);
  private
    { Private declarations }
    procedure OnChange(var Msg: TMessage); message WM_CHANGE;
    procedure OnHScroll(var Msg: TMessage); message WM_HSCROLL;
    procedure OnVScroll(var Msg: TMessage); message WM_VSCROLL;
  public
    { Public declarations }
  end;

var
  FrmMain: TFrmMain;
  g_nWidth, g_nHeight: integer;
  g_nColor: integer = 24;
  g_hCaptureThread: THandle = 0;
  g_bStart: BOOL = False;
  g_bFirst: Bool = True;
  g_pScreenBuf: Pbyte = nil;
  g_BitmapInfo: TBitmapInfo;
  g_nStartX, g_nStartY: integer;

implementation

uses
  Mirro_D7;

{$R *.dfm}

procedure TFrmMain.FormCreate(Sender: TObject);
begin
  g_nStartX := 0;
  g_nStartY := 0;
  ClientWidth := Screen.Width;
  ClientHeight := Screen.Height;
  HorzScrollBar.Range := Screen.Width;
  VertScrollBar.Range := Screen.Height;
  if not MirroDriverIsInstalled then
  begin
    if Application.MessageBox('Mirro Driver is not found in system,Do you want to Install it?', Pchar(Caption), MB_ICONQUESTION + MB_YESNO) = IDNO then
    begin
      Application.Terminate;
      Exit;
    end;

    if not InstallMirroDriver then
    begin
      ShowMessage('Mirro Driver Install Error!');
      Application.Terminate;
      Exit;
    end;
  end;
end;

function MirroCaptureThread(lpParam: Pointer): DWORD; stdcall;
var
  dwType: DWORD;
  MyRect: TRect;
  nNewWidth, nNewHeight: integer;
  pBmpBuf: PByte;
  wp, lp: integer;
begin
  Result := 0;

  pBmpBuf := ptr(GlobalAlloc(GMEM_FIXED, g_nWidth * g_nHeight * g_nColor div 8));
  if pBmpBuf = nil then
  begin
    ShowMessage('Alloc Memory Error!');
    Exit;
  end;

  while g_bStart do
  begin
    if g_bFirst then
    begin
      g_bFirst := False;
      dwType := MirrorGetFullScreen(MyRect, pBmpBuf);
    end
    else
      dwType := MirrorGetChangeInfo(MyRect, pBmpBuf);

    if dwType = CHANGE_NO then
    begin
      Sleep(20);
      Continue;
    end
    else if dwType = CHANGE_SCREEN then
    begin
      // 拷贝到屏幕缓冲
      MirrorUpdateRectToScreen(pBmpBuf, MyRect, g_pScreenBuf, g_nWidth, g_nColor);
      wp := ((MyRect.left) shl 16) or (MyRect.right);
      lp := ((MyRect.top) shl 16) or (MyRect.bottom);
      // 发送窗口消息，刷新变化区域
      PostMessage(FrmMain.Handle, WM_CHANGE, wp, lp);
      sleep(1);
    end
    else if dwType = CHANGE_EXIT then
    begin

      if (MirrorStart(SCREEN_COLOR_24, False, nNewWidth, nNewHeight) <> 0) then
      begin
        ShowMessage('Mirro Driver Init Err!');
        break;
      end;

      if (nNewWidth * nNewHeight * 24 > g_nWidth * g_nHeight * g_nColor) then
      begin
        g_nWidth := nNewWidth;
        g_nHeight := nNewHeight;
        g_nColor := 24;

        if (pBmpBuf <> nil) then
        begin
          GlobalFree(DWORD(pBmpBuf));
          pBmpBuf := nil;
        end;
        pBmpBuf := ptr(GlobalAlloc(GMEM_FIXED, g_nWidth * g_nHeight * g_nColor div 8));
        if (pBmpBuf = nil) then
        begin
          ShowMessage('Alloc Memory Error!');
          break;
        end;

        if (g_pScreenBuf <> nil) then
        begin
          GlobalFree(DWORD(g_pScreenBuf));
          g_pScreenBuf := nil;
        end;
        g_pScreenBuf := ptr(GlobalAlloc(GMEM_FIXED, g_nWidth * g_nHeight * g_nColor div 8));
        if (g_pScreenBuf = nil) then
        begin
          ShowMessage('Alloc Memory Error!');
          break;
        end;
      end;

    end;
  end; //end while

  if (pBmpBuf <> nil) then
  begin
    GlobalFree(DWORD(pBmpBuf));
    pBmpBuf := nil;
  end;

  g_hCaptureThread := 0;
end;

procedure TFrmMain.FormActivate(Sender: TObject);
var
  dwRet, dwID: DWORD;
begin
  OnActivate := nil;
  dwRet := MirrorStart(SCREEN_COLOR_24, False, g_nWidth, g_nHeight);
  if (dwRet <> 0) then
  begin
    ShowMessage(Format('Load Driver Err.ErrCode:0x%X', [dwRet]));
    Exit;
  end;

  ZeroMemory(@g_BitmapInfo, sizeof(TBitmapInfo));
  g_BitmapInfo.bmiHeader.biSize := sizeof(BITMAPINFOHEADER);
  g_BitmapInfo.bmiHeader.biCompression := BI_RGB;
  g_BitmapInfo.bmiHeader.biClrImportant := 0;
  g_BitmapInfo.bmiHeader.biPlanes := 1;
  g_BitmapInfo.bmiHeader.biClrUsed := 0;
  g_BitmapInfo.bmiHeader.biSizeImage := 0;
  g_BitmapInfo.bmiHeader.biWidth := g_nWidth;
  g_BitmapInfo.bmiHeader.biHeight := -g_nHeight;
  g_BitmapInfo.bmiHeader.biBitCount := 24;


  g_pScreenBuf := ptr(GlobalAlloc(GMEM_FIXED, g_nWidth * g_nHeight * g_nColor div 8));
  if g_pScreenBuf = nil then
  begin
    MirrorStop;
    ShowMessage('Alloc Memory Error!');
    Exit;
  end;

  Self.Width := g_nWidth;
  Self.Height := g_nHeight;
  SetForegroundWindow(Handle);

  g_hCaptureThread := CreateThread(nil, 0, @MirroCaptureThread, nil, 0, dwID);
  if g_hCaptureThread = 0 then
  begin
    dwRet := GetLastError();
    MirrorStop;
    ShowMessage(Format('Start Thread Err.ErrCode:%X', [dwRet]));
    Exit;
  end;
  g_bStart := TRUE;
end;

procedure TFrmMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  g_bStart := FALSE;
  if (g_hCaptureThread <> 0) then
  begin
    WaitForSingleObject(g_hCaptureThread, INFINITE);
    CloseHandle(g_hCaptureThread);
    g_hCaptureThread := 0;
  end;
  MirrorStop;
  if g_pScreenBuf <> nil then GlobalFree(DWORD(g_pScreenBuf));
end;

procedure TFrmMain.FormPaint(Sender: TObject);
var
  dc: HDC;
begin
  if (g_pScreenBuf <> nil) then
  begin
    dc := GetDC(Handle);

    SetDIBitsToDevice(dc,
      -g_nStartX,
      -g_nStartY,
      g_nWidth,
      g_nHeight,
      0,
      0,
      0,
      g_nHeight,
      g_pScreenBuf,
      g_BitmapInfo,
      DIB_RGB_COLORS);

    ReleaseDC(Handle, dc);
  end;
end;

procedure TFrmMain.OnChange(var Msg: TMessage);
var
  r: TRect;
begin
  r.left := (Msg.wParam shr 16) - 0;
  r.right := (Msg.wParam and $0000FFFF) - 0;
  r.top := (Msg.lParam shr 16) - 0;
  r.bottom := (Msg.lParam and $0000FFFF) - 0;

  InvalidateRect(Handle, @r, FALSE);
end;

procedure TFrmMain.OnHScroll(var Msg: TMessage);
var
  r: TRect;
begin
  inherited;
  g_nStartX := HorzScrollBar.Position;
  r := ClientRect;
  InvalidateRect(Handle, @r, False);
end;

procedure TFrmMain.OnVScroll(var Msg: TMessage);
var
  r: TRect;
begin
  inherited;
  g_nStartY := VertScrollBar.Position;
  r := ClientRect;
  InvalidateRect(Handle, @r, False);
end;

procedure TFrmMain.FormCanResize(Sender: TObject; var NewWidth,
  NewHeight: Integer; var Resize: Boolean);
var
  r: TRect;
begin
  g_nStartX := HorzScrollBar.Position;
  g_nStartY := VertScrollBar.Position;
  r := ClientRect;
  InvalidateRect(Handle, @r, False);
end;

end.