home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Softwarová Záchrana 3
/
Softwarova-zachrana-3.bin
/
ArsClip
/
source.zip
/
UnitFrmClipboardManager.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
2004-01-24
|
46KB
|
1,492 lines
unit UnitFrmClipboardManager;
{
Purpose:
This unit monitors new items on the clipboard.
Raw data is retrieved and send to the ClipQueue
(the text, filenames, and icons).
Also, this unit is the interface for the user
to manipulating the queue.
NOTE:
Items entering the clipboard too soon after an ArsClip
paste are ignored, since our clipboard items must be
ignored.
Updates:
'Fix URL' broken, timing problem and logic problem
-------------------
If a clip is copied at the same exact time the Clipboard Watcher fires,
it generates a false clipboard break message.
Fix: GDI object leak when new clipboard item retreival fails
New Fix URLs option
Pressing Delete Key to delete items
-------------------
Detection of Infinite loop in clipboard chain
SetIgnoreClipboard now private, not needed elsewhere
UnitPaste now marks all clips as ours ^^^^^^^^^
------------------
edit/preview OtherQueue items
new 'Copy As' button
-------------
Updated to save/load icons
Updated for optional Rich Text monitoring
----
Improved error reporting for corrupt data file
Two Icon notifications when an item is copied: normal
mode, and disabled mode
--
A new method of ignoring the clipboard was needed when another
program was part of the clipboard viewer chain. When a
WMDRAWCLIPBOARD message arrives, at least 1 second must have
passed since the last time FrmMainPopup placed an item on the
clipboard.
The SetIgnoreClipboard() function is only needed durring
a paste operation.
Moved the rest of the Queue logic to UnitClipQueue
Copied files no longer causes duplicate entries
lbQueue is not longer used for the clipboard history, due to Win9X
memory constraints for components. See UnitClipQueue for details.
}
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Clipbrd, ShellAPI, Buttons, ExtCtrls, ComCtrls,
ImgList {for DragQueryFile};
type
TfrmClipboardManager = class(TForm)
Panel1: TPanel;
btnTop: TSpeedButton;
btnUp: TSpeedButton;
btnDown: TSpeedButton;
btnBottom: TSpeedButton;
Panel2: TPanel;
btnClose: TButton;
btnDelete: TButton;
bCopyToClipboard: TButton;
PageControl1: TPageControl;
TabSheet1: TTabSheet;
TabSheet2: TTabSheet;
Preview: TLabel;
mPreview: TMemo;
lbQueue: TListBox;
lbNontext: TListBox;
iPreview: TImage;
bCopyAs: TButton;
Label1: TLabel;
lblClipSize: TLabel;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure btnCloseClick(Sender: TObject);
procedure btnTopClick(Sender: TObject);
procedure btnUpClick(Sender: TObject);
procedure btnDownClick(Sender: TObject);
procedure btnBottomClick(Sender: TObject);
procedure btnDeleteClick(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormShow(Sender: TObject);
procedure lbQueueClick(Sender: TObject);
procedure bCopyToClipboardClick(Sender: TObject);
procedure lbQueueDrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
procedure lbQueueMeasureItem(Control: TWinControl; Index: Integer;
var Height: Integer);
procedure lbNontextDrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
procedure PageControl1Change(Sender: TObject);
procedure lbNontextClick(Sender: TObject);
procedure bCopyAsClick(Sender: TObject);
procedure lbNontextKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure lbQueueKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
private
HistoryLoaded : boolean;
{ Private declarations }
NextHandle: THandle; {clipboard chain pointer}
DisableMonitoring: boolean; {altered by public interface}
IgnoreClipboard: boolean;
MonitorFilenames: boolean;
MonitorOtherItems: boolean;
CopyIcon : boolean;
//LastPaste : TDateTime;
DisableWhenScrollLock : boolean;
IsJoinedToChain : boolean;
BypassPasteProtectionOnce : boolean;
function IsSafeToMove : boolean;
procedure ClipboardChainJoin;
procedure ClipboardChainLeave;
procedure SaveTextItemsOrder;
procedure SaveOtherItemsOrder;
procedure SetIgnoreClipboard(ignore : boolean);
//procedure InformOfPaste;
procedure HealBrokenChain;
{windows messages}
//procedure WMDRAWCLIPBOARD(var Message: TMessage); message WM_DRAWCLIPBOARD;
procedure WMDRAWCLIPBOARD_NEW(var Message: TMessage); message WM_DRAWCLIPBOARD;
procedure WMCHANGECBCHAIN(var Message: TMessage); message WM_CHANGECBCHAIN;
public
{ Public declarations }
CF_RICHTEXT : UINT;
CF_HTML : UINT;
{configuration}
procedure SetMonitoring(disable: boolean);
procedure SetFilenameMonitoring(enable: boolean);
procedure SetOtherItemsMonitoring(enable: boolean);
procedure SetCopyIcon(enable: boolean);
procedure SetDisableWhenScrollLock(value : boolean);
{temporarily ignore the clipboard items}
function GetClipboardOwnerIcon : HICON;
{history load/save}
//function GetDoSave
procedure LoadHistory;
procedure SaveHistory;
procedure RefreshClipboardMonitor;
function GetIsOnChain : boolean;
end;
var
frmClipboardManager: TfrmClipboardManager;
{////////////////////}
{//}implementation{//}
{////////////////////}
uses UnitFrmMainPopup, UnitListBoxMover, UnitFrmDummyIcon,
UnitClipQueue, UnitOtherQueue, UnitKeyboardQuery, StrUtils, DateUtils,
UnitFrmSysTrayMenu, UnitFrmChainWatcher, UnitFrmConfig, UnitMisc, Math,
UnitPaste;
const REMEMBER_FILE = 'remember.txt';
const OTHER_FILE = 'other.txt';
{$R *.dfm}
{
--======================
-- // Public Inteface //
--======================
}
procedure TfrmClipboardManager.RefreshClipboardMonitor;
begin
Windows.SetLastError(ERROR_SUCCESS);
self.ClipboardChainLeave;
self.ClipboardChainJoin;
end;
procedure TfrmClipboardManager.HealBrokenChain;
begin
// this is a bad idea, if the chain is not truely broken
//
self.NextHandle := 0;
self.ClipboardChainJoin;
end;
{
procedure TFrmClipboardManager.InformOfPaste;
begin
LastPaste := SysUtils.Time();
end;
}
//--------------------------------
// configuration stuff
//--------------------------------
procedure TfrmClipboardManager.SetCopyIcon(enable: boolean);
begin
self.CopyIcon := enable;
end;
procedure TfrmClipboardManager.SetMonitoring(disable: boolean);
begin
self.DisableMonitoring := disable;
end;
procedure TfrmClipboardManager.SetIgnoreClipboard(ignore : boolean);
begin
IgnoreClipboard := ignore;
UnitMisc.AppendLog('ClipboardManager: ignore = ' + BoolToStr(ignore) );
end;
procedure TfrmClipboardManager.SetFilenameMonitoring(enable: boolean);
begin
MonitorFilenames := enable;
end;
procedure TFrmClipboardManager.SetOtherItemsMonitoring(enable: boolean);
begin
MonitorOtherItems := enable;
if (not enabled) then
ClipQueue.ClearQueue;
end;
procedure TFrmClipboardManager.SetDisableWhenScrollLock(value : boolean);
begin
DisableWhenScrollLock := value;
end;
{
--======================
-- // Create/Destroy //
--======================
}
procedure TfrmClipboardManager.FormCreate(Sender: TObject);
begin
Windows.SetLastError(ERROR_SUCCESS);
self.CF_HTML := RegisterClipboardFormat('HTML Format');
self.CF_RICHTEXT := RegisterClipboardFormat('Rich Text Format');
self.ClipboardChainJoin;
PageControl1.ActivePageIndex := 0;
end;
procedure TfrmClipboardManager.FormDestroy(Sender: TObject);
begin
self.ClipboardChainLeave;
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 TfrmClipboardManager.WMDRAWCLIPBOARD_NEW(var Message: TMessage);
// return string when teh clipboard is altered
function FixedURL(ci : TClipItem) : string;
var s, s2: string;
i : integer;
begin
result := '';
if (FrmConfig.cbAutofixURLs.Checked) then begin
s := ci.GetAsText;
s2 := Trim(s);
i := Pos( '://', s2);
if (i > 2) and (i < 8) then begin
while (Pos(#13#10, s2) <> 0) do begin
s2 := StringReplace(s2, #13#10, '', [rfReplaceAll]);
end;
if (s2 <> s) then begin
result := s2;
end;
end;
end;
end;
var s : string;
//cTime : TDateTime;
ClipItem : TClipItem;
cformat : cardinal;
URL : string;
label exit_code;
begin
Windows.SetLastError(ERROR_SUCCESS);
if (FrmChainWatcher <> nil) then begin
FrmChainWatcher.NotifyOfClipboardActivity;
FrmChainWatcher.Disable;
end;
// is this our data that we just pasted?
// disabled? Ignore the clipboard for now?
// make sure the data isn't from us
// configurable disable via Scroll Lock key
{CTime := SysUtils.Time();
if ((MillisecondOfTheDay(CTime) - MillisecondOfTheDay(LastPaste)) < 100) then begin
UnitMisc.AppendLog(' Too soon a paste message - ignoring');
goto exit_code;
end;
}
if (DisableMonitoring) then begin
frmSysTrayMenu.SetIconIgnore;
UnitMisc.AppendLog('//// Monitoring disabled');
goto exit_code;
end;
if (IgnoreClipboard) then begin
UnitMisc.AppendLog('//// Ignoring ');
goto exit_code;
end;
if (Windows.GetClipboardOwner = Application.Handle) and
not (self.BypassPasteProtectionOnce) then begin
UnitMisc.AppendLog(' Ignore our own clipboard events');
goto exit_code;
end;
self.BypassPasteProtectionOnce := false;
If (self.DisableWhenScrollLock) then begin
if (KeyboardQuery.LockOn(VK_SCROLL)) then begin
frmSysTrayMenu.SetIconIgnore;
UnitMisc.AppendLog(' scroll lock on - ignoring contents');
goto exit_code;
end;
end;
// get ready to do the thing
IgnoreClipboard := true;
UnitMisc.AppendLog('//// Clipboard Start ////' +
#13+#10 +
' # = ' + IntToStr(message.msg) +
' lparam = ' + IntToStr(message.LParam) +
' wparam = ' + IntToStr(message.WParam)
);
frmSysTrayMenu.SetIconTriggered;
//
// Clipboard contents have changed
// Copy the contents
//
cformat := 0;
try
ClipItem := TClipItem.Create;
UnitMisc.AppendLog(' Attempting to retrieve clipboard text');
// get clipboard item
// only act when an item is found (non-zero result) without error
if (CopyIcon) then begin
cformat := ClipItem.GetClipboardItem(self.GetClipboardOwnerIcon);
end else begin
cformat := ClipItem.GetClipboardItem(0);
end;
except
on E: Exception do
begin
UnitMisc.AppendLog('problems getting new clip item: ' + e.message);
end;
end;
// FIX: Don't leak GDI memory when object retreval fails
if (cformat = 0) then begin
UnitMisc.AppendLog('Get ClipItem failed',true);
MyDestroyIcon(ClipItem.CData.GetHICONAbsolute);
MyFree(ClipItem);
IgnoreClipboard := false;
goto exit_code;
end;
// Detect broken URLs
// - abort process when detected
URL := FixedURL(ClipItem);
if (FixedUrl(ClipItem) <> '') then begin
MyFree(ClipItem);
IgnoreClipboard := false;
goto exit_code;
end;
try
if (cformat <> 0) then begin
s := ClipItem.GetAsText;
// May be a text item, may be a copied filename,
// may be an "Other" item
// Will be deleted if nobody wants the clip
if (s <> '') then begin
if (CFormat = Windows.CF_HDROP) then begin
if (MonitorFilenames) then begin
if (s <> '') then begin
UnitMisc.AppendLog(' Accepting as file(s)');
ClipQueue.InsertAtStart(ClipItem);
end else begin
UnitMisc.AppendLog(' Nobody wants the clip');
MyFree(ClipItem);
end;
end;
end else begin
UnitMisc.AppendLog(' Accepting as text');
ClipQueue.InsertAtStart(ClipItem);
end;
end else begin
if (self.MonitorOtherItems)then begin
UnitMisc.AppendLog(' Accepting as Other clip');
OtherQueue.InsertAtStart(ClipItem);
end else begin
UnitMisc.AppendLog(' Nobody wants the clip');
MyFree(ClipItem);
end;
end;
end;
except
on E: Exception do
begin
UnitMisc.AppendLog('problems getting new clip item: ' + e.message);
end;
end;
IgnoreClipboard := false;
exit_code:
// Pass message to next in line (rules of a cliboard viewer)
Message.Result := 0;
If (NextHandle <> 0) then begin
if (NextHandle = self.Handle) then begin
NextHandle := 0;
UnitMisc.AppendLog('Infinite loop detected in Clipboard chain!!!');
end else begin
Windows.SendMessage(NextHandle, WM_DRAWCLIPBOARD, message.WParam, message.LParam )
end;
end;
UnitMisc.AppendLog('//// Clipboard End ////');
if (FrmChainWatcher <> nil) then begin
FrmChainWatcher.Enable;
end;
if (URL <> '') then begin
UnitMisc.AppendLog('//// Fixing URL');
self.BypassPasteProtectionOnce := true;
Paste.PlaceOnClipboardDontBypassClipboardManager(URL);
UnitMisc.TimerStart;
UnitMisc.TimerEndAt(50);
end;
end;
{
procedure TfrmClipboardManager.WMDRAWCLIPBOARD(var Message: TMessage);
var s : string;
cTime : TDateTime;
label exit_code;
function GetClipboardText(GetAsRichText : boolean = false): string;
var hnd : THandle;
p : Pointer;
format : UINT;
formatFound : boolean;
begin
// This code is an attemp to get rid of the "Cannot Open Clipboard"
// errors. The previous version of this code caused garbage to appear
// in the history.
result := '';
p := nil;
hnd := 0;
try
formatFound := false;
format := 0;
if (Clipboard.HasFormat(CF_RICHTEXT) and GetAsRichText) then begin
format := CF_RICHTEXT;
formatFound := true;
end else if (clipboard.HasFormat(CF_TEXT) and Not GetAsRichText) then begin
format := CF_TEXT;
formatFound := true;
end;
if (formatFound) then begin
UnitMisc.AppendLog('open clipboard');
if (Windows.OpenClipboard(Application.Handle)) then begin
hnd := Windows.GetClipboardData(format);
if (hnd <> 0) then begin
p := GlobalLock(hnd);
if (p <> nil) then begin
result := PChar(p);
end else begin
UnitMisc.AppendLog('ERROR: failed to lock clipboard data');
end;
end else begin
UnitMisc.AppendLog('ERROR: GetClipboardData() : ' + SysErrorMessage(GetLastError()) );
end;
Windows.CloseClipboard;
end else begin
UnitMisc.AppendLog('ERROR: Failed to open clipboard: ' + SysErrorMessage(GetLastError()) );
end;
end;
finally
if (p <> nil) and (hnd <> 0) then begin
Windows.GlobalUnlock(hnd);
UnitMisc.AppendLog('closing lock');
end else begin
UnitMisc.AppendLog('not closing lock');
end;
end;
end;
//
// return all filenames or return empty string
function GetFilenames: string;
var h, lockdata : THandle;
i, j : longint;
s : string;
begin
result := '';
if (MonitorFilenames) then begin
if (clipboard.HasFormat(CF_HDROP)) then begin
UnitMisc.AppendLog(' Detecting Filenames...');
// only attemp after a global lock has been made
h := clipboard.GetAsHandle(CF_HDROP);
lockdata := THandle(Windows.GlobalLock(h));
if (lockdata <> 0) then begin
j := ShellApi.DragQueryFile(lockdata, $FFFFFFFF, nil, 0);
result := '';
for i := 0 to (j - 1) do begin
s := stringofchar(' ', Windows.MAX_PATH);
ShellApi.DragQueryFile(lockdata, i, pchar(s), length(s));
UnitMisc.AppendLog(Trim(String(s)));
if i = (j - 1) then begin
result := result + Trim(PChar(s));
end else begin
result := result + Trim(PChar(s)) + #13 + #10;
end;
end;
Windows.GlobalUnlock(lockdata);
end;
end;
end;
end;
var RichText : string;
begin
if (FrmChainWatcher <> nil) then begin
FrmChainWatcher.NotifyOfClipboardActivity;
end;
// is this our data that we just pasted?
// disabled? Ignore the clipboard for now?
// make sure the data isn't from us
// configurable disable via Scroll Lock key
CTime := SysUtils.Time();
if ((MillisecondOfTheDay(CTime) - MillisecondOfTheDay(LastPaste)) < 300) then begin
UnitMisc.AppendLog(' Too soon a paste message - ignoring');
goto exit_code;
end;
if (DisableMonitoring) then begin
frmSysTrayMenu.SetIconIgnore;
UnitMisc.AppendLog('//// Monitoring disabled');
goto exit_code;
end;
if (IgnoreClipboard) then begin
UnitMisc.AppendLog('//// Ignoring ');
goto exit_code;
end;
if (Windows.GetClipboardOwner = self.Handle) then begin
UnitMisc.AppendLog(' Ignore our own clipboard events');
goto exit_code;
end;
If (self.DisableWhenScrollLock) then begin
if (KeyboardQuery.LockOn(VK_SCROLL)) then begin
frmSysTrayMenu.SetIconIgnore;
UnitMisc.AppendLog(' scroll lock on - ignoring contents');
goto exit_code;
end;
end;
// get ready to do the thing
IgnoreClipboard := true;
UnitMisc.AppendLog('//// Clipboard Start ////' +
#13+#10 +
' # = ' + IntToStr(message.msg) +
' lparam = ' + IntToStr(message.LParam) +
' wparam = ' + IntToStr(message.WParam)
);
frmSysTrayMenu.SetIconTriggered;
//
// Clipboard contents have changed
// Copy the contents if it is text
try
UnitMisc.AppendLog(' Attempting to retrieve clipboard text');
s := GetClipboardText;
if (s = '') then begin
// check for filenames
UnitMisc.AppendLog(' Empty string in clipboard or error retreiving text.');
s := GetFilenames();
if (s = '') and (self.MonitorOtherItems) then begin
if (CopyIcon) then begin
OtherQueue.ClipboardSave(self.GetClipboardOwnerIcon);
end else begin
OtherQueue.ClipboardSave(HICON(nil));
end;
end;
end;
// trim the queue size, dup oldest entry
if (s <> '') then begin
ClipQueue.InsertAtStart(ClipItem);
if (CopyIcon) then begin
if FrmConfig.cbMonitorRichTextItems.checked then begin
RichText := GetClipboardText(true);
end else begin
RichText := '';
end;
if (RichText = '') then begin
Clip
ClipQueue.InsertAtStart(s, self.GetClipboardOwnerIcon);
end else begin
ClipQueue.InsertAtStart(s, RichText, self.GetClipboardOwnerIcon);
end;
end else begin
ClipQueue.InsertAtStart(s, HICON(nil));
end;
end;
finally
end;
IgnoreClipboard := false;
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;
UnitMisc.AppendLog('//// Clipboard End ////');
end;
}
procedure TfrmClipboardManager.WMCHANGECBCHAIN(var Message: TMessage);
begin
Windows.SetLastError(ERROR_SUCCESS);
//
//Someone is leaving the chain, only "fires" when the program leaving
//is the one after us
//
{ 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 (Cardinal(Message.WParam) = NextHandle) then begin
UnitMisc.AppendLog('WM_Changecbchain - reassign next handle');
NextHandle := Message.LParam;
if (NextHandle = self.Handle) then begin
Raise Exception.Create('ERROR: ArsClip Joined the chain twice!');
end;
end else if (NextHandle <> 0) then begin
UnitMisc.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;
//
// viewers joining/leaving the chain can send erounious 'clipboard
// changed' events, so they'll need to be ingored just like our own
// paste events
//self.InformOfPaste;
Message.Result := 0;
end;
procedure TfrmClipboardManager.ClipboardChainJoin;
var i : integer;
begin
Windows.SetLastError(ERROR_SUCCESS);
//Join the cliboard chain
// Disable monitoring until this form has been created
// This prevents aditions until the Config form has a
// chance to set the queue size
self.SetIgnoreClipboard(true);
UnitMisc.AppendLog('ClipManager: Joining Chain');
Windows.SetLastError(ERROR_SUCCESS);
if not Windows.OpenClipboard(Application.Handle) then begin
UnitMisc.AppendLog('Can''t open clipboard', true);
EXIT;
end;
NextHandle := Windows.SetClipboardViewer(self.Handle);
if (NextHandle = 0) then begin
i := Windows.GetLastError;
if (i <> 0) then begin
UnitMisc.AppendLog('ClipManager: Can''t join chain ' + SysErrorMessage(i) );
self.IsJoinedToChain := false;
end else begin
self.IsJoinedToChain := true;
end;
end else begin
self.IsJoinedToChain := true;
end;
Windows.CloseClipboard;
UnitMisc.AppendLog('ClipManger: joining end');
self.SetIgnoreClipboard(false);
end;
procedure TfrmClipboardManager.ClipboardChainLeave;
begin
Windows.SetLastError(ERROR_SUCCESS);
self.IsJoinedToChain := false;
self.SetIgnoreClipboard(true);
UnitMisc.AppendLog('ClipManager: leaving chain');
//Leave the chain
Windows.ChangeClipboardChain(self.Handle, // our handle to remove
NextHandle ); // handle of next window in the chain
UnitMisc.AppendLog('ClipManger: leaving end');
self.SetIgnoreClipboard(false);
end;
procedure TfrmClipboardManager.LoadHistory;
var base, icons, otherclips, textclips, name, itemText, s : string;
lineCount : cardinal;
i , IconCount: integer;
tf : textfile;
ci : TClipItem;
begin
// only load once
if (HistoryLoaded) then begin
exit;
end;
HistoryLoaded := true;
//
// load permanent items
//
base := IncludeTrailingPathDelimiter(ExtractFilePath(application.ExeName));
name := base + REMEMBER_FILE;
icons := base + 'iconcache\';
textclips := base + 'textcache\';
otherclips := base + 'othercache\';
if FileExists(name) then begin
AssignFile(tf, name);
Reset(tf, name);
ClipQueue.ClearQueue;
//
// abort reading and show message on error
// always close the file
//
try
iconCount := 0;
while not eof(tf) do begin
try
Readln(tf, s);
itemText := '';
lineCount := StrToInt(s);
for i := 0 to lineCount - 1 do begin
Readln(tf, s);
if (itemText = '') then begin
itemText := s;
end else begin
itemText := itemText + #13#10 + s;
end;
end;
ci := TClipItem.Create;
ci.CData.SetString(itemText);
// load icon if exists
ci.LoadIconFromFile(icons, iconCount);
ci.LoadFromFIle(textClips, IconCount);
ClipQueue.AddNoSizeCheck(itemText, ci);
inc(IconCount);
except
on E: Exception do begin
ShowMessage('The "Load items from last session" file is corrupted - ' + name + #13#10#13#10 +
'Error Message: ' + E.Message);
break;
end;
end;
end;
finally
CloseFile(tf);
end;
end;
//
// load the
//
name := base + OTHER_FILE;
if (FileExists(name)) then begin
AssignFile(tf, name);
reset(tf);
i := 0;
while not eof(tf) do begin
readln(tf,s);
ci := TClipItem.Create;
ci.CData.SetString(s);
ci.LoadFromFIle(otherclips, i);
ci.LoadIconFromFile(icons, i, '-o');
OtherQueue.AddNoSizeCheck(s, ci);
inc(i);
end;
closefile(tf);
end;
end;
procedure TfrmClipboardManager.SaveHistory;
var base, name, icons, otherclips, textclips, s : string;
i, j, cnt : integer;
tf: textfile;
ci : TClipItem;
ico : TIcon;
bit : TBitmap;
r : TRect;
begin
//
// save items
//
base := IncludeTrailingPathDelimiter(ExtractFilePath(application.ExeName));
name := base + REMEMBER_FILE;
icons := base + 'iconcache\';
ForceDirectories(icons);
textclips := base + 'textcache\';
ForceDirectories(textclips);
otherclips := base + 'othercache\';
ForceDirectories(otherclips);
AssignFile(tf, name);
Rewrite(tf);
ico := TIcon.Create;
bit := TBitmap.Create;
r.Top := 0;
r.Left := 0;
r.bottom := 15;
r.Right := 15;
for i := 0 to (ClipQueue.GetQueueCount - 1) do begin
// ultra cheap trick[tm] to count lines in an item
// FIX: Count CR+LF instead of just CR
cnt := 1;
s := ClipQueue.GetItemText(i);
for j := 1 to length(s) - 1 do begin
if (s[j] = #13) and (s[j+1]= #10) then inc(cnt);
end;
//
// save or overwrite the icon file
// save or overwrite the clip item
//
ci := ClipQueue.GetClipItem(i);
if (ci <> nil) then begin
ci.SaveIconToFile(icons, i);
ci.SaveToFile(textclips, i)
end;
writeln(tf, cnt);
writeln(tf, s);
end;
CloseFile(tf);
//
// save the other items
// and their icons
//
AssignFile(tf, base + OTHER_FILE);
Rewrite(tf);
for i := 0 to (OtherQueue.GetQueueCount - 1) do begin
ci := OtherQueue.GetClipItem(i);
writeln(tf, ci.GetAsText);
ci.SaveToFile(otherclips, i);
ci.SaveIconToFile(icons, i, '-o');
end;
CloseFile(tf);
MyFree(ico);
MyFree(bit);
end;
function TFrmClipboardManager.GetClipboardOwnerIcon() : HICON;
var h, owner : THandle;
// NOTE: DestroyIcon must before deleting a queued item!!!!!
{
// CopyIcon seems to leak GDI objects
function CloneIcon(inIcon : HICON) : HICON;
begin
// talk about a simple replacement!
Result := Windows.CopyIcon(inIcon);
end;
}
function CloneIcon(inIcon : HICON) : HICON;
var hIconNew : HICON;
info : _ICONINFO;
begin
result := 0;
// info from PCMagazine's TrayManager
// Get information about the specified icon
// Create a clone of the icon
if (not Windows.GetIconInfo(inIcon, info)) then begin
frmMainPopup.AppendLog('clone icon: ' + SysErrorMessage(GetLastError));
EXIT;
end;
hIconNew := Windows.CreateIconIndirect(info);
if (hIconNew = 0) then begin
frmMainPopup.AppendLog('CreateIconIndirect failed: ' + SysErrorMessage(GetLastError));
end;
// Delete the info item's bitmaps -- otherwise we get a very
// ugly memory leak
if (not Windows.DeleteObject(info.hbmMask)) then begin
frmMainPopup.AppendLog('DeleteObject failed: ' + SysErrorMessage(GetLastError));
end;
if (not Windows.DeleteObject(info.hbmColor)) then begin
frmMainPopup.AppendLog('DeleteObject failed: ' + SysErrorMessage(GetLastError));
end;
result := hIconNew;
end;
begin
Windows.SetLastError(ERROR_SUCCESS);
// set defualt result
// bail out if owner went bye-bye
result := 0;
owner := Windows.GetForegroundWindow;
if (owner = 0) then begin
EXIT;
end;
UnitMisc.AppendLog('^Cloning Icon^');
// find topmost parent
repeat
h := GetWindowLong(owner, GWL_HWNDPARENT);
if (h <> 0) then begin
{
// may be used in the future to identifiy CLIPBRDWNDCLASS
s := StringOfChar(#0, 255);
if GetClassName(owner, pchar(s), length(s)-1) <> 0 then begin
// CLIPBRDWNDCLASS will return nothing
// wonder what that bastard class actually is
end;
}
owner := h;
end;
until (h = 0);
Windows.SetLastError(ERROR_SUCCESS);
// get the first small icon available, if any
h := Windows.GetClassLong(owner, GCL_HICONSM);
if (h <> 0) then begin
result := CloneIcon(h);
EXIT;
end;
Windows.SetLastError(ERROR_SUCCESS);
h := Windows.GetClassLong(owner, GCL_HICON);
if (h <> 0) then begin
result := CloneIcon(h);
EXIT;
end;
Windows.SetLastError(ERROR_SUCCESS);
if (SendMessageTimeout(owner, WM_GETICON, ICON_SMALL,0,SMTO_ABORTIFHUNG,1000,h) <> 0) then begin
result := CloneIcon(h);
EXIT;
end;
Windows.SetLastError(ERROR_SUCCESS);
if (SendMessageTimeout(owner, WM_GETICON, ICON_BIG,0,SMTO_ABORTIFHUNG,1000,h) <> 0) then begin
result := CloneIcon(h);
EXIT;
end;
Windows.SetLastError(ERROR_SUCCESS);
UnitMisc.AppendLog('Clone failed: ' + SysUtils.SysErrorMessage(Windows.GetLastError));
end;
//////////////////////////////////////////////////////////////
// User Interface
// close the window,
// move item
// delete item
//////////////////////////////////////////////////////////////
procedure TfrmClipboardManager.btnCloseClick(Sender: TObject);
begin
self.ModalResult := mrok;
self.close;
end;
function TfrmClipboardManager.IsSafeToMove: boolean;
var ci : TClipItem;
begin
if (lbQueue.Count = 0) then begin
Result := true;
EXIT;
end;
ci := TClipItem(self.lbQueue.Items.Objects[0]);
result := (ClipQueue.IndexOf(ci) = 0);
if (not result) then begin
ShowMessage('The clipboard contents have changed. Unable to move the items.'
+ #13#10 + 'Refreshing display');
self.FormShow(self);
end;
end;
procedure TfrmClipboardManager.btnTopClick(Sender: TObject);
begin
if (PageControl1.ActivePageIndex = 0) then begin
if (IsSafeToMove) then begin
UnitListBoxMover.MoveSelectedTop(lbQueue);
self.SaveTextItemsOrder;
end;
end else begin
UnitListBoxMover.MoveSelectedTop(lbNontext);
self.SaveOtherItemsOrder;
end;
end;
procedure TfrmClipboardManager.btnUpClick(Sender: TObject);
begin
if (PageControl1.ActivePageIndex = 0) then begin
if (IsSafeToMove) then begin
UnitListBoxMover.MoveSelectedUp(lbQueue);
self.SaveTextItemsOrder;
end;
end else begin
UnitListBoxMover.MoveSelectedUp(lbNontext);
self.SaveOtherItemsOrder;
end;
end;
procedure TfrmClipboardManager.btnDownClick(Sender: TObject);
begin
if (PageControl1.ActivePageIndex = 0) then begin
if (IsSafeToMove) then begin
UnitListBoxMover.MoveSelectedDown(lbQueue);
self.SaveTextItemsOrder;
end;
end else begin
UnitListBoxMover.MoveSelectedDown(lbNontext);
self.SaveOtherItemsOrder;
end;
end;
procedure TfrmClipboardManager.btnBottomClick(Sender: TObject);
begin
if (PageControl1.ActivePageIndex = 0) then begin
if (IsSafeToMove) then begin
UnitListBoxMover.MoveSelectedBottom(lbQueue);
self.SaveTextItemsOrder;
end;
end else begin
UnitListBoxMover.MoveSelectedBottom(lbNontext);
self.SaveOtherItemsOrder;
end;
end;
procedure TfrmClipboardManager.btnDeleteClick(Sender: TObject);
var i, j : integer;
ci : TClipItem;
begin
if KeyboardQuery.IsPressed(VK_CONTROL) then begin
self.HealBrokenChain;
// Purposely KILL THE PROGRAM
end;
if (PageControl1.ActivePageIndex = 0) then begin
for i := (lbqueue.Items.count - 1) downto 0 do begin
if (lbqueue.Selected[i]) then begin
ci := TClipItem(lbQueue.Items.Objects[i]);
j := ClipQueue.IndexOf(ci);
ClipQueue.DeleteItem(j);
lbQueue.Items.Delete(i);
end;
end;
end else begin
for i := (lbnontext.Items.count - 1) downto 0 do begin
if (lbnontext.Selected[i]) then begin
ci := TClipItem(lbNontext.Items.Objects[i]);
j := OtherQueue.IndexOf(ci);
lbnontext.Items.Delete(i);
OtherQueue.DeleteItem(j);
end;
end;
end;
end;
//------------------------------------------------------------------
// To set the changes in the queue, send back what we've altered
//
// NOTE: See the dirty trick used as a Win9X workaround
// A reference to the ClipItem of each listbox item is stored.
// This is how each item's index can be found in ClipQueue and
// OtherQueue
//------------------------------------------------------------------
procedure TfrmClipboardManager.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
bCopyAs.Visible := false;
lbNontext.Clear;
lbQueue.Clear;
end;
procedure TfrmClipboardManager.SaveOtherItemsOrder;
var i, index : longint;
ci : TClipItem;
begin
//
// recreate the order as seen in the form
//
for i := (lbNontext.Items.count - 1) downto 0 do begin
ci := TClipItem(lbNontext.items.Objects[i]);
index := OtherQueue.IndexOf(ci);
if (i <> index) then begin
OtherQueue.Move(index, i);
end;
end;
end;
procedure TfrmClipboardManager.SaveTextItemsOrder;
var i, index : longint;
ci : TClipItem;
begin
for i := (lbQueue.Items.count - 1) downto 0 do begin
ci := TClipItem(lbQueue.items.Objects[i]);
index := ClipQueue.IndexOf(ci);
if (i <> index) then begin
ClipQueue.Move(index, i);
end;
end;
end;
procedure TfrmClipboardManager.FormShow(Sender: TObject);
procedure AddItems(clips : TClipQueue; listbox : TListBox);
var i : integer;
s : string;
ci : TClipItem;
begin
for i := 0 to (clips.GetQueueCount - 1) do begin
ci := clips.GetClipItem(i);
s := ci.GetAsText;
listbox.Items.AddObject(LeftStr(s,300), TObject(ci) );
end;
end;
begin
// dirty trick to get around Win9X memory limitations
// for some components
// I'm storing the full string in the object list
lbQueue.Items.Clear;
lbNontext.Items.Clear;
mPreview.Text := '';
iPreview.Visible := false;
AddItems(ClipQueue, lbQueue);
AddItems(OtherQueue, lbNontext);
end;
//
// show the preview when an item is clicke on
//
procedure TfrmClipboardManager.lbQueueClick(Sender: TObject);
var ci : TClipItem;
begin
mPreview.Visible := true;
mPreview.Text := LeftStr(ClipQueue.GetItemText(lbQueue.ItemIndex), 1000);
if (lbQueue.SelCount = 1) then begin
bCopyAs.Visible := true;
ci := ClipQueue.GetClipItem(lbQueue.itemindex);
bCopyAs.Caption := 'Copy as ' + leftstr(ci.GetFormatName,10);
if (ci.GetDataSize <> 0) then begin
lblClipSize.Caption := 'Size(bytes): ' + IntToStr(ci.GetDataSize);
end else begin
lblClipSize.Caption := '';
end;
end else begin
bCopyAs.Visible := false;
end;
end;
procedure TfrmClipboardManager.bCopyToClipboardClick(Sender: TObject);
var i : longint;
s : string;
ci : TClipItem;
begin
if (PageControl1.ActivePageIndex =0) then begin
for i := 0 to (lbQueue.Items.count - 1) do begin
if lbQueue.Selected[i] then begin
ci := TClipItem(lbQueue.items.Objects[i]);
s := s + ci.GetAsText;
end;
end;
if (s <> '') then begin
Paste.SetClipboardOnlyOnce;
Paste.SendText(s);
end;
end else begin
i := lbNontext.ItemIndex;
if (i <> -1) then begin
Paste.SetClipboardOnlyOnce;
Paste.SendText('', OtherQueue.GetClipItem(i));
end;
end;
end;
procedure TfrmClipboardManager.bCopyAsClick(Sender: TObject);
var ci : TClipItem;
begin
if (PageControl1.ActivePageIndex = 0) then begin
ci := TClipItem(lbQueue.items.Objects[lbQueue.ItemIndex]);
UnitMisc.AppendLog('Copy As ' + ci.GetAsText + ' ' + ci.GetFormatName );
Paste.SetClipboardOnlyOnce;
Paste.SendText('', ci);
end;
end;
function TfrmClipboardManager.GetIsOnChain: boolean;
begin
result := self.IsJoinedToChain;
end;
//
// custome draw routines
//
procedure TfrmClipboardManager.lbQueueDrawItem(Control: TWinControl;
Index: Integer; Rect: TRect; State: TOwnerDrawState);
var ci : TClipItem;
th, h : integer;
c : TColor;
s : string;
begin
// height of rectangle & height of text on the listbox
h := (rect.Bottom - rect.top) + 1;
th := lbQueue.Canvas.TextHeight('ALKJDFIOJ');
//
// draw the icon leaving enough pixels above and below
// for the selection outline
//
s := lbqueue.Items.Strings[index];
ci := ClipQueue.GetClipItem(index);
if (ci <> nil) then begin
if (ci.CData.GetHICON <> 0) then begin
DrawIconEX(
lbQueue.Canvas.Handle, rect.Left+2, rect.Top+1,ci.CData.GetHICON,
h-2, h-2,
0,0,DI_NORMAL);
end;
s := UnitMisc.GetCliptypeSymbol(ci.GetFormat) + ' ' + s;
end;
// leave a space for the icon
// center the text if possible
if (h <= th) then begin
lbqueue.Canvas.TextOut(
rect.Left + h + 3, rect.Top, s
);
end else begin
lbqueue.Canvas.TextOut(
rect.Left + h + 3, floor((h-th)/2) + rect.Top, s
);
end;
//
// Draw/Clear the selection outline
//
c := lbQueue.Canvas.Brush.color;
if (odSelected in state) then begin
lbQueue.Canvas.Brush.Color := clHighlight;
lbQueue.Canvas.FrameRect(rect);
end else begin
lbqueue.Canvas.Brush.color := clWindow;
lbQueue.Canvas.FrameRect(rect);
end;
lbQueue.Canvas.Brush.color := c;
end;
procedure TfrmClipboardManager.lbQueueMeasureItem(Control: TWinControl;
Index: Integer; var Height: Integer);
begin
height := math.max(18, lbQueue.Canvas.TextHeight('ALKJDIOJ')+4);
end;
procedure TfrmClipboardManager.lbNontextDrawItem(Control: TWinControl;
Index: Integer; Rect: TRect; State: TOwnerDrawState);
var ci : TClipItem;
th, h : integer;
c : TColor;
begin
// height of rectangle & height of text on the listbox
h := (rect.Bottom - rect.top) + 1;
th := lbNontext.Canvas.TextHeight('ALKJDFIOJ');
// leave a space for the icon
// center the text if possible
if (h <= th) then begin
lbNontext.Canvas.TextOut(
rect.Left + h + 3, rect.Top,
lbNontext.Items.Strings[index]);
end else begin
lbNontext.Canvas.TextOut(
rect.Left + h + 3, floor((h-th)/2) + rect.Top,
lbNontext.Items.Strings[index]);
end;
//
// draw the icon leaving enough pixels above and below
// for the selection outline
//
ci := OtherQueue.GetClipItem(index);
if (ci <> nil) then begin
if (ci.CData.GetHICON <> 0) then begin
lbNontext.Canvas.Brush.Color := clWHite;
DrawIconEX(
lbNontext.Canvas.Handle, rect.Left+2, rect.Top+1,ci.CData.GetHICON,
h-2, h-2,
0,0,DI_NORMAL);
end;
end;
//
// Draw/Clear the selection outline
//
c := lbNontext.Canvas.Brush.color;
if (odSelected in state) then begin
lbNontext.Canvas.Brush.Color := clHighlight;
lbNontext.Canvas.FrameRect(rect);
end else begin
lbNontext.Canvas.Brush.color := clWindow;
lbNontext.Canvas.FrameRect(rect);
end;
lbNontext.Canvas.Brush.color := c;
end;
procedure TfrmClipboardManager.PageControl1Change(Sender: TObject);
begin
if (PageControl1.ActivePageIndex = 0) then begin
mPreview.Visible := true;
iPreview.Visible := false;
end else begin
bCopyAs.Visible := false;
mPreview.Visible := false;
iPreview.Visible := true;
end;
end;
procedure TfrmClipboardManager.lbNontextClick(Sender: TObject);
var ci : TClipITem;
begin
ci := TCLipITem(lbnontext.items.objects[lbNontext.ItemIndex]);
if ci.GetFormat = CF_DIB then begin
ipreview.Visible := true;
ci.GetDIB(ipreview.Picture);
end;
end;
procedure TfrmClipboardManager.lbNontextKeyDown(Sender: TObject;
var Key: Word; Shift: TShiftState);
begin
if (key = Windows.VK_DELETE) then begin
self.btnDelete.Click;
end;
end;
procedure TfrmClipboardManager.lbQueueKeyDown(Sender: TObject;
var Key: Word; Shift: TShiftState);
begin
if (key = Windows.VK_DELETE) then begin
self.btnDelete.Click;
end;
end;
end.