home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Softwarová Záchrana 3
/
Softwarova-zachrana-3.bin
/
ArsClip
/
source.zip
/
UnitArsClip.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
2002-03-08
|
25KB
|
853 lines
unit UnitArsClip;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Clipbrd, Menus, StrUtils, ShellAPI, ExtCtrls;
const MY_WM_TRAYICON = WM_USER + 1; // used to receive tray icon messsages
type
TForm1 = class(TForm)
Memo1: TMemo;
lbQueue: TListBox;
btnHide: TButton;
Image1: TImage;
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure btnHideClick(Sender: TObject);
private
{ Private declarations }
HotKeyForeWindow: cardinal; {target window for text pasting}
HotKeyTarget: cardinal; {target control with keyboard focus}
NextHandle: THandle; {clipboard chain pointer}
Popup: TPopupMenu; {text pasting popup}
TrayPopup: TPopupMenu; {tray icon's popup}
QueueSize: integer; {number of clipboard items to store}
LastStringSelected: string; {last selected queue item from Popup}
TrayIcon: TNotifyIconData; {tray icon info}
ThreadOurs: cardinal; {Used soley by ThreadAttach/Detach}
ThreadTarget: cardinal;
ThreadAttached: boolean;
IgnoreClipboard: boolean; {altered by public interface}
DisableMonitoring: boolean;
PopupUseKB: boolean;
UsePermanentItems: boolean;
UseKeyboardMimic: boolean;
PasteHandle : THandle;
function ThreadAttach(TargetWindow: cardinal) : boolean;
procedure ThreadDetach();
procedure GetTargetControl(ParentWindow: cardinal;
var TargetHandle: cardinal;
var TargetX: integer;
var TargetY: integer);
procedure ShowPopup(X,Y: integer);
procedure MenuItemClickEvent(Sender: TObject);
procedure LastMenuItemClickEvent(Sender: TObject);
procedure CancelMenuItemClickEvent(Sender: TObject);
procedure PermanentMenutItemClickEvent(sender: TObject);
procedure SendText(s : string);
procedure AppendLog(s : string);
protected
public
{public declarations}
{configuration}
procedure PopupUseKeyboard(usekb: boolean);
procedure SetQueueSize(qsize: integer);
procedure SetMonitoring(disable: boolean);
procedure SetPermanentItems(DoUse: boolean);
procedure SetPasteMethod(MimicKeyboard : boolean);
{windows messages}
procedure WMDRAWCLIPBOARD(var Message: TMessage); message WM_DRAWCLIPBOARD;
procedure WMCHANGECBCHAIN(var Message: TMessage); message WM_CHANGECBCHAIN;
{system tray stuff}
procedure WMHotKey(var Msg : TWMHotKey); message WM_HOTKEY;
procedure WMTrayIcon(var Msg: TMessage); message MY_WM_TRAYICON;
procedure ExitMenuItemClickEvent(Sender: TObject);
procedure SwitchMenuItemClickEvent(sender : TOBject);
procedure SwithPermFolder(sender : TObject);
procedure ConfigureMenuItemClickEven(Sender : TObject);
procedure FlushHistoryMenuItemClickEvent(sender : TObject);
end;
var
Form1: TForm1;
implementation
uses UnitFrmConfig, UnitFrmPermanent;
{$R *.dfm}
{
--========================
-- // Public Interface //
--========================
}
procedure TForm1.PopupUseKeyboard(usekb: boolean);
begin
self.PopupUseKB := usekb;
end;
procedure TForm1.SetQueueSize(qsize: integer);
begin
self.QueueSize := qsize;
while lbqueue.Count > qsize do
lbqueue.Items.Delete(lbqueue.Count - 1);
end;
procedure Tform1.SetMonitoring(disable: boolean);
begin
self.DisableMonitoring := disable;
end;
procedure TForm1.SetPermanentItems(DoUse: boolean);
begin
self.UsePermanentItems := douse;
end;
procedure TForm1.SetPasteMethod(MimicKeyboard : boolean);
begin
UseKeyboardMimic := MimicKeyboard;
end;
{
--========================
-- // Set/Release Hooks //
--========================
Description: Monitor the clipboard, assign a hotkey, show our tray icon,
and ready our programmatically created popup menus. Also, release all of these
resources on form close.
}
procedure TForm1.FormCreate(Sender: TObject);
begin
//
//Join the cliboard chain
//
NextHandle := Windows.SetClipboardViewer(self.Handle);
//
// Create System Tray Icon
// Set the callback hook to our icon handler
//
TrayIcon.cbSize := SizeOf(TrayIcon);
TrayIcon.Wnd := Self.Handle;
TrayIcon.uID := 0;
TrayIcon.uFlags := NIF_ICON or NIF_TIP or NIF_MESSAGE;
TrayIcon.uCallbackMessage := MY_WM_TRAYICON;
TrayIcon.hIcon := Application.Icon.Handle;
TrayIcon.szTip := 'ArsClip';
ShellAPI.Shell_notifyIcon(NIM_ADD, @TrayIcon);
//
// popup & menu items init
//
self.ShowHint := true;
Popup := TPopupMenu.Create(self);
TrayPopup := TPopupMenu.Create(self);
//QueueSize := 15;
ThreadAttached := false;
UseKeyboardMimic := false;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
//
// clean up popup resources
//
TrayPopup.Items.Clear;
TrayPopup.Free;
Popup.Items.Clear;
Popup.Free;
//
// Remove tray icon
//
ShellAPI.Shell_notifyIcon(NIM_DELETE, @TrayIcon);
//
//Leave the chain
//
Windows.ChangeClipboardChain(Handle, // our handle to remove
NextHandle ); // handle of next window in the chain
end;
{
--========================
-- // Trayicon messages //
--========================
Description: On a right click on the tray icon, present a popup menu
that allows the user to
close the program
call up the permanent items form
}
procedure TForm1.WMTrayIcon(var Msg: TMessage);
var menu: TMenuItem;
submenu : TMenuItem;
CursorPos : TPoint;
i : integer;
lib : cardinal;
stm : TMemoryStream;
begin
//
// show exit popup on a right click
//
if (Msg.lparam = WM_Rbuttondown) then begin
AppendLog('WMTrayIcon right button ' + IntToStr(msg.Msg));
Windows.GetCursorPos(CursorPos);
TrayPopup.Items.Clear;
TrayPopup.AutoHotkeys := maAutomatic;
menu := TMenuItem.Create(TrayPopup);
menu.caption := '&Configure';
menu.OnClick := self.ConfigureMenuItemClickEven;
image1.Picture.Icon := application.Icon;
menu.Bitmap.pixelformat := pf24bit;
menu.Bitmap.Width := application.Icon.Width;
menu.Bitmap.Height := application.Icon.Height;
menu.Bitmap.Canvas.draw(0,0, image1.Picture.Graphic);
TrayPopup.Items.Add(menu);
TrayPopup.Items.Add(NewLine());
menu := TMenuItem.Create(TrayPopup);
menu.Caption := '&Permanent Items';
menu.OnClick := self.SwitchMenuItemClickEvent;
TrayPopup.Items.Add(menu);
TrayPopup.Items.Add(NewLine());
menu := TMenuItem.Create(TrayPopup);
menu.Caption := '&Switch to...';
TrayPopup.Items.Add(NewLine());
for i := 0 to frmPermanent.PermFoldersGetCount - 1 do begin
submenu := TMenuItem.Create(menu);
submenu.Caption := frmPermanent.PermFoldersGetItem(i);
submenu.hint := submenu.caption;
submenu.OnClick := self.SwithPermFolder;
menu.Insert(i, submenu)
end;
TrayPopup.Items.Add(menu);
menu := TMenuItem.Create(TrayPopup);
menu.Caption := '&Flush History';
menu.OnClick := self.FlushHistoryMenuItemClickEvent;
TrayPopup.Items.Add(menu);
TrayPopup.Items.Add(NewLine());
menu := TMenuItem.Create(TrayPopup);
menu.caption := '&Exit';
menu.OnClick := self.ExitMenuItemClickEvent;
TrayPopup.Items.Add(menu);
AppendLog('tray popup');
Windows.SetForegroundWindow(self.handle);
TrayPopup.Popup(CursorPos.x, CursorPos.y);
Windows.PostMessage(self.Handle, WM_NULL, 0, 0);
AppendLog('tray popup done');
end else if (msg.LParam = WM_LBUTTONDBLCLK ) then begin
//
// show configuration form on a left double click
//
frmconfig.show();
end else if (msg.LParam = WM_RBUTTONDBLCLK ) then begin
//
// show/hide debug window on right double click
//
self.Visible := self.Visible xor true;
end;
end;
{
// menu item clicks
}
procedure TForm1.ExitMenuItemClickEvent(Sender: TObject);
begin
// End the program nicely
self.Close;
end;
procedure TForm1.SwitchMenuItemClickEvent(sender : TOBject);
begin
frmPermanent.Show;
end;
procedure TForm1.ConfigureMenuItemClickEven(Sender : TObject);
begin
frmConfig.Show;
end;
procedure TForm1.SwithPermFolder(sender : TObject);
begin
with sender as TMenuItem do begin
frmPermanent.SetPermanentPath( hint );
end;
end;
procedure TForm1.FlushHistoryMenuItemClickEvent(sender : TObject);
begin
self.lbQueue.items.clear;
end;
{
--=========================
-- // Clipboard messages //
--=========================
Description: Monitor for new text entries entered into the clipboard. Add
new text entries into the finite sized queue (removing oldest items as needed).
Also, follow the rule for a change in the clipboard chain.
}
procedure TForm1.WMDRAWCLIPBOARD(var Message: TMessage);
var s: string;
i: integer;
dupFound: boolean;
label exit_code;
function GetClipboardText: string;
var hnd: THandle;
p: ^string;
begin
result := '';
try
if clipboard.HasFormat(CF_TEXT) then begin
if (Windows.OpenClipboard(Application.Handle)) then begin
hnd := Windows.GetClipboardData(CF_TEXT);
if (hnd <> 0) then begin
result := PChar(hnd);
end;
Windows.CloseClipboard;
end;
end;
finally
end;
end;
begin
AppendLog('//// Clipboard Start ////');
//
// disabled?
// Ignore the clipboard for now?
//
if (DisableMonitoring) then begin
AppendLog(' Monitoring disabled');
goto exit_code;
end;
if (IgnoreClipboard) then begin
AppendLog(' Ignoring data when sending text to target control');
goto exit_code;
end;
IgnoreClipboard := true;
//
// If I don't ignore another message, I'll get a "can't open clipboard"
// error because of an async call.
// This happens when text is selected in an Outlook email, copied, not unselected,
// and another email is selected or opened.
// Damn hard to find bug!!!
//
// make sure the data isn't from us
//
if GetClipboardOwner = self.Handle then begin
AppendLog(' Ignore our own clipboard events');
goto exit_code;
end;
//
// Clipboard contents have changed
// Add to start of queue
//
appendlog(' WM_DRawclipboard message');
appendlog(
' # = ' + IntToStr(message.msg) +
' lparam = ' + IntToStr(message.LParam) +
' wparam = ' + IntToStr(message.WParam)
);
//
// Copy the contents if it is text
//
try
// open/close should'n't be needed here
//clipboard.Open();
AppendLog(' Attempting to retrieve clipboard text');
s := GetClipboardText;
if (s <> '') then begin
dupFound := false;
for i := 0 to lbQueue.count - 1 do begin
if (s = lbQueue.items[i]) then dupfound := true;
end;
if not DupFound then begin
AppendLog(' clipboard text = ' + s);
lbqueue.Items.Insert(0, s);
// trim the queue size, dup oldest entry
if (lbQueue.items.Count = QueueSize) then lbQueue.items.Delete(lbqueue.count - 1);
end else begin
AppendLog(' Ignoring duplicate');
end;
end else begin
AppendLog(' Empty string in clipboard or error retreiving text.');
end;
finally
//clipboard.Close();
end;
exit_code:
// Pass message to next in line (rules of a cliboard viewer)
Message.Result := 0;
If (NextHandle <> 0) then begin
Windows.SendMessage(NextHandle, WM_DRAWCLIPBOARD, message.WParam, message.LParam )
end;
AppendLog('//// Clipboard End ////');
IgnoreClipboard := false;
end;
procedure TForm1.WMCHANGECBCHAIN(var Message: TMessage);
begin
//
//Someone is leaving the chain
//
{ MS Documentation...
When a clipboard viewer window receives the WM_CHANGECBCHAIN message,
it should call the SendMessage function to pass the message to the
next window in the chain, unless the next window is the window being
removed. In this case, the clipboard viewer should save the handle
specified by the lParam parameter as the next window in the chain.
}
if (Message.WParam = NextHandle) then begin
AppendLog('WM_Changecbchain - reassign next handle');
NextHandle := Message.LParam;
end else if (NextHandle <> 0) then begin
AppendLog('WM_Changecbchain - send message to next handle');
if NextHandle <> 0 then
sendmessage(NextHandle,
WM_CHANGECBCHAIN,
Message.WParam, // handle of window to remove
Message.LParam); // handle of next window
end;
Message.Result := 0;
end;
{
--======================
-- // HotKey Message //
--======================
Description: Determine the control with keyboard focus at the time the
hot key is pressed. Show the popup without taking keyboard focus away from
the target control. If the popup looses focus, it disapears. If cancel is not
selected, program flow proceeds to "// Popup MenuItem Click //".
}
procedure TForm1.WMHotKey(var Msg: TWMHotKey);
var TargetX, TargetY: integer;
begin
//--
//-- Insert the clipboard info into they control the user is typing in
//--
if (msg.HotKey <> FrmConfig.GetHotKeyID) then begin
exit
end;
AppendLog('WM_Hotkey - received');
self.HotKeyForeWindow := Windows.GetForegroundWindow();
if (self.HotKeyForeWindow <> 0) then begin
GetTargetControl(self.HotKeyForeWindow, self.HotKeyTarget,
TargetX, TargetY);
if (HotKeyTarget <> 0) then begin
//
// Attaching to the target keys the popup from
// taking away focus from the target item.
// Example, pasting to the name of a desktop icon. If you remove
// focus, you remove the rename box
//
if (self.PopupUseKB) then begin
// we need to be foreground for keyboard focus
SetForegroundWindow(self.Handle);
self.ShowPopup(TargetX, TargetY);
end else begin
if (self.ThreadAttach(self.HotKeyForeWindow)) then begin
self.ShowPopup(TargetX, TargetY);
self.ThreadDetach();
end else begin
ShowMessage('Couldn''t attach popup menu to this window');
end;
end;
end else begin
ShowMessage('Couldn''t find control to target');
end;
end else begin
ShowMessage('Coulnd''t get foreground window');
end;
end;
procedure TForm1.GetTargetControl(ParentWindow: cardinal;
var TargetHandle: cardinal;
var TargetX: integer;
var TargetY: integer);
var CaretPos: TPoint;
Rect: TRect;
begin
//
// attempt to get target control's handle and
// the position of the caret in the text window
//
TargetHandle := 0;
if (self.ThreadAttach(ParentWindow)) then begin
TargetHandle := Windows.GetFocus();
if (TargetHandle <> 0) then begin
Windows.GetCaretPos(CaretPos);
Windows.GetWindowRect(HotKeyTarget, Rect);
TargetX := Rect.left + CaretPos.X;
TargetY := Rect.top + CaretPos.Y;
end;
self.ThreadDetach;
end;
end;
procedure TForm1.ShowPopup(X,Y: integer);
var i: integer;
m: TMenuItem;
m2: TMenuItem;
m2a: TMenuItem;
const SHOW_LEN = 30;
//
// create a 1..9, for items 0 to 8 and A to Z for items 9 and so no
//
function GetAccelerator(i: integer): char;
begin
case (i) of
0..8: result := chr(byte('1') + i);
else
result := chr(byte('A') + (i - 9));
end;
end;
begin
//
// Recreate the menuitems
//
popup.Items.Clear;
if (self.PopupUseKB) then begin
popup.AutoHotkeys := maAutomatic;
end else begin
popup.AutoHotkeys := maManual;
end;
for i := 0 to lbQueue.Items.count - 1 do begin
m := TMenuItem.Create(popup);
if (self.PopupUseKB) then begin
m.Caption := '&' + GetAccelerator(i) + ': ' + leftstr(lbQueue.Items[i], SHOW_LEN);
end else begin
m.Caption := leftstr(lbQueue.Items[i], SHOW_LEN);
end;
m.OnClick := self.MenuItemClickEvent;
popup.Items.Add(M);
end;
//
// divider line cancel cancel
// divider line Last string option
//
popup.Items.Add(NewLine());
m := TMenuItem.Create(popup);
m.caption := 'Cancel';
m.OnClick := self.CancelMenuItemClickEvent;
popup.Items.Add(m);
if (trim(LastStringSelected) <> '') then begin
popup.Items.Add(Menus.NewLine());
m := TMenuItem.Create(popup);
m.caption := 'Last: ' + LeftStr(LastStringSelected, SHOW_LEN);
m.OnClick := self.LastMenuItemClickEvent;
popup.Items.Add(m);
end;
if (self.UsePermanentItems) then begin
popup.Items.Add(menus.NewLine());
for i := 0 to frmPermanent.GetCount - 1 do begin
m := TMenuItem.Create(popup);
m.hint := frmPermanent.GetItemName(i);
m.Caption := m.Hint;
m.OnClick := self.PermanentMenutItemClickEvent;
popup.Items.Add(m);
end;
end;
//
// show
//
AppendLog('Popup Activated');
popup.Popup(x, y);
if GetLastError <> 0 then AppendLog(SysErrorMessage(GetLastError));
AppendLog('Popup End');
end;
{
--============================
-- // Popup MenuItem Click //
--============================
Description: Handle a normal menu item, 'cancel' item, or
'last' item being clicked. If cancel is not selected mimic keyboard input
into the control with keyboard focus (which is set by the popup menu).
Remember the last selected item for the 'last' menu item option.
MenuItem MenuIndex's and the lbQueue index's are the same number.
}
procedure TForm1.MenuItemClickEvent(Sender: TObject);
begin
with Sender as TMenuItem do begin
AppendLog( 'menuitem ' + IntToStr(MenuIndex) );
AppendLog( 'lbQueue.count ' + IntToStr(lbQueue.Count));
LastStringSelected := lbQueue.items[MenuIndex];
AppendLog('inserting text');
self.SendText(lbQueue.items[MenuIndex]);
AppendLog('inserting done');
end;
end;
procedure TForm1.LastMenuItemClickEvent(Sender: TObject);
begin
AppendLog('Inserting last selected string');
self.SendText(LastStringSelected);
end;
procedure TForm1.CancelMenuItemClickEvent(Sender: TObject);
begin
//
// since using the keyboard takes away focus from the target
// window, it must be returned
//
if (self.PopupUseKB) then begin
if (self.ThreadAttach(self.HotKeyForeWindow)) then begin
Windows.SetForegroundWindow(self.HotKeyForeWindow);
self.ThreadDetach;
end;
end;
end;
procedure TForm1.PermanentMenutItemClickEvent(sender: TObject);
begin
with sender as tmenuitem do begin
self.SendText( frmPermanent.GetTextFrom( Hint ) );
end;
end;
//
// fake a CTRL+V or fake keyboard typing
//
procedure TForm1.SendText(s: string);
procedure SendUsingKeyboardMimic(s : string);
var c : char;
w : word;
i : integer;
ShiftPressed, EnterPressed : boolean;
begin
for i := 1 to length(s) do begin
c := s[i];
w := VkKeyScan(c);
ShiftPressed := (hi(w) and 1) > 0;
EnterPressed := (byte(c) = vk_return);
{VkKeyScan: The first bit of the hi byte set means W means shift is pressed}
{Ditch LF - assume CR came first}
if (c <> #10) then begin
if ShiftPressed and (not EnterPressed) then begin
keybd_event(VK_SHIFT, VkKeyScan(char(VK_SHIFT)), 0, 0);
end;
{Press and release key}
keybd_event(lo(w), w, 0, 0);
keybd_event(lo(w), w, KEYEVENTF_KEYUP, 0);
if ShiftPressed and (not EnterPressed) then begin
keybd_event(VK_SHIFT, VkKeyScan(char(VK_SHIFT)), KEYEVENTF_KEYUP, 0);
end;
end;
if (i mod 10 = 0) then sleep(1); // give the keyboard buffer a little break
end;
end;
procedure SendUsingPaste(s : string);
var i : integer;
c : char;
w : word;
s2 : string;
begin
//
// place text on clipboard and paste via CTRL+P
//
AppendLog('clearing and placing selected text on clipboard');
clipboard.Open;
clipboard.Clear;
Clipboard.SetTextBuf(PChar(s));
clipboard.Close;
sleep(1);
AppendLog('sending CTRL+V');
keybd_event(VK_CONTROL , VkKeyScan(char(VK_control)), 0, 0);
sleep(1);
w := VkKeyScan('V');
keybd_event(lo(w), w, 0, 0);
sleep(1);
keybd_event(lo(w), w, KEYEVENTF_KEYUP, 0);
sleep(1);
keybd_event(VK_CONTROL , VkKeyScan(char(VK_control)), KEYEVENTF_KEYUP, 0);
sleep(1);
AppendLog('sent CTRL+V');
end;
var s2 : string;
begin
IgnoreClipboard := true;
AppendLog('[Paste Start]');
//
// Since the popup may have stolen focus from the target,
// it must be given keyboard focus again
//
if (self.PopupUseKB) then begin
if (self.ThreadAttach(self.HotKeyForeWindow)) then begin
Windows.SetForegroundWindow(self.HotKeyForeWindow);
Windows.SetFocus(self.HotKeyTarget);
end else begin
showmessage('ERROR: Unable to paste into target');
exit;
end;
end;
if (UseKeyboardMimic) then begin
SendUsingKeyboardMimic(s);
end else begin
SendUsingPaste(s);
end;
if (self.PopupUseKB) then begin
self.ThreadDetach;
end;
AppendLog('[Paste End]');
IgnoreClipboard := false;
end;
{
--============================
-- // Thead utility methods //
--============================
Description: Mimic being part of the targeted window. This method is used
to get the keyboard focused item of an outside process and to associate a
popup menu with an outside process.
}
function Tform1.ThreadAttach(TargetWindow: cardinal) : boolean;
begin
result := false;
If (ThreadAttached) then begin
showmessage('Error: Thread already attached');
self.Close;
end;
ThreadTarget := Windows.GetWindowThreadProcessId(TargetWindow, nil);
ThreadOurs := Windows.GetCurrentThreadId();
if (ThreadTarget <> ThreadOurs) then begin
result := Windows.AttachThreadInput(ThreadTarget, ThreadOurs, true);
ThreadAttached := true;
end;
end;
procedure TForm1.ThreadDetach();
begin
If (not ThreadAttached) then begin
showmessage('Error: Thread not attached');
self.Close;
end;
if (ThreadTarget <> ThreadOurs) then begin
Windows.AttachThreadInput(ThreadTarget, ThreadOurs, false);
ThreadAttached := false;
end;
end;
{
--===========
-- // Etc. //
--===========
}
procedure TForm1.AppendLog(s : string);
begin
if length(memo1.text) > 20000 then memo1.Text := '';
// Cheezy Debugging Info[tm]
// make sure we don't overflow the text, only accept 1000 characters
// at a time
memo1.Text := leftstr(s, 1000) + #13 + #10 + memo1.text;
end;
procedure TForm1.btnHideClick(Sender: TObject);
begin
self.Hide;
end;
end.