DFMirage Driver delphi 演示实例（高效率抓屏方式）

DFMirage Mirror Driver是TightVNC用来抓屏的驱动，可以获取屏幕的变化区域，效率非常高。这个技术非常适合做远程监控、屏幕录制之类的软件。由于TigntVNC是C++的，对于不熟悉C++的DELPHI fans会有点麻烦。这个实例就是参照TightVNC中的代码翻译过来的，希望大家能用得上。

 

使用前请先安装驱动：
http://demoforge.com/dfmirage.htm

{
DFMirage Driver class for delphi

DFMirage is "cutting edge" video driver mirroring technology for the Windows NT OS family.
It is a driver for a virtual video device managed at the DDML level of the graphics system
that exactly mirrors the drawing operations of one or more physical display devices.
A detailed explanation of how a mirroring video driver works may be found in the Windows DDK.

more information by
http://demoforge.com/dfmirage.htm

by heroyin
E-MAIL: [email protected]
}
unit VideoDriver;

interface

uses
  SysUtils, Windows, Graphics;

const
  ESC_QVI  =  1026;

  MAP1  =  1030;
  UNMAP1  =  1031;
  _TESTMAPPED  = 1051;

  MAXCHANGES_BUF = 20000;

const

  dmf_dfo_IGNORE    = 0;
  dmf_dfo_FROM_SCREEN = 1;
  dmf_dfo_FROM_DIB  = 2;
  dmf_dfo_TO_SCREEN  = 3;

  dmf_dfo_SCREEN_SCREEN  = 11;
  dmf_dfo_BLIT    = 12;
  dmf_dfo_SOLIDFILL  = 13;
  dmf_dfo_BLEND    = 14;
  dmf_dfo_TRANS    = 15;
  dmf_dfo_PLG      = 17;
  dmf_dfo_TEXTOUT    = 18;

  dmf_dfo_Ptr_Engage  = 48;  // point is used with this record
  dmf_dfo_Ptr_Avert  = 49;

  // 1.0.9.0
  // mode-assert notifications to manifest PDEV limbo status
  dmf_dfn_assert_on  = 64;  // DrvAssert(TRUE): PDEV reenabled
  dmf_dfn_assert_off  = 65;  // DrvAssert(FALSE): PDEV disabled


const

  CDS_UPDATEREGISTRY = $00000001;
  CDS_TEST          = $00000002;
  CDS_FULLSCREEN     = $00000004;
  CDS_GLOBAL         = $00000008;
  CDS_SET_PRIMARY    = $00000010;
  CDS_RESET          = $40000000;
  CDS_SETRECT        = $20000000;
  CDS_NORESET        = $10000000;

type
{
typedef BOOL (WINAPI* pEnumDisplayDevices)(PVOID,DWORD,PVOID,DWORD);
typedef LONG (WINAPI* pChangeDisplaySettingsEx)(LPCTSTR, LPDEVMODE, HWND, DWORD, LPVOID);
}
//**********

  PCHANGES_RECORD = ^CHANGES_RECORD;
  CHANGES_RECORD = record
    _type: ULONG;  //screen_to_screen, blit, newcache,oldcache
    rect: TRECT;
    origrect: TRECT;
    point: TPOINT;
    color: ULONG; //number used in cache array
    refcolor: ULONG; //slot used to pase btimap data
  end;

  PCHANGES_BUF = ^CHANGES_BUF;
  CHANGES_BUF = record
     counter: ULONG;
    pointrect: array [0..MAXCHANGES_BUF-1] of CHANGES_RECORD;
  end;

  PGETCHANGESBUF = ^GETCHANGESBUF;
  GETCHANGESBUF = record
    buffer: PCHANGES_BUF;
    Userbuffer: Pointer;
  end;

const
  DMF_PROTO_VER_CURRENT = (1 shl 24) or (2 shl 16) or (0 shl 8) or 0;
  DMF_PROTO_VER_MINCOMPAT = (0 shl 24) or (9 shl 16) or (0 shl 8) or 1;


type
  Esc_dmf_Qvi_IN = record
    cbSize: ULONG;
    app_actual_version: ULONG;
    display_minreq_version: ULONG;
    connect_options: ULONG;    // reserved. must be 0.
  end;

const
  esc_qvi_prod_name_max  = 16;


   ESC_QVI_PROD_MIRAGE  = 'MIRAGE';

type

  Esc_dmf_Qvi_OUT = record
    cbSize: ULONG;
    display_actual_version: ULONG;
    miniport_actual_version: ULONG;
    app_minreq_version: ULONG;
    display_buildno: ULONG;
    miniport_buildno: ULONG;
    prod_name: array [0..esc_qvi_prod_name_max-1] of char;
  end;

//////////
const
//  szDriverString = 'Winvnc Video hook driver';
  szDriverString = 'Mirage Driver';
  szDriverStringAlt = 'DemoForge Mirage Driver';
  szMiniportName = 'dfmirage';


  MINIPORT_REGISTRY_PATH = 'SYSTEM//CurrentControlSet//Hardware Profiles//Current//System//CurrentControlSet//Services';

type
  TVideoDriver = class(TObject)
  private
    FDeviceMode: TDeviceMode;
    m_devname: string;
    m_drv_ver_mj: LongWord;
    m_drv_ver_mn: LongWord;
    m_fDirectAccessInEffect: Boolean;
    m_fHandleScreen2ScreenBlt: Boolean;
    m_fIsActive: Boolean;
    oldCounter: Integer;
  public
    bufdata: GETCHANGESBUF;
    constructor Create;
    destructor Destroy; override;
    function Activate(fForDirectAccess: BOOL; prcltarget: PRect): Boolean;
    function Activate_NT50(fForDirectAccess: BOOL; prcltarget: PRect): Boolean;
    function CheckVersion: Boolean;
    function CreateDeviceKey(szMpName: PChar): HKEY;
    procedure Deactivate;
    procedure Deactivate_NT50;
    function LookupVideoDeviceAlt(szDevStr, szDevStrAlt: PChar; devNum: DWORD; var
        pDd: TDisplayDevice): Boolean;
    function MapSharedbuffers(fForDirectScreenAccess: BOOL): Boolean;
    function TestMapped: Boolean;
    procedure UnMapSharedbuffers;
    property DeviceMode: TDeviceMode read FDeviceMode;
  end;

implementation

uses Math;

const
  ENUM_CURRENT_SETTINGS: DWORD    = DWORD(-1);
  ENUM_REGISTRY_SETTINGS   = -2;


constructor TVideoDriver.Create;
begin
  inherited;
  bufdata.buffer := nil;
  bufdata.Userbuffer := nil;
  m_fIsActive := false;
  m_fDirectAccessInEffect := false;
  m_fHandleScreen2ScreenBlt := false;
  m_devname := '';
  m_drv_ver_mj := 0;
  m_drv_ver_mn := 0;
end;

destructor TVideoDriver.Destroy;
begin
  UnMapSharedbuffers();
  Deactivate();   
  inherited;
end;

function TVideoDriver.CheckVersion: Boolean;
var
  l_gdc: HDC;
  qvi_in: Esc_dmf_Qvi_IN;
  qvi_out: Esc_dmf_Qvi_OUT;
  drvCr: Integer;
begin
  l_gdc := CreateDC(PChar(m_devname), nil, nil, nil);
  if (l_gdc = 0) then
  begin
    Result := False;
    Exit;
  end;

  qvi_in.cbSize := sizeof(qvi_in);
  qvi_in.app_actual_version := DMF_PROTO_VER_CURRENT;
  qvi_in.display_minreq_version := DMF_PROTO_VER_MINCOMPAT;
  qvi_in.connect_options := 0;

  qvi_out.cbSize := sizeof(qvi_out);

  drvCr := ExtEscape(
    l_gdc,
    ESC_QVI,
    sizeof(qvi_in), @qvi_in,
    sizeof(qvi_out), @qvi_out);

  DeleteDC(l_gdc);

  if (drvCr <= 0) then
  begin
    Result := False;
    Exit;
  end;

  m_drv_ver_mj := (qvi_out.display_actual_version shr 24) and $FF;
  m_drv_ver_mn := (qvi_out.display_actual_version shr 16) and $FF;

  Result := True;
end;


function TVideoDriver.LookupVideoDeviceAlt(szDevStr, szDevStrAlt: PChar;
    devNum: DWORD; var pDd: TDisplayDevice): Boolean;
begin
  ZeroMemory(@pDd, sizeof(TDisplayDevice));
  pDd.cb := sizeof(TDisplayDevice);

  while EnumDisplayDevices(nil, devNum, pDd, 0) do
  begin
    if SameText(pDd.DeviceString, szDevStr) or
      ((szDevStrAlt <> nil) and SameText(pDd.DeviceString, szDevStrAlt)) then
    begin
      Result := True;
      Exit;
    end;
    Inc(devNum);
  end;

  Result := False;
end;

function TVideoDriver.MapSharedbuffers(fForDirectScreenAccess: BOOL): Boolean;
var
  l_gdc: HDC;
  drvCr: Integer;
begin
  l_gdc := CreateDC(PChar(m_devname), nil, nil, nil);
  if (l_gdc = 0) then
  begin
    Result := False;
    Exit;
  end;

  oldCounter := 0;
  drvCr := ExtEscape(
    l_gdc,
    MAP1,
    0, nil,
    sizeof(GETCHANGESBUF), @bufdata);
  DeleteDC(l_gdc);

  if (drvCr <= 0) then
  begin
    Result := False;
    Exit;
  end;

  m_fIsActive := true;

  if (fForDirectScreenAccess) then
  begin
    if (bufdata.Userbuffer = nil) then
    begin
      Result := False;
      Exit;
    end;
    m_fDirectAccessInEffect := true;
  end else
  begin
    if (bufdata.Userbuffer <> nil) then
    begin
    end;
  end;

// Screen2Screen support added in Mirage ver 1.2
  m_fHandleScreen2ScreenBlt := (m_drv_ver_mj > 1) or
    ((m_drv_ver_mj = 1) and (m_drv_ver_mn >= 2));

  Result := True;  
end;

function TVideoDriver.TestMapped: Boolean;
var
  pDevName: PChar;
  dd: TDisplayDevice;
  devNum: Integer;
  l_ddc: HDC;
begin
  devNum := 0;
  if (not LookupVideoDeviceAlt(szDriverString, szDriverStringAlt, devNum, dd)) then
  begin
    Result := False;
    Exit;
  end;

  pDevName := dd.DeviceName;

  l_ddc := CreateDC(pDevName, nil, nil, nil);
  if (l_ddc <> 0) then
  begin
    Result := ExtEscape(l_ddc, _TESTMAPPED, 0, nil, 0, nil) <> 0;
    DeleteDC(l_ddc);
  end else
    Result := False;
end;

procedure TVideoDriver.UnMapSharedbuffers;
var
  DrvCr: Integer;
  l_gdc: HDC;
begin
  DrvCr := 0;
  if (m_devname <> '') then
  begin
    l_gdc  := CreateDC(PChar(m_devname), nil, nil, nil);
    if (l_gdc <> 0) then
    begin
      DrvCr := ExtEscape(
        l_gdc,
        UNMAP1,
        sizeof(GETCHANGESBUF), @bufdata,
        0, nil);
      DeleteDC(l_gdc);
    end;
  end;
// 0 return value is unlikely for Mirage because its DC is independent
// from the reference device;
// this happens with Quasar if its mode was changed externally.
// nothing is particularly bad with it.

  if (DrvCr <= 0) then
  begin
    if (bufdata.buffer <> nil) then
    begin
      UnmapViewOfFile(bufdata.buffer);
    end;
    if (bufdata.Userbuffer <> nil) then
    begin
      UnmapViewOfFile(bufdata.Userbuffer);
    end;
  end;
  m_fIsActive := false;
  m_fDirectAccessInEffect := false;
  m_fHandleScreen2ScreenBlt := false;
end;

function TVideoDriver.CreateDeviceKey(szMpName: PChar): HKEY;
var
  hKeyProfileMirror, hKeyProfileMp, hKeyDevice: HKEY;
  cr: DWORD;
begin
  hKeyProfileMirror := 0;
  if (RegCreateKey(
      HKEY_LOCAL_MACHINE,
      (MINIPORT_REGISTRY_PATH),
      hKeyProfileMirror) <> ERROR_SUCCESS) then
  begin
    Result := 0;
    Exit;
  end;

  hKeyProfileMp := 0;
  cr := RegCreateKey(
      hKeyProfileMirror,
      szMpName,
      hKeyProfileMp);
  RegCloseKey(hKeyProfileMirror);
  if (cr <> ERROR_SUCCESS) then
  begin
    Result := 0;
    Exit;
  end;

  hKeyDevice := 0;
  if (RegCreateKey(
      hKeyProfileMp,
      ('DEVICE0'),
      hKeyDevice) <> ERROR_SUCCESS) then
  begin
//    Result := 0;
//    Exit;
  end;

  RegCloseKey(hKeyProfileMp);
  Result := hKeyDevice;
end;

function TVideoDriver.Activate(fForDirectAccess: BOOL; prcltarget: PRect):
    Boolean;
begin
  Result := Activate_NT50(fForDirectAccess, prcltarget);
end;

procedure TVideoDriver.Deactivate;
begin
  Deactivate_NT50();
end;

function TVideoDriver.Activate_NT50(fForDirectAccess: BOOL; prcltarget: PRect):
    Boolean;
var
  hdeskInput, hdeskCurrent: HDESK;
  dd: TDisplayDevice;
  devNum: Integer;
  devmode: TDeviceMode;
  hKeyDevice: HKEY;
  dwVal: DWORD;
begin
  devNum := 0;

  if (not LookupVideoDeviceAlt(szDriverString, szDriverStringAlt, devNum, dd)) then
  begin
    Result := False;
    Exit;
  end;

  FillMemory(@devmode, sizeof(TDeviceMode), 0);
  devmode.dmSize := sizeof(TDeviceMode);
  devmode.dmDriverExtra := 0;
  EnumDisplaySettings(nil, ENUM_CURRENT_SETTINGS, devmode);
  devmode.dmFields := DM_BITSPERPEL or DM_PELSWIDTH or DM_PELSHEIGHT;
  if (prcltarget <> nil) then
  begin
// we always have to set position or
// a stale position info in registry would come into effect.
    devmode.dmFields := devmode.dmFields or DM_POSITION;
    PPoint(@devmode.dmOrientation)^.x := prcltarget.left;
    PPoint(@devmode.dmOrientation)^.y := prcltarget.top;

    devmode.dmPelsWidth := prcltarget.right - prcltarget.left;
    devmode.dmPelsHeight := prcltarget.bottom - prcltarget.top;
  end;

  FillChar(devmode.dmDeviceName, Length(devmode.dmDeviceName), 0);

  
  hKeyDevice := CreateDeviceKey(szMiniportName);
  if (hKeyDevice = 0) then
  begin
    Result := False;
    Exit;
  end;

// TightVNC does not use these features
  RegDeleteValue(hKeyDevice, ('Screen.ForcedBpp'));
  RegDeleteValue(hKeyDevice, ('Pointer.Enabled'));

  dwVal := IfThen(fForDirectAccess, 3, 0);
// NOTE that old driver ignores it and mapping is always ON with it
  if (RegSetValueEx(
      hKeyDevice,
      ('Cap.DfbBackingMode'),
      0,
      REG_DWORD,
      @dwVal,
      4) <> ERROR_SUCCESS) then
  begin
    Result := False;
    Exit;
  end;

  dwVal := 1;
  if (RegSetValueEx(
    hKeyDevice,
    ('Order.BltCopyBits.Enabled'),
    0,
    REG_DWORD,
    @dwVal,
    4) <> ERROR_SUCCESS) then
  begin
    Result := False;
    Exit;
  end;

  dwVal := 1;
  if (RegSetValueEx(
      hKeyDevice,
      ('Attach.ToMyDesktop'),
      0,
      REG_DWORD,
      @dwVal,
      4) <> ERROR_SUCCESS) then
  begin
    Result := False;
    Exit;
  end;

{  dwVal := 16;
  if (RegSetValueEx(
      hKeyDevice,
      ('Screen.ForcedBpp'),
      0,
      REG_DWORD,
      @dwVal,
      4) <> ERROR_SUCCESS) then
  begin
    Result := False;
    Exit;
  end;   }

{  pChangeDisplaySettingsEx pCDS = NULL;
  HINSTANCE  hInstUser32 = LoadNImport("User32.DLL", "ChangeDisplaySettingsExA", pCDS);
  if (!hInstUser32) return FALSE;   }

  // Save the current MyDesktop
  hdeskCurrent := GetThreadDesktop(GetCurrentThreadId());
  hdeskInput := 0;
  if (hdeskCurrent <> 0) then
  begin
    hdeskInput := OpenInputDesktop(0, FALSE, MAXIMUM_ALLOWED);
    if (hdeskInput <> 0) then
      SetThreadDesktop(hdeskInput);
  end;
// 24 bpp screen mode is MUNGED to 32 bpp.
// the underlying buffer format must be 32 bpp.
// see MyDesktop::ThunkBitmapInfo()
  if (devmode.dmBitsPerPel = 24) then devmode.dmBitsPerPel := 32;

  ChangeDisplaySettingsEx(          
    dd.DeviceName,
    devmode,
    0,
    CDS_UPDATEREGISTRY, nil);

  FDeviceMode := devmode;

  m_devname := dd.DeviceName;

  // Reset MyDesktop
  SetThreadDesktop(hdeskCurrent);
  // Close the input MyDesktop
  if hdeskInput <> 0 then
    CloseDesktop(hdeskInput);
    
  RegCloseKey(hKeyDevice);

  Result := True;
end;

procedure TVideoDriver.Deactivate_NT50;
var
  hdeskInput, hdeskCurrent: HDESK;
  dd: TDisplayDevice;
  devNum: Integer;
  devmode: TDeviceMode;
  one: DWORD;
  hKeyDevice: HKEY;
begin
// it is important to us to be able to deactivate
// even what we have never activated. thats why we look it up, all over
//  if (!m_devname[0])
//    return;
// ... and forget the name
  m_devname := '';

  devNum := 0;
  if (not LookupVideoDeviceAlt(szDriverString, szDriverStringAlt, devNum, dd)) then
  begin
    Exit;
  end;

  FillMemory(@devmode, sizeof(TDeviceMode), 0);
  devmode.dmSize := sizeof(TDeviceMode);
  devmode.dmDriverExtra := 0;
  EnumDisplaySettings(nil, ENUM_CURRENT_SETTINGS, devmode);
  devmode.dmFields := DM_BITSPERPEL or DM_PELSWIDTH or DM_PELSHEIGHT;
  devmode.dmDeviceName[0] := #0;

  hKeyDevice := CreateDeviceKey(szMiniportName);
  if hKeyDevice = 0 then Exit;

  one := 0;
  RegSetValueEx(hKeyDevice, 'Attach.ToMyDesktop', 0, REG_DWORD, @one,4);

// reverting to default behavior
  RegDeleteValue(hKeyDevice, 'Cap.DfbBackingMode');
  RegDeleteValue(hKeyDevice, 'Order.BltCopyBits.Enabled');

  // Save the current MyDesktop
  hdeskCurrent := GetThreadDesktop(GetCurrentThreadId());
  hdeskInput := 0;
  if (hdeskCurrent <> 0) then
  begin
    hdeskInput := OpenInputDesktop(0, FALSE, MAXIMUM_ALLOWED);
    if (hdeskInput <> 0) then
      SetThreadDesktop(hdeskInput);
  end;
// 24 bpp screen mode is MUNGED to 32 bpp. see MyDesktop::ThunkBitmapInfo()
  if (devmode.dmBitsPerPel = 24) then devmode.dmBitsPerPel := 32;

  // Add 'Default.*' settings to the registry under above hKeyProfile/mirror/device
  ChangeDisplaySettingsEx(dd.DeviceName, devmode, 0, CDS_UPDATEREGISTRY, nil);

  // Reset MyDesktop
  SetThreadDesktop(hdeskCurrent);
  // Close the input MyDesktop
  if hdeskInput <> 0 then
    CloseDesktop(hdeskInput);
  RegCloseKey(hKeyDevice);
end;

end.