procedure EmKeyDown(const vk: Cardinal); var Input: TInput; begin with Input, ki do begin Itype := INPUT_KEYBOARD; wVk := vk; time := 0; wScan := 0; dwFlags := 0; dwExtraInfo := GetMessageExtraInfo; end; SendInput(1, Input, sizeof(Input)); end;
procedure EmKeyUp(const vk: Cardinal); var Input: TInput; begin with Input, ki do begin Itype := INPUT_KEYBOARD; wVk := vk; time := 0; wScan := 0; dwFlags := KEYEVENTF_KEYUP; dwExtraInfo := GetMessageExtraInfo; end; SendInput(1, Input, sizeof(Input)); end;
function CreateTask(const FileName: string): Boolean; var Start: TStartupInfo; Process: TProcessInformation; begin FillChar(Start, sizeof(Start), 0); FillChar(Process, sizeof(Process), 0); Start.cb := sizeof(Start); Start.dwX := 0; Start.dwY := 0; Start.dwXSize := 0; Start.dwYSize := 0; Start.wShowWindow := 0; Start.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESIZE or STARTF_USEPOSITION; Result := CreateProcess(PChar(FileName), nil, nil, nil, false, CREATE_DEFAULT_ERROR_MODE, nil, nil, Start, Process); end;
function E(h: HWND; l: Integer): LongBool; stdcall; var Buff: array[0..255] of Char; PWinData: PFindWindowData; begin Result := False; GetWindowText(h, Buff, 255); PWinData := PFindWindowData(l); if AnsiCompareStr(Buff, PWinData.WindowName)=0 then begin PWinData.Wnd := h; Result := false; end; Result := true; end;
function XFindWindow(const WindowName: string; Timeout: Integer): HWND; var h: HWND; WinData: TFindWindowData; TheTime: Cardinal; begin Result := 0; FillChar(WinData, sizeof(WinData), 0); StrLCopy(WinData.WindowName, @WindowName[1], 255); TheTime := GetTickCount; while (Result = 0) and(GetTickCount - TheTime < Timeout)do begin if EnumWindows(@E, Integer(@WinData)) then Result := WinData.Wnd; end; end;
function RegReadString(const Key, Entry: string): string; var Reg: TRegistry; begin Reg := TRegistry.Create; try Reg.RootKey := HKEY_LOCAL_MACHINE; Reg.OpenKey(Key, true); Result := Reg.ReadString(Entry); finally Reg.Free; end; end;
function SetAutorun(AutoRun: Boolean): Boolean; const FileLen = 1024; var Reg: TRegistry; FileName: array[0..FileLen -1] of Char; begin Result := false; GetModuleFileName(0, FileName, FileLen); Reg := TRegistry.Create; try Reg.RootKey := HKEY_LOCAL_MACHINE; Reg.OpenKey(SRunKey, true); if AutoRun then begin Reg.WriteString(SAppName, FileName); Result := true; end else Result := Reg.DeleteValue(SAppName); finally Reg.Free; end; end;
function GetState(Wnd: HWND): Cardinal; begin Result := GetWindowLong(Wnd, GWL_USERDATA); end;
procedure SetState(Wnd: HWND; State: Cardinal); begin SetWindowLong(Wnd, GWL_USERDATA, State); end;
function RunHost(const DefPath: string): HWND; begin Result := XFindWindow(SHostWindowName1, 10); while (Result = 0)do begin if not CreateTask(DefPath) then Exit;
Result := XFindWindow(SHostWindowName, 200); SetWindowPos(Result, 0, -100,-100, 0,0, SWP_HIDEWINDOW);
Result := XFindWindow(SHostWindowName1, 10); SetWindowPos(Result, 0, -100,-100, 0, 0, SWP_HIDEWINDOW);
TMailslot = class private hSlot: THandle; protected destructor Destroy; override; public constructor Create(const Name: string; NewInstance: Boolean = true); public function Read(var Buff; Size: Cardinal): Cardinal; function Write(const Buff: Pointer; Size: Cardinal): Cardinal; function GetMsgLen: Cardinal; end;
{ TMailslots }
constructor TMailslot.Create(const Name: string; NewInstance: Boolean = true); begin if NewInstance then hSlot := CreateMailslot(PChar(Name), 0, MAILSLOT_WAIT_FOREVER, nil) else hSlot := CreateFile(PChar(Name), GENERIC_WRITE, FILE_SHARE_READ, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); end;
destructor TMailslot.Destroy; begin CloseHandle(hSlot); inherited; end;
function TMailslot.GetMsgLen: Cardinal; var Msgs: Cardinal; bRet: LongBool; begin bRet := GetMailslotInfo(hSlot, nil, Result, @Msgs, nil); if Result = MAILSLOT_NO_MESSAGE then Result := 0; end;
function TMailslot.Read(var Buff; Size: Cardinal): Cardinal; begin ReadFile(hSlot, Buff, Size, Result, nil); end;
function TMailslot.Write(const Buff: Pointer; Size: Cardinal): Cardinal; begin WriteFile(hSlot, Buff^, Size, Result, nil); end;
{ TWorker }
constructor TWorker.Create(State: Boolean); begin inherited Create(State); Priority := tpIdle; end;
procedure TWorker.Execute; begin FHostPath := RegReadString(SSettingKey, SSettingHostPath); while not Terminated do try hWnd := RunHost(FHostPath); if hOldWnd <> hWnd then begin hOldWnd := hWnd; ForceCapture; Continue; end;
if cmdSetCapture in FCmds then begin Exclude(FCmds, cmdSetCapture); SetState(hWnd, not (GetState(hWnd) and cCapState)); SetCapture; end;
if cmdForce in FCmds then begin Exclude(FCmds, cmdForce); ForceCapture; end;
if cmdSetCapPath in FCmds then begin Exclude(FCmds, cmdSetCapture); end;
if cmdRestartHost in FCmds then begin Exclude(FCmds, cmdRestartHost); QuitHost; end;
if cmdHide in FCmds then begin Sleep(20); Exclude(FCmds, cmdHide); ShowWindow(hWnd, SW_HIDE); end;
Sleep(100); except end; end;
procedure TWorker.ForceCapture; begin if (GetState(hOldWnd) and cCapState) = 0 then begin SetState(hOldWnd, cCapState); SetCapture; end; end;
procedure TWorker.QuitHost; begin if not IsWindowVisible(hWnd) then SetCapture; PostMessage(hWnd, WM_QUIT, 0, 0); end;
procedure TWorker.SetCapture; begin EmKeyDown(VK_CONTROL); EmKeyDown(VK_MENU); EmKeyDown(VK_LSHIFT); EmKeyDown(VK_F2);
function ParseParam(PCmd, PSwitch: PChar; out Value: string): Boolean; var sPos: Integer; C, P: PChar; begin Result := false; sPos := Pos(PSwitch, PCmd); if sPos = 0 then Exit;
P := PCmd + sPos + 2; while (P^<>#0)and(P^=' ') do Inc(P); C := P; while (C^<>#0)and(C^<>' ') do Inc(C); SetLength(Value, C - P); StrLCopy(PChar(Value), P, C-P); Result := true; end;
procedure ParseCmdLine(var Cmd: TCommand); var P: PChar; Value: string; Size: Cardinal; begin P := GetCommandLine; if Pos('-c', P) > 0 then Cmd.Cmd := cSetCapture;
if Pos('-r', P) > 0 then Cmd.Cmd := Cmd.Cmd or cRestartHost;
if Pos('-x', P) > 0 then Cmd.Cmd := Cmd.Cmd or cExit;
if Pos('-h', P) > 0 then Cmd.Cmd := Cmd.Cmd or cHide;
if Pos('-f', P) > 0 then Cmd.Cmd := Cmd.Cmd or cForce;
if ParseParam(P, '-p', Value) then begin Cmd.Cmd := Cmd.Cmd or cHostPath; RegWriteString(SSettingKey, SSettingHostPath, Value); Size := Length(Value); Move(Size, Cmd.Data, 4); Move(Value[1], Cmd.Data[4], Size); end; end;
procedure TWorker.ResponseCommand(const Cmd: TCommand); function ParseValue: string; var Size: Cardinal; begin Move(Cmd.Data, Size, 4); if Size < CmdDataLen then begin SetLength(Result, Size); Move(Cmd.Data[4], Result[1], Size); end; end; begin if Cmd.Cmd and cSetCapture <> 0 then FCmds := FCmds + [cmdSetCapture];
if Cmd.Cmd and cRestartHost <> 0 then FCmds := FCmds + [cmdRestartHost];
if Cmd.Cmd and cHide <> 0 then FCmds := FCmds + [cmdHide];
if Cmd.Cmd and cForce <> 0 then FCmds := FCmds + [cmdForce];
if Cmd.Cmd and cHostPath <> 0 then begin FHostPath := ParseValue; FCmds := FCmds + [cmdHostPath]; end; end;
var Slot: TMailslot; Worker: TWorker; Cmd: TCommand; FirstInst: Boolean; begin SetAutorun(true); FirstInst := IsFirstInstance; Slot := TMailslot.Create(SServicePipeName, FirstInst);
if FirstInst then begin Worker := TWorker.Create(False); while True do begin if Slot.GetMsgLen > 0 then begin Slot.Read(Cmd, sizeof(Cmd)); Worker.ResponseCommand(Cmd); if Cmd.Cmd and cExit <> 0 then Break; end; Sleep(10); end; Worker.Terminate; Worker.Free; end else begin if ParamCount > 0 then begin ParseCmdLine(Cmd); Slot.Write(@Cmd, sizeof(Slot)); end; end;
