注册 登录  
 加关注
   显示下一条  |  关闭
温馨提示!由于新浪微博认证机制调整,您的新浪微博帐号绑定已过期,请重新绑定!立即重新绑定新浪微博》  |  关闭

BCB-DG's Blog

...

 
 
 

日志

 
 

Delphi的TService的輸入桌面切換  

2008-03-13 20:33:59|  分类: Delphi |  标签: |举报 |字号 订阅

  下载LOFTER 我的照片书  |

 

dfm:

object CopyDeskService: TCopyDeskService
  OldCreateOrder = False
  OnCreate = ServiceCreate
  OnDestroy = ServiceDestroy
  AllowPause = False
  DisplayName = 'Copy Desk Service'
  Interactive = True
  Left = 192
  Top = 107
  Height = 150
  Width = 215
end

pas:

unit Main;

interface

uses
  Windows, SysUtils, Classes, Graphics, SvcMgr;

type
  TCopyThread = class(TThread)
  private
    FIndex: DWORD;
    FScrBmp: TBitmap;
  protected
    procedure Execute; override;
  public
    constructor Create; reintroduce;
    destructor Destroy; override;
  end;

  TCopyDeskService = class(TService)
    procedure ServiceCreate(Sender: TObject);
    procedure ServiceDestroy(Sender: TObject);
  private
    FCopyThread: TCopyThread;
  public
    function GetServiceController: TServiceController; override;
  end;

var
  CopyDeskService: TCopyDeskService;

implementation

{$R *.DFM}

procedure ServiceController(CtrlCode: DWord); stdcall;
begin
  CopyDeskService.Controller(CtrlCode);
end;

function TCopyDeskService.GetServiceController: TServiceController;
begin
  Result := ServiceController;
end;

procedure TCopyDeskService.ServiceCreate(Sender: TObject);
begin
  FCopyThread := TCopyThread.Create;
end;

procedure TCopyDeskService.ServiceDestroy(Sender: TObject);
begin
  FCopyThread.Terminate;
end;

function SelectHDESK(HNewDesk: HDESK): Boolean; stdcall;
var
  HOldDesk: HDESK;
  dwDummy:  DWORD;
  sName:    array[0..255] of Char;
begin
 Result := False;
  HOldDesk := GetThreadDesktop(GetCurrentThreadId);
  if (not GetUserObjectInformation(HNewDesk, UOI_NAME, @sName[0], 256, dwDummy)) then
  begin
    OutputDebugString('GetUserObjectInformation Failed.');
    Exit;
  end;
  if (not SetThreadDesktop(HNewDesk)) then
  begin
    OutputDebugString('SetThreadDesktop Failed.');
    Exit;
  end;
  if (not CloseDesktop(HOldDesk)) then
  begin
    OutputDebugString('CloseDesktop Failed.');
    Exit;
  end;
  Result := True;
end;

function SelectDesktop(pName: PChar): Boolean; stdcall;
var
  HDesktop: HDESK;
begin
  Result := False;
  if Assigned(pName) then
    HDesktop := OpenDesktop(pName, 0, False,
                          DESKTOP_CREATEMENU or DESKTOP_CREATEWINDOW or
                          DESKTOP_ENUMERATE or DESKTOP_HOOKCONTROL or
                          DESKTOP_WRITEOBJECTS or DESKTOP_READOBJECTS or
                          DESKTOP_SWITCHDESKTOP or GENERIC_WRITE)
  else
    HDesktop := OpenInputDesktop(0, False,
                          DESKTOP_CREATEMENU or DESKTOP_CREATEWINDOW or
                          DESKTOP_ENUMERATE or DESKTOP_HOOKCONTROL or
                          DESKTOP_WRITEOBJECTS or DESKTOP_READOBJECTS or
                          DESKTOP_SWITCHDESKTOP or GENERIC_WRITE);
  if (HDesktop = 0) then
  begin
    OutputDebugString(PChar('Get Desktop Failed: ' + IntToStr(GetLastError)));
    Exit;
  end;
  Result := SelectHDESK(HDesktop);
end;

function InputDesktopSelected: Boolean; stdcall;
var
  HThdDesk: HDESK;
  HInpDesk: HDESK;
  dwError:  DWORD;
  dwDummy:  DWORD;
  sThdName: array[0..255] of Char;
  sInpName: array[0..255] of Char;
begin
  Result := False;
  HThdDesk := GetThreadDesktop(GetCurrentThreadId);
  HInpDesk := OpenInputDesktop(0, False,
                          DESKTOP_CREATEMENU or DESKTOP_CREATEWINDOW or
                          DESKTOP_ENUMERATE or DESKTOP_HOOKCONTROL or
                          DESKTOP_WRITEOBJECTS or DESKTOP_READOBJECTS or
                          DESKTOP_SWITCHDESKTOP);
  if (HInpDesk = 0) then
  begin
    OutputDebugString('OpenInputDesktop Failed.');
    dwError := GetLastError;
    Result := (dwError = 170);
    Exit;
  end;
  if (not GetUserObjectInformation(HThdDesk, UOI_NAME, @sThdName[0], 256, dwDummy)) then
  begin
    OutputDebugString('GetUserObjectInformation HThdDesk Failed.');
    CloseDesktop(HInpDesk);
    Exit;
  end;
  if (not GetUserObjectInformation(HInpDesk, UOI_NAME, @sInpName[0], 256, dwDummy)) then
  begin
    OutputDebugString('GetUserObjectInformation HInpDesk Failed.');
    CloseDesktop(HInpDesk);
    Exit;
  end;
  CloseDesktop(HInpDesk);
  Result := (lstrcmp(sThdName, sInpName) = 0);
end;

procedure CopyScreen(Bmp: TBitmap; out Index: DWORD);
var
  DC: HDC;
begin
  DC := GetDC(0);
  Bmp.Width  := GetSystemMetrics(SM_CXSCREEN);
  Bmp.Height := GetSystemMetrics(SM_CYSCREEN);
  Bmp.Canvas.Lock;
  try
    BitBlt(Bmp.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, DC, 0, 0, SRCCOPY);
    Bmp.SaveToFile('j:\p' + IntToStr(Index) + '.bmp');
    Inc(Index);
  finally
    Bmp.Canvas.Unlock;
    ReleaseDC(0, DC);
  end;
end;

constructor TCopyThread.Create;
begin
  FreeOnTerminate := True;
  FScrBmp := TBitmap.Create;
  FScrBmp.PixelFormat := pf8bit;
  FIndex := 0;
  inherited Create(False);
end;

destructor TCopyThread.Destroy;
begin
  FScrBmp.Free;
  FScrBmp := nil;
  inherited;
end;

procedure TCopyThread.Execute;
begin
  while (not Terminated) do
  begin
    if InputDesktopSelected then CopyScreen(FScrBmp, FIndex)
    else if SelectDesktop(nil) then CopyScreen(FScrBmp, FIndex);
    Sleep(3000);
  end;
end;

end.

  评论这张
 
阅读(1397)| 评论(0)
推荐 转载

历史上的今天

评论

<#--最新日志,群博日志--> <#--推荐日志--> <#--引用记录--> <#--博主推荐--> <#--随机阅读--> <#--首页推荐--> <#--历史上的今天--> <#--被推荐日志--> <#--上一篇,下一篇--> <#-- 热度 --> <#-- 网易新闻广告 --> <#--右边模块结构--> <#--评论模块结构--> <#--引用模块结构--> <#--博主发起的投票-->
 
 
 
 
 
 
 
 
 
 
 
 
 
 

页脚

网易公司版权所有 ©1997-2017