Softwarová Záchrana 3/Softwarova-zachrana-3.bin/ArsClip/source.zip/UnitClipQueue.pas

Pascal/Delphi Source File | 2004-10-11 | 46KB | 1,637 lines

unit UnitClipQueue;
{
    Purpose:
        Encapsulate all the rules of of the queue
        - number of items allowed
        - deleting icons on item removal (no memory leaks)
        - etc
        Handle a separate queue of items removed from the ClipQueue

    Updates:
        GetClipboardFormatName - check for failure
        -------------------
        Fix for 0 sized TPagedStringQueue

        ------------------
        Better way to enumerate the clipboard formats - single API call
        Workaround for WinXP when retreiving from clipboard


        ------------------
        Ability to save/load a clipboard item (TClipItem)
        Full color ICons

        ------------------
        Fix for DragQuery API (ClipItem) on Win9x machines.

        Revamped naming a little - removed some TClipItem wrapper functions
        from the queues (that weren't really a queue function).
        New Objects to simplify support for Rich Text, Unicode, and
        more. TClipData & TClipItem


        Added support for storing many data items along with text version of
        and item.
        Added support for loading a StringQueue (for Remove Items)

        --------------
        Created a basic StringQueue that's just a FIFO to be
        used for a RemovedQueue object.
        MoveDuplicateTop logic moved here (where it should be)
        Ignore duplicates durring Add or Instert
}


{ TODO: Investigate large HTML -> RichText clips failing if large}
{///////////////}
{//}interface{//}
{///////////////}
uses classes, Windows, Graphics {TPicture};

var ClipDataDefaultIcon : HICON;
{
    TClipData
        - data associated with a clipboard item ( aka TClipItem )
}
type TClipData = class(TObject)
    private
        size : cardinal;
        s : string;
        h : HICON;
        timestamp : TDateTime;

    public
        constructor Create(s : string; h : HICON);
        destructor Destroy; override;
        function GetString : string;
        function GetHICON : HICON;
        function GetHICONAbsolute : HICON; {used so the default icon is not saved}
        procedure SetString(s : string);
        procedure SetHICON(h : HICON);
        function GetCreationDate : TDateTime;
end;
{
    TClipItem
        - Get's data from the clipboard in native form,
        put's data on the clipboard, Keeps a plain text version of the item,
        and associates an icon with the handle (see TClipData)
}
const CF_FILE_RICHTEXT = CF_PRIVATEFIRST;
const CF_FILE_HTML = CF_PRIVATEFIRST + 1;

type TClipItem = class(TObject)
    private
        CFormat : WORD; {The format & Handle of the copied clipboard item}
        CHandle : THandle;  {The bare essentials for a clipboard item}

        function GetFilenamesAsText(h : THandle) : string;
        procedure CleanupMemory;
        //procedure PlaceOnClipboard;
    public
        CData : TClipdata; {Data relating to the clipboard item}
                           {Used to store a text version of the file and
                            save the ICON of the program that this text came from}
        constructor Create;
        destructor Destroy; override;


        function GetClipboardItem(hi : HICON; OverrideFormat : WORD = 0; SizeLimit : cardinal = $FFFF) : cardinal; overload;


        function GetAsText : string;
        function HasText : boolean;
        procedure OverrideTextVersionOfItem(s : string);
        function GetHandle : THandle;
        function GetDataSize : cardinal;
        function GetFormat : cardinal;
        function GetFormatName(AccessHandle : boolean = true) : string;
        procedure GetDIB(pic : TPicture);
        procedure GetRichText(var s : string);

        procedure SaveToFile(path : string; index : integer);
        procedure LoadFromFIle(path : string; index : integer);
        function GetFilename(path : string; index : integer) : string;

        procedure SaveIconToFile(path : string; index : integer; sufix : string = '');
        procedure LoadIconFromFile(path : string; index : integer; sufix : string = '');
        function GeticonFilename(path : string; index : integer; sufix : string = '') : string;
        {util}
        //function DupHandle(h : Thandle; var sizeh : cardinal; SizeLimit : boolean = false) : Thandle;
end;

{
    TStringQueue
        - Basic FIFO for strings
        - Enforces a total size
        - Override for populating the list
    NOTES:
        TStringList container because I don't want to deal with overriding
        all the many ways the list can be altered. Lazy, yes I am, but it also
        saves me from myself.
}
type TStringQueue = class(TObject)
    protected
        sl : TStringList;
        qSize : cardinal;
    public
        constructor Create;
        destructor Destroy; override;
        // init the rule
        procedure SetQueueSize(size : longint);

        // Add - for loading history, no size check
        // InsertAtStart - for FrmClipboardManagaer
        procedure AddNoSizeCheck(s : string);
        procedure InsertAtStart(s : string); overload;

        function GetQueueCount : cardinal;
        function GetItemText(index : cardinal) : string;


        procedure DeleteItem(index : cardinal); virtual;
        procedure ClearQueue; virtual;
end;

{
    TClipQueue
        - A string Queue that ass
}
type TClipQueue = class(TStringQueue)
    private
        MoveDuplicateTop : boolean;


    public
        constructor Create;
        destructor Destroy; override;


        {config options}
        procedure SetMoveDuplicateTop(enable: boolean);

        procedure MoveToStart(index : cardinal);
        procedure Move(oldIndex : cardinal; newIndex : cardinal);

        {add & retreive operations}
        procedure GetQueueItems(items : TStrings);
        procedure SetQueueItems(items : TStrings);

        procedure AddNoSizeCheck(s : string; ci : TClipItem = nil); virtual;
        procedure InsertAtStart(ci : TClipItem); overload;
        function GetClipItem(index : cardinal) : TClipItem;


        {find & delete}
        function IndexOf(s : string) : cardinal;  overload;
        function IndexOf(ci : TClipItem) : cardinal; overload;
        procedure DeleteItem(index : cardinal); override;
        procedure ClearQueue; override;
end;

{
    TPagedStringQueue
        Poor Engineering 101 here, but oh well. (Does not inherit
        from TStringQueue)

        - Circular queue of items 0-N but the Queue "start" is the first
        item in the list
        - Item 0 is the oldest item, Item (GetQueueCount - 1) is the newest
        item
}
const PAGED_EXT = '.ac';
const PAGED_CLIP_EXT = '.acz';
const PAGED_STATEFILE = 'start' + PAGED_EXT;
const PAGED_ICON_EXT = '.bmp';

type TPagedStringQueue = class(TObject)
    private
        base : string;
        filename : string;
        cache : string;
        iconcache : string;
        qSize : cardinal;
        qStart : cardinal;
        qCount : cardinal;

        ci : TClipITem;

        procedure SaveItem(s : string; index: cardinal; ci : TClipItem = nil);

        function IsEmptyItem(index : cardinal) : boolean;
        function IsEmptyItemAbsolute(absoluteIndex : cardinal) : boolean;
        function IsEmptyItemClipAbsolute(absoluteIndex : cardinal) : boolean;

        procedure RemoveOldestItem;
        procedure SaveQueueState;
        procedure ReIndexQueue;

        function IndexTranslate(index : cardinal) : cardinal;

        function GetItemAbsolute(absoluteIndex : cardinal) : string;
        function GetItemClipAbsolute(absoluteIndex : cardinal) : TClipItem;

        function GetFilename(index : cardinal) : string;
        function GetFilenameAbsolute(absoluteIndex : cardinal) : string;
        function GetFilenameClip(index : cardinal) : string;
        function GetFilenameClipAbsolute(absoluteIndex : cardinal) : string;
        function GetFilenameIcon1Absolute(absoluteIndex : cardinal) : string;
        function GetFilenameIcon2Absolute(absoluteIndex : cardinal) : string;
    public

        constructor Create(filename : string; folder : string = '');
        destructor Destroy; override;


        procedure InsertAtStart(s : string; ci : TClipItem = nil); overload;
        function GetQueueCount : cardinal;
        function GetItemText(index : cardinal) : string;
        function GetItemClip(Index: cardinal): TClipItem;

        procedure ClearQueue;
        procedure SetQueueSize(size : cardinal);
end;



var ClipQueue : TClipQueue;
var RemovedQueue : TPagedStringQueue;

{////////////////////}
{//}implementation{//}
{////////////////////}


uses UnitFrmMainPopup, UnitFrmClipboardManager, Forms {For Application object},
    Clipbrd, StrUtils, SysUtils, ShellAPI, Dialogs, UnitMisc, UnitPaste;




//-------------------
// (Con/De)structors
//-------------------
constructor TStringQueue.Create;
begin
    sl := TStringList.Create;
end;

destructor TStringQueue.Destroy;
begin
    MyFree(sl);
    inherited Destroy;
end;

procedure TStringQueue.SetQueueSize(size : longint);
begin
    qSize := size;
    while (sl.count > size) and (sl.count > 0) do
        self.DeleteItem(sl.count - 1);
end;

procedure TStringQueue.DeleteItem(index : cardinal);
begin
    sl.Delete(index);
end;

procedure TStringQueue.InsertAtStart(s : string);
begin
    sl.Insert(0,s);
    self.SetQueueSize(self.qSize);
end;

procedure TStringQueue.AddNoSizeCheck(s: string);
var i : longint;
begin
    i := sl.IndexOf(s);
    if (i = -1) then begin
        sl.Add(s);
    end;
end;




function TStringQueue.GetQueueCount : cardinal;
begin
    result := sl.count;
end;

function TStringQueue.GetItemText(index : cardinal) : string;
begin
    result := sl[index];
end;

procedure TStringQueue.ClearQueue;
var i : integer;
begin
    for i := (sl.count - 1) downto 0 do begin
        self.DeleteItem(i);
    end;
end;



//////////////////////////
//
// TClipQueue
//
//////////////////////////

//-------------------
// (Con/De)structors
//-------------------
constructor TClipQueue.Create;
begin
    sl := TStringList.Create;
end;

destructor TClipQueue.Destroy;
begin
    MyFree(sl);
    inherited Destroy;
end;


//-------------------
// Configuration
//-------------------
procedure TClipQueue.SetMoveDuplicateTop(enable: boolean);
begin
    self.MoveDuplicateTop := enable;
end;


//-------------------
// Public Interface
//-------------------


//
// items added to list
//
procedure TClipQueue.AddNoSizeCheck(s : string; ci : TClipItem = nil);
var i : longint;
begin
    // No dups, add move to top if configured to do so

    i := sl.IndexOf(s);
    if (i = -1) then begin
        sl.AddObject(s, ci);
    end else if (self.MoveDuplicateTop) then begin
        self.MoveToStart(i);
    end;
end;

procedure TClipQueue.InsertAtStart(ci : TClipItem);
var i : integer;
    ci2 : TClipItem;
begin
    i := sl.IndexOf(ci.GetAsText);
    if (i = -1) then begin
        sl.InsertObject(0, ci.GetAsText, ci);
        self.SetQueueSize(self.qSize);
    end else begin
        if (self.MoveDuplicateTop) then begin
            // delete an add it in its place if only differs in Case CASE case
            ci2 := self.GetClipItem(i);
            if CompareStr(ci2.GetAsText, ci.GetAsText) <> 0 then begin
                DeleteItem(i);
                sl.InsertObject(0, ci.GetAsText, ci);
                self.SetQueueSize(self.qSize);
            end else begin
                self.MoveToStart(i);
                UnitMisc.MyDestroyIcon(ci.CData.GetHICONAbsolute);
                UnitMisc.MyFree(ci);
            end;
        end;
    end

end;



procedure TClipQueue.SetQueueItems(items : TStrings);
begin
    //
    // trim queue if needed

    self.ClearQueue;
    sl.AddStrings(items);
    self.SetQueueSize(self.qSize);
end;



function TClipQueue.IndexOf(s : string) : cardinal;
begin
    result := sl.IndexOf(s);
end;

function TClipQueue.IndexOf(ci: TClipItem): cardinal;
begin
    result := sl.IndexOfObject(ci);
end;


procedure TClipQueue.GetQueueItems(items : TStrings);
begin
    items.Clear;
    items.AddStrings( sl );
end;


function TClipQueue.GetClipItem(index: cardinal): TClipItem;
    var ci : TClipItem;
begin
    ci := TClipItem(sl.Objects[index]);
    result := ci;
end;




//
// Move items in the list
//
procedure TClipQueue.MoveToStart(index : cardinal);
begin
    sl.Move(index, 0);
end;

procedure TClipQueue.Move(oldIndex : cardinal; newIndex : cardinal);
begin
    sl.Move(oldIndex, newindex);
end;



//
// Remove items from queue
// NOTE: Resources must be released here
//
procedure TClipQueue.DeleteItem(index : cardinal);
var ci : TClipItem;
begin
    // We've got to clean up the clone icon to avoid a memory leak
    ci := TClipITem(sl.Objects[index]);

    // Add the text to the removed items
    // ClipItem also has global memory to free
    RemovedQueue.InsertAtStart(self.GetItemText(index), ci);

    if (ci <> nil) then begin
        UnitMisc.AppendLog('^Deleting Icon^');
        MyDestroyIcon(ci.CData.GetHICON);
    end;
    MyFree(ci);


    // this MUST be the ONLY place an item is deleted
    sl.Delete(index);
end;


procedure TClipQueue.ClearQueue;
var i : longint;
begin
    // see note in DeleteQueueItem for rules of removing items
    // from queue
    // I know better, this must go in reverse order
    for i := (sl.count - 1) downto 0 do begin
        self.DeleteItem(i);
    end;

end;













//------------------------------
// ClipData / ClipItem
//------------------------------

{ TClipData }

constructor TClipData.Create(s: string; h: HICON);
begin
    self.s := s;
    self.h := h;
end;

destructor TClipData.Destroy;
var s : string;
begin
    s := 'du what?';
  inherited;
end;

function TClipData.GetCreationDate: TDateTime;
begin
    result := self.timestamp;
end;

function TClipData.GetHICON: HICON;
begin
    if (self.h = 0) then begin
        result := UnitClipQueue.ClipDataDefaultIcon;
    end else begin
        result := self.h;
    end;
end;

function TClipData.GetHICONAbsolute: HICON;
begin
    result := self.h;
end;

function TClipData.GetString: string;
begin
    result := self.s;
end;

procedure TClipData.SetHICON(h: HICON);
begin
    self.h := h;
end;

procedure TClipData.SetString(s: string);
begin
    self.s := s;
end;

{ TClipItem }

constructor TClipItem.Create;
begin
    self.CData := TClipData.Create('', 0);
    self.CHandle := 0;
    self.CFormat := 0;
end;

destructor TClipItem.Destroy;
begin
    self.CleanupMemory;
    MyFree(CData);
    inherited Destroy;
end;

procedure TClipItem.CleanupMemory;
begin
    if (self.CHandle <> 0) then begin
        Windows.GlobalFree(self.CHandle);
        self.CHandle := 0;
    end;
end;




function TClipItem.GetAsText: string;
begin
    result := CData.GetString;
end;

//
// Return the format of clipitem saved
// 0 = ERROR
// NOTES: GetAtText will return empty unless the clipboard has CF_TEXT or
// CF_HDROP
//
function TClipItem.GetClipboardItem( hi: HICON; OverrideFormat : word = 0; SizeLimit : cardinal = $FFFF): cardinal;
var files : string;
    CVolatileHandle : THandle;
    IsText : boolean;
    HasText : boolean;

    Procedure ChooseAFormat;
    begin
        if (not Windows.OpenClipboard(Application.Handle)) then begin
            UnitMisc.AppendLog('<ClipItem - can''t open clipboard> ', true);
            EXIT;
        end;

        // This gets the first and
        // most descriptive clipboard format the clipboard contains
        self.CFormat := Windows.EnumClipboardFormats(0);
        Windows.CloseClipboard;

        // OVERIDE format
        // CF_BITMAP kills over in DupHandle, CD_DIB does not
        // A wave clip may show up as a speaker icon if CF_WAVE is not
        // before CF_DIB

        HasText := Clipboard.HasFormat(CF_TEXT);
        if clipboard.HasFormat(CF_WAVE) then begin
            CFormat := CF_WAVE
        end else if clipboard.HasFormat(CF_DIB) then begin
            CFormat := CF_DIB
        end else if clipboard.HasFormat(CF_HDROP) then begin
            CFormat := CF_HDROP
        end else if clipboard.HasFormat(frmClipboardManager.CF_RICHTEXT) then begin
            CFormat := frmClipboardManager.CF_RICHTEXT;
            IsText := true;
        end else if clipboard.HasFormat(frmClipboardManager.CF_HTML) then begin
            CFormat := frmClipboardManager.CF_HTML;
            IsText := true;
        end else if clipboard.HasFormat(CF_UNICODETEXT) then begin
            CFormat := CF_UNICODETEXT;
            IsText := true;
        end;
        if (CFormat = CF_OEMTEXT) then begin
            CFormat := CF_TEXT;
            IsText := true;
        end;
        UnitMisc.AppendLog('<ClipItem Overided Format = ' + self.GetFormatName(false) );
    end;
begin
    UnitMisc.AppendLog('<ClipItem> ', true);
    Windows.SetLastError(ERROR_SUCCESS);     // workaround for some OS's
    CData.SetHICON(HI);  // incase retreival fails, we don't want to leak memory


    // find the current format
    // must be non-zero
    self.CleanupMemory;
    CFormat := 0;
    CHandle := 0;
    result := 0;
    IsText := false;
    try
        if OverrideFormat = 0 then begin
            ChooseAFormat;
        end else begin
            CFormat := OverrideFormat;
        end;

    except
        UnitMisc.AppendLog('<ClipItem - Find Format exception' + SysErrorMessage(GetLastError) );
        Windows.CloseClipboard;
        result := 0;
        CFormat := 0;
        CHandle := 0;
        EXIT;
    end;

    if (CFormat  = 0) then begin
        EXIT;
    end;


    //
    // Dupe the handle, exit on error
    //
    try

        //
        // Win9X will puke if you try to dup the handle and the clipboard is
        // not open. The VolatileHandle name reminds me that it is not to be
        // touched anywhere but here.
        //
        self.CData.size := SizeLimit;
        if not Windows.OpenClipboard(Application.Handle) then begin
            UnitMisc.AppendLog('<ClipItem - can''t open clipboard2 > ', true);
            EXIT;
        end;
        CVolatileHandle := Windows.GetClipboardData(CFormat);
        if (CVolatileHandle = 0) then begin
            UnitMisc.AppendLog('<ClipItem - can''t get handle > ', true);
            Windows.CloseClipboard;
            EXIT;
        end;
        CHandle := UnitMisc.DupHandle(CVolatileHandle, self.CData.size, (SizeLimit <> $FFFF));
        if (CHandle = 0) then begin
            UnitMisc.AppendLog('<ClipItem - can''t dup handle> ');
            Windows.CloseClipboard;
            EXIT;
        end;
        Windows.CloseClipboard;

        // save the extra data
        // Icon handle, Text version of item

        CData.SetHICON(HI);

        if (IsText or HasText) then begin
            CData.SetString(Clipboard.AsText);
        end else if (CFormat = CF_HDROP) then begin;
            files := self.GetFilenamesAsText(CHandle) ;
            UnitMisc.AppendLog('filenames: ' + files);
            CData.SetString(files);
        end else begin
            CData.SetString('');
        end;

    except
        on E: Exception do begin
            UnitMisc.AppendLog('<clipItem Dup Exception - ' + E.Message + ' ', true);
            Windows.CloseClipboard;
            CFormat := 0;
            CHandle := 0;
            result := 0;
            EXIT;
        end;
    end;

    {Future user - when the clip was created}
    cdata.timestamp := now;
    UnitMisc.AppendLog('<ClipItem ClipboardSave success!> size=' + IntToSTr(CData.size) );
    result := CFormat;
end;


// return all filenames or return empty string
function TClipItem.GetFilenamesAsText(h : THandle): string;
var i, j : longint;
    s : string;
begin
    Windows.SetLastError(ERROR_SUCCESS);
    result := '';

    if (CFormat = CF_HDROP) then begin
        UnitMisc.AppendLog('    Detecting Filenames...');

        try
            //
            // On Win9x, the handle must be on the clipboard and the clipboard
            // must be open; otherwise, bad bad stuff happens
            //
            UnitMisc.AppendLog('GetFilenamesAsText');
            s := stringofchar(#0, Windows.MAX_PATH+1);
            j := ShellApi.DragQueryFile(h, Cardinal(-1){//$FFFFFFFF}, nil, 0);
            UnitMisc.AppendLog('FileCount=' + IntToSTr(j));
            result := '';
            for i := 0 to (j - 1) do begin
                s := stringofchar(#0, Windows.MAX_PATH+1);
                ShellApi.DragQueryFile(h, i, pchar(s), Windows.MAX_PATH);
                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;

        except
            on e : exception do begin
                UnitMisc.AppendLog('GetFilenamesAsText' + #13#10 +
                    e.Message + ' ', true
                );
            end;
        end;
    end;
end;

function TClipItem.GetFormat: cardinal;
begin
    result := self.CFormat;
end;

function TClipItem.GetHandle: THandle;
begin
    result := self.CHandle;
end;

procedure TClipItem.OverrideTextVersionOfItem(s : string);
begin
    self.CData.SetString(s);
end;

{
procedure TClipItem.PlaceOnClipboard;
begin
    // moved all pasting logic to the appropreite location, the Paste Object
    if (CHandle <> 0) then begin
        Paste.SetClipboardOnlyOnce;
        Paste.SendText('', self);
    end else begin
        UnitMisc.AppendLog('ClipItem - PlaceOnClipboard failed ' + SysErrorMessage(GetLastError));
    end;
end;
}
function TClipItem.GetFormatName(AccessHandle : boolean = true) : string;
var name : array[0 .. 80] of char;
    format : cardinal;
    p : ^tagBITMAPINFO;
begin
    Windows.SetLastError(ERROR_SUCCESS);

    format := self.CFormat;

    case (format) of
        CF_DIB          : begin
            if (AccessHandle) then begin
                p := Windows.GlobalLock(CHandle);
                if (p <> nil) then begin
                    result := 'Picture (DIB) ' + IntToStr(p^.bmiHeader.biWidth) + 'x' + IntToStr(p^.bmiHeader.biHeight);
                    Windows.GlobalUnlock(self.Chandle);
                end else begin
                    UnitMisc.AppendLog('GetFormatName: ' + SysErrorMessage(GetLastError));
                end;
            end else begin
                result := 'Picture (DIB)';
            end;
        end;
        CF_WAVE         : result := 'Wave Audio';
        CF_BITMAP       : result := 'Picture (Bitmap)';
        CF_HDROP        : result := 'File(s)';

        CF_DIF          : result := 'CF_DIF';
        CF_TEXT         : result := 'CF_TEXT';
        CF_SYLK         : result := 'CF_SYLK';
        CF_TIFF         : result := 'CF_TIFF';
        CF_RIFF         : result := 'CF_RIFF';
        CF_LOCALE       : result := 'CF_LOCALE';
        CF_OEMTEXT      : result := 'CF_OEMTEXT';
        CF_PALETTE      : result := 'CF_PALETTE';
        CF_PENDATA      : result := 'CF_PENDATA';
        CF_UNICODETEXT  : result := 'Unicode';
        CF_ENHMETAFILE  : result := 'CF_ENHMETAFILE';
        CF_METAFILEPICT : result := 'CF_METAFILEPICT';
        else begin
            UnitMisc.AppendLog('Unknown format...');
            if Windows.GetClipboardFormatName(format,  @name,  sizeof(name)  ) <> 0 then begin
                Result := string(name);
                if (result  = '') then begin
                    result := 'Unknown';
                end;
            end else begin
                UnitMisc.AppendLog('Format Name failed', true);
                result := 'Error: Unknown';
            end;
        end;
   end;

end;

procedure TClipItem.GetDIB( pic : TPicture);
    procedure DibToBitmap(hDIB:  THandle; BM : TBitmap);
    var
        bmfh :  TBitmapFileHeader;
        bi :  PBitmapInfo;
        ms :  TMemoryStream;
        ColorsUsed : integer;
    begin
        bi := PBitmapInfo( Windows.GlobalLock(hDIB) );
        try
            // Caculate the number of colors used (power of 2)
            ColorsUsed := bi.bmiHeader.biClrUsed;
            if (ColorsUsed = 0) and (bi.bmiHeader.biBitCount <= 8) then
                ColorsUsed := 1 shl bi.bmiHeader.biBitCount;

            bmfh.bfType := $4D42;  // 'BM'
            bmfh.bfReserved1 := 0;
            bmfh.bfReserved2 := 0;

            // point to location of actual data
            // header is variable because of the RGBQuads
            bmfh.bfOffBits := SizeOf(TBitmapFileHeader)       +
                       SizeOf(TBitmapInfoHeader)       +
                       ColorsUsed * SizeOf(TRGBQuad);
            bmfh.bfSize := bmfh.bfOffBits + bi.bmiHeader.biSizeImage;

            // Create a fake bitmap file
            // and load it into a TBitmap
            ms := TMemoryStream.Create;
            try
                ms.Write(bmfh, SizeOf(TBitmapFileHeader));
                ms.Write(bi^, bmfh.bfSize - SizeOf(TBitmapFileHeader));
                ms.Position := 0;

                BM.LoadFromStream(ms)
            finally
                ms.Free
            end;
        finally
            Windows.GlobalUnlock(hDIB);
        end;
    end;

begin
    Windows.SetLastError(ERROR_SUCCESS);
    if (self.CFormat = CF_DIB) then begin
        DibToBitmap(self.CHandle, pic.Bitmap);
    end;
end;

procedure TClipItem.GetRichText(var s: string);
var p : PChar;
    ss : TStringStream;
begin
    p := Windows.GlobalLock(self.CHandle);
    if (p <> nil) then begin
        ss := TStringStream.Create('');
        ss.Write(p^, Windows.GlobalSize(self.CHandle));
        s := ss.DataString;

        Windows.GlobalUnlock(self.Chandle);

        MyFree(ss);
    end;
end;


//
// Static Objects
//

function TClipItem.GetDataSize: cardinal;
begin
    result := self.CData.size;
end;

function TClipItem.GetFilename(path: string; index: integer): string;
begin
    result := path + IntToHex(index, 8) + '.acz';
end;


procedure TClipItem.SaveToFile(path : string; index : integer);
var f : file;
    p : Pointer;
    w : word;
    clpname : string;
begin
    if self.CHandle = 0 then EXIT;
    if self.CData.size = 0 then EXIT;

    clpname := self.GetFilename(path, index);
    assign(f, clpname);
    rewrite(f,1);

    if (self.CFormat = frmClipboardManager.CF_RICHTEXT) then begin
        w := CF_FILE_RICHTEXT;
    end else if (self.CFormat = frmClipboardManager.CF_HTML ) then begin
        w := CF_FILE_HTML;
    end else begin
        w := self.CFormat;
    end;
    blockwrite(f, w, sizeof(self.CFormat));
    blockwrite(f, self.CData.size, sizeof(self.CData.size));

    p := GlobalLock(self.CHandle);
    blockwrite(f, p^, self.cdata.size);
    GlobalUnlock(self.CHandle);

    close(f);
end;

procedure TClipItem.LoadFromFile(path : string; index : integer);
var f : file;
    p : pointer;
    clpname : string;
begin
    clpname := self.GetFilename(path, index);
    if not (FileExists(clpname)) then begin
        EXIT;
    end;

    assignfile(f, clpname);
    reset(f,1);
    if filesize(f) = 0 then begin
        EXIT;
    end;
    try
        blockread(f, self.CFormat, sizeof(self.CFormat));
        if (self.CFormat =  CF_FILE_RICHTEXT) then begin
            self.CFormat := frmClipboardManager.CF_RICHTEXT;
        end else if (self.CFormat = CF_FILE_HTML) then begin
            self.CFormat := frmClipboardManager.CF_HTML;
        end;
        blockread(f, self.CData.size, sizeof(self.CData.size));
    except
        on e: exception do begin
            self.CHandle := 0;
            self.CData.size := 0;
            UnitMisc.AppendLog('TClipItem.LoadFromFile: read1 error' + SysErrorMessage(GetLastError));
        end;
    end;

    self.CHandle := GlobalAlloc(GMEM_MOVEABLE,self.CData.size);
    p := GlobalLock(self.CHandle);
    if (p = nil) then begin
        self.CHandle := 0;
        self.CData.size := 0;
        UnitMisc.AppendLog('TClipItem.LoadFromFile: error couldn''t lock handle!');
        EXIT;
    end;

    try
        blockread(F, p^, self.CData.size);
        GlobalUnlock(self.CHandle);
    except
        on e: exception do begin
            self.CHandle := 0;
            self.CData.size := 0;
            UnitMisc.AppendLog('TClipItem.LoadFromFile: read2 error' + SysErrorMessage(GetLastError));
        end;
    end;
    closefile(f);
end;

    {
    function BitmapToIcon(Bitmap: TBitmap): HICON;
    var x, y : integer;
        info : TIconInfo;
        image, mask : TBitmap;
        i, j : Integer;
        TransparentColor : TColor;
    begin
        // this entire routine doesn't work - it erases black instead
        // of preserving tranparency

        X := 32;
        Y := 32;

        image:= TBitmap.Create;
        image.Width:= X;
        image.Height:= Y;

        image.Canvas.StretchDraw(Rect(0, 0, X, Y), Bitmap);
        image.TransparentColor:= Bitmap.TransparentColor;

        TransparentColor:= image.TransparentColor and $FFFFFF;

        mask:= TBitmap.Create;
        //mask.Assign(image);
        mask.Monochrome := true;
        mask.Width := image.Width;
        mask.Height := image.Height;

        for i := 0 to (Y - 1) do begin
            for j:= 0 to (X - 1) do begin
                if (image.Canvas.Pixels[i, j] = TransparentColor) then begin
                    mask.Canvas.Pixels[i, j]:= clWhite;
                end else begin
                    mask.Canvas.Pixels[i, j]:= clBlack;
                end;
                //image.Canvas.Pixels[i,j] := image.Canvas.Pixels[i,j];
            end;
        end;

        info.fIcon := True;
        info.hbmMask := mask.MaskHandle;
        info.hbmColor := image.Handle;

        Result := CreateIconIndirect(info);

        mask.Free;
        image.Free;
    end;
    }


function TClipItem.GetIconFilename(path: string; index: integer; sufix : string = ''): string;
begin
    result := path + IntToHex(index, 8) + sufix + '.bmp';
end;

procedure TClipItem.LoadIconFromFile(path : string; index : integer; sufix : string = '');
var f : file;
    icn : TIcon;
var bit1, bit2 : TBitmap;
    info : _ICONINFO;
    iconName : string;
    h : HICON;
begin
    // legacy support
    // load the ICO version only if the BMP
    // version does not exist

    iconName := self.GetIconFilename(path, index, sufix);

    if (FileExists( stringreplace(iconName,'.bmp','-m.bmp',[rfignorecase])))
        and (FileExists( stringreplace(iconName,'.bmp','-c.bmp',[rfignorecase]))) then begin
    {if (FileExists(IconName)) then begin}
        // preserve transparency

        bit1 := TBitmap.Create;
        bit1.LoadFromFile(stringreplace(iconName,'.bmp','-m.bmp',[rfignorecase]));
        bit2 := TBitmap.Create;
        bit2.LoadFromFile(stringreplace(iconName,'.bmp','-c.bmp',[rfignorecase]));

        info.fIcon := true;
        info.xHotspot := 0;
        info.yHotspot := 0;
        info.hbmMask := bit1.Handle;
        info.hbmColor := bit2.Handle;

        h := Windows.CreateIconIndirect(info);
        self.CData.SetHICON( h );
        MyFree(bit1);
        MyFree(bit2);
        {
        bit := TBitmap.Create;
        bit.LoadFromFile(IconName);
        self.CData.SetHICON( BitmapToIcon(bit) );
        MyFree(bit);
        }
    end else begin
        iconName := path + IntToStr(index) + sufix + '.ico';

        if (FileExists(iconName)) then begin
            assignfile(f, iconname);
            Reset(f);
            if (FileSize(f) <> 0) then begin
                CloseFile(f);
                icn := TIcon.Create;
                icn.LoadFromFile(iconname);

                self.CData.SetHICON(icn.Handle);

                //icn.free; {Can't free this icon - it will destroy the HICON}
            end;
        end;
    end;
end;

procedure TClipItem.SaveIconToFile(path : string; index : integer; sufix : string = '');
var bit1, bit2 : TBitmap;
    info : _ICONINFO;
    iconName : string;
begin
    iconName := Self.GeticonFilename(path, index, sufix);
    if (self.CData.GetHICONAbsolute <> 0) then begin
        bit1 := TBitmap.Create;
        bit2 := TBitmap.Create;

        Windows.GetIconInfo(self.CData.GetHICONAbsolute, info);
        bit1.Handle := info.hbmMask;
        bit1.SaveToFile( stringreplace(iconName,'.bmp','-m.bmp',[rfIgnoreCase]));

        bit2.Handle := info.hbmColor;
        bit2.SaveToFile( stringreplace(iconName,'.bmp','-c.bmp',[rfIgnoreCase]));
        MyFree(bit1);
        MyFree(bit2);
    end else begin
        //
        // Without this, null icons will use old cached icon from other clips
        //
        DeleteFile(stringreplace(iconName,'.bmp','-m.bmp',[rfIgnoreCase]));
        DeleteFile(stringreplace(iconName,'.bmp','-c.bmp',[rfIgnoreCase]));
    end;
    {
    //
    // This works, but I can't find a way to load it correctly.
    // Saving mask and image separately works for me
    //
    bit := TBitmap.Create;
    bit.width := 32;
    bit.height := 32;
    // 24 bit kills transparency
    bit.PixelFormat := pf8bit;

    DrawIcon(bit.Canvas.Handle,0,0,self.CData.GetHICON);

    bit.SaveToFile(iconName);
    MyFree(bit);
    }
end;

function TClipItem.HasText: boolean;
begin
    result := (self.GetAsText <> '') and (self.CFormat <> CF_HDROP);
end;



{ TPagedStringQueue }

//--------------------
// Public Interface
//--------------------
constructor TPagedStringQueue.Create(filename: string; folder : string = '');
var tf : textfile;
    s, itemText : string;
    linecount, i, itemcount : integer;
begin
    self.ci := TClipItem.Create;

    self.base := IncludeTrailingPathDelimiter(ExtractFilePath(Application.ExeName));
    if folder = '' then begin
        self.cache :=  self.base + 'removedcache\';
    end else begin
        self.cache := IncludeTrailingPathDelimiter( self.base + folder );
    end;
    self.filename := self.base + filename;
    SysUtils.ForceDirectories(cache);
    self.iconcache := self.cache + 'iconcache\';
    SysUtils.ForceDirectories(self.iconcache);

    //
    // legacy stuff - move the old file into the new cache
    //
    if (FileExists(self.filename)) then begin
        AssignFile(tf, filename);
        Reset(tf, filename);

        try
            itemcount := 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;
                    self.qSize := itemCount + 1;
                    self.SaveItem(itemText, itemcount);

                    inc(itemcount);
                except
                    on E: Exception do begin
                        ShowMessage('The "Load items from last session" file is corrupted - ' + filename + #13#10#13#10 +
                                    'Error Message: ' + E.Message);
                        break;
                    end;
                end;
            end;
        finally
            CloseFile(tf);
        end;

        DeleteFile(self.filename);
    end;


    // fake having a zero based, largest possible queue
    // until we find the real count and size
    self.qSize := 0;
    self.qStart := 0;
    i := 0;
    self.qSize := $ffffffff;
    while FileExists(self.GetFilenameAbsolute(i)) do begin
        if (not self.IsEmptyItemAbsolute(i)) then begin
            inc(self.qCount);
        end;
        inc(i);
    end;
    self.qSize := i;

    // get the real "zero" item index
    if (FileExists(self.cache + PAGED_STATEFILE)) then begin
        assignfile(tf, self.cache + PAGED_STATEFILE);
        reset(tf);
        read(tf, self.qStart);
        close(tf);
    end else begin
        self.qStart := 0;
    end;

end;

destructor TPagedStringQueue.Destroy;
begin
    inherited;
end;

procedure TPagedStringQueue.InsertAtStart(s: string; ci : TClipItem = nil);
begin
    // ensure the queue has 1 free spot
    while (self.qCount >= self.qSize) and (self.qCount <> 0) do begin
        self.RemoveOldestItem;
    end;

    // save the item at the end of the queue
    self.SaveItem(s, self.qCount, ci);
    inc(self.qCount);
    self.SaveQueueState;
end;

function TPagedStringQueue.GetQueueCount: cardinal;
begin
    result := self.qCount;
end;

procedure TPagedStringQueue.ClearQueue;
begin
    {Too simple eh?}
    while (self.qCount > 0) do begin
        self.RemoveOldestItem;
    end;
    self.qStart := 0;
    self.SaveQueueState;
end;

procedure TPagedStringQueue.SaveQueueState;
var tf : textfile;
begin
    assignfile(tf, cache + PAGED_STATEFILE);
    rewrite(tf);
    write(tf, self.qStart);
    close(tf);
end;


procedure TPagedStringQueue.SetQueueSize(size: cardinal);
var fn : string;
    i : integer;
    tf : textfile;
begin
    // Make sure all files exist within the circular queue
    // (when the queue size is enlarged)
    // Make sure new items are blank
    for i := 0 to (size - 1) do begin
        fn := self.GetFilenameAbsolute(i);
        if not FileExists(fn) or
            (cardinal(i) >= self.qSize) then begin
            Assign(tf, fn);
            Rewrite(tf);
            Close(tf);
        end;
    end;

    // To Shrink the paged queue.....
    // Remove oldest items
    // Re-index items from 0-(qSize - 1)  so that virtual indexes
    // match the actuall indexes.
    // Break the contigous numbers so that only 0-(size-1) exists
    // contigously

    while (self.qCount > size) do begin
        self.RemoveOldestItem;
    end;

    self.ReIndexQueue;

    fn := self.GetFilenameAbsolute(size);
    if (FileExists(fn)) then begin
        DeleteFile(fn);
    end;

    self.qSize := size;
    self.SaveQueueState;
end;

function TPagedStringQueue.GetItemText(index: cardinal): string;
begin
    index := IndexTranslate(index);
    result := self.GetItemAbsolute(index);
end;
function TPagedStringQueue.GetItemClip(Index: cardinal): TClipItem;
begin
    result := self.GetItemClipAbsolute(IndexTranslate(index));
    if (result <> nil) then begin
        result.LoadIconFromFile(self.iconcache, IndexTranslate(index) );
    end;
end;


//-----------------------
// Private Implementation
//-----------------------

procedure TPagedStringQueue.SaveItem(s : string; index: cardinal; ci : TClipItem = nil);
var tf : textfile;
begin
    if self.qSize = 0 then EXIT;

    Assign(tf, self.GetFilename(index));
    Rewrite(tf);
    write(tf, s);
    close(tf);

    if (ci <> nil) then begin
        ci.SaveToFile(self.cache, self.IndexTranslate(index) );
        if (ci.CData.GetHICONAbsolute <> 0) then begin
            ci.SaveIconToFile(self.iconcache, self.IndexTranslate(index) );
        end;
    end;
end;


function TPagedStringQueue.IsEmptyItem(index: cardinal): boolean;
begin
    result := self.IsEmptyItemAbsolute(IndexTranslate(index));
end;
function TPagedStringQueue.IsEmptyItemAbsolute(
  absoluteIndex: cardinal): boolean;
var f : file;
    fn : string;
    fs : cardinal;
begin
    fn := self.GetFilenameAbsolute(absoluteIndex);
    Assign(f, fn);
    Reset(f, 1);
    try
        fs := FileSize(f);
        result := (fs = 0);
    finally
        Close(f);
    end;
end;

function TPagedStringQueue.IsEmptyItemClipAbsolute(
  absoluteIndex: cardinal): boolean;
var f : file;
    fn : string;
    fs : cardinal;
begin
    fn := self.GetFilenameClipAbsolute(absoluteIndex);
    Assign(f, fn);
    Reset(f, 1);
    try
        fs := FileSize(f);
        result := (fs = 0);
    finally
        Close(f);
    end;
end;




function TPagedStringQueue.IndexTranslate(index: cardinal): cardinal;
begin
    // since this is a circular queue, item "0" can actually
    // start anywhere from 0 to qSize - 1

    result := (self.qStart + index) mod self.qSize;
end;


procedure TPagedStringQueue.RemoveOldestItem;
var fn : string;
begin
    // "delete" the first/oldest item in the list
    if (self.qSize = 0) then begin
        fn := self.GetFilenameAbsolute(0);
        if (FileExists(fn)) then begin
            DeleteFile(fn);
        end;
        self.qCount := 0;
    end else begin
        self.SaveItem('', 0);
        self.qStart := (self.qStart + 1) mod qSize;
        dec(self.qCount);
    end;
end;

procedure TPagedStringQueue.ReIndexQueue;
var s1, s2 : string;
    i, k : integer;
begin
    if self.qStart = 0 then EXIT;

    // move virtual items 0-n to absolute indexes 0-n
    // replace the extension of all items so there are no name clashed
    // when re-ordering the items

    for i := 0 to self.qSize do begin
        s1 := self.GetFilenameAbsolute(i);
        RenameFile(s1, stringreplace(s1, PAGED_EXT, '.bak', []));

        s1 := self.GetFilenameClipAbsolute(i);
        RenameFile(s1, stringreplace(s1, PAGED_CLIP_EXT, '.baz', []));

        s1 := self.GetFilenameIcon1Absolute(i);
        RenameFile(s1, stringreplace(s1, PAGED_ICON_EXT, '.bak', []));

        s1 := self.GetFilenameIcon2Absolute(i);
        RenameFile(s1, stringreplace(s1, PAGED_ICON_EXT, '.bak', []));
    end;


    // move absolute item X to virtual item X
    i := self.qStart;
    k := 0;
    repeat
        s1 := stringreplace(self.GetFilenameAbsolute(i), PAGED_EXT,'.bak',[]);
        s2 := self.GetFilenameAbsolute(k);
        if FileExists(s1) then
            RenameFile(s1, s2);

        s1 := stringreplace(self.GetFilenameClipAbsolute(i), PAGED_CLIP_EXT,'.baz',[]);
        s2 := self.GetFilenameClipAbsolute(k);
        if FileExists(s1) then
            RenameFile(s1, s2);


        s1 := stringreplace(self.GetFilenameIcon1Absolute(i), PAGED_ICON_EXT,'.bak',[]);
        s2 := self.GetFilenameIcon1Absolute(k);
        if FileExists(s1) then
            RenameFile(s1, s2);

        s1 := stringreplace(self.GetFilenameIcon2Absolute(i), PAGED_ICON_EXT,'.bak',[]);
        s2 := self.GetFilenameIcon2Absolute(k);
        if FileExists(s1) then
            RenameFile(s1, s2);

        i := Cardinal(i + 1) mod self.qSize;
        inc(k);
    until (Cardinal(i) = self.qStart);
    self.qStart := 0;
end;



function TPagedStringQueue.GetFilename(index: cardinal): string;
begin
    index := self.IndexTranslate(index);
    result := self.GetFilenameAbsolute(index);
end;
function TPagedStringQueue.GetFilenameClip(index: cardinal): string;
begin
    index := self.IndexTranslate(index);
    result := self.GetFilenameClipAbsolute(index);
end;



function TPagedStringQueue.GetFilenameAbsolute(
  absoluteIndex: cardinal): string;
begin
    result := self.cache + IntToHex(absoluteIndex,8) + PAGED_EXT;
end;
function TPagedStringQueue.GetFilenameClipAbsolute(
  absoluteIndex: cardinal): string;
begin
    result := ci.GetFilename(self.cache, absoluteIndex);
end;
function TPagedStringQueue.GetFilenameIcon1Absolute(
  absoluteIndex: cardinal): string;
begin
    result := ci.GeticonFilename(self.iconcache, absoluteIndex, '-m');
end;
function TPagedStringQueue.GetFilenameIcon2Absolute(
  absoluteIndex: cardinal): string;
begin
    result := ci.GeticonFilename(self.iconcache, absoluteIndex, '-c');
end;

function TPagedStringQueue.GetItemAbsolute(
  absoluteIndex: cardinal): string;
var f : text;
    filename, s : string;
begin
    filename := self.GetFilenameAbsolute(absoluteIndex);
    result := '';
    s := '';
    if (FileExists(filename)) then begin
        try
            Assign(f, filename);
            FileMode := 0;
            Reset(f);
            while not eof(f) do begin
                readln(f,s);
                if (result <> '') then begin
                    result := result + #13#10  + s;
                end else begin
                    result := s;
                end;
            end;
            close(f);
        except
            on e : exception do begin
                UnitMisc.AppendLog('GetItemAbsolute: ' + e.Message );
            end;
        end;
    end;
end;
function TPagedStringQueue.getItemClipAbsolute(
  absoluteIndex: cardinal): TClipItem;
begin
    result := nil;

    if FileExists(self.GetFilenameClipAbsolute(absoluteIndex)) then begin
        result := TClipItem.Create;
        result.LoadFromFIle(self.cache, absoluteIndex);
    end;
end;




{////////////////////}
{//}initialization{//}
{////////////////////}
begin
    RemovedQueue := TPagedStringQueue.Create('removed.txt', 'removedcache\');

    ClipQueue := TClipQueue.Create;
    ClipDataDefaultIcon := LoadIcon(0, IDI_APPLICATION);
end;
{//////////////////}
{//}finalization{//}
{//////////////////}
begin
    RemovedQueue.Free;
    ClipQueue.Free;
end;
end.