Clipboard backup

I am using some code I found in this thread:

http://www.experts-exchange.com/Programming/Languages/Pascal/Delphi/Q_20126222.html

The problem with this code is that SetClippedData() opens and closes the clipboard one time per clipboard format when restoring the saved clipboard. This generates unnecessary clipboard messages and in some cases causes problems. I have tried to make it such that the Clipboard is opened once, but I am having problems with the memory management.

Can anyone figure it out?

Here is the code from the mentioned thread:

Button1 saves and Button2 restores:


unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Clipbrd;

type
  PClips = ^TClips;
  TClips = record
    cf:   Word;
    buf:  Pointer;
    size: Cardinal;
  end;

  TForm1 = class(TForm)
    Button1: TButton;
    ListBox1: TListBox;
    ListBox2: TListBox;
    ListBox3: TListBox;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
    ClipList: TList;
    procedure GetClippedData(cf: Cardinal; var buf: Pointer; var size: Cardinal);
    function SetClippedData(cf: Cardinal; buf: Pointer; size: Cardinal): boolean;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var i: Integer;
    blk: PClips;
begin
  ClipList := TList.Create;
  for i := 0 to Clipboard.FormatCount - 1 do
  begin
    New(blk);
    blk.cf := Clipboard.Formats[i];
    GetClippedData(blk.cf, blk.buf, blk.size);
    ClipList.Add(blk);
    ListBox1.Items.Add(IntToStr(blk.cf));
    ListBox2.Items.Add(IntToStr(Integer(blk.buf)));
    ListBox3.Items.Add(IntToStr(blk.size));
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var blk: PClips;
begin
  Clipboard.Clear;
  while ClipList.Count > 0 do
  begin
    blk := ClipList.Items[0];
    SetClippedData(blk.cf, blk.buf, blk.size);
    Dispose(blk);
    ClipList.Delete(0);
  end;
  ClipList.Free;
end;

procedure TForm1.GetClippedData(cf: Cardinal; var buf: Pointer; var size: Cardinal);
var hmem: Cardinal;
    lock: Pointer;
begin
  if OpenClipboard(Handle) then
  begin
    hmem := GetClipboardData(cf);
    if hmem = 0 then
      buf := nil
    else begin
      size := GlobalSize(hmem);
      buf := AllocMem(size);
      lock := GlobalLock(hmem);
      CopyMemory(buf, lock, size);
      GlobalUnlock(hmem);
    end;
    CloseClipboard;
  end
  else
    buf := nil;
end;

function TForm1.SetClippedData(cf: Cardinal; buf: Pointer; size: Cardinal): boolean;
var hmem, sd: Cardinal;
    lock: Pointer;
begin
  // Allocate memory in the global heap
  // Do not free it in this app. It will be freed when the clipboard is cleared
  hmem := GlobalAlloc(GMEM_DDESHARE or GMEM_MOVEABLE, size);

  lock := GlobalLock(hmem);
  CopyMemory(lock, buf, size);
  FreeMem(buf);
  GlobalUnlock(hmem);

  if OpenClipboard(Handle) then
  begin
    sd := SetClipboardData(cf, hmem);
    CloseClipboard;
    Result := (sd <> 0);
  end
  else
    Result := false;
end;

end.

Dream-Asked:
Who is Participating?
 
diniludCommented:
Project1.dpr
==========


program Project1;

uses
  Forms,
  Unit1 in 'Unit1.pas' {Form1},
  Unit2 in 'Unit2.pas';

{$R *.res}

begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.


Unit1.dfm
========

object Form1: TForm1
  Left = 386
  Top = 25
  Width = 325
  Height = 381
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  FormStyle = fsStayOnTop
  OldCreateOrder = False
  OnClose = FormClose
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object Button1: TButton
    Left = 64
    Top = 232
    Width = 193
    Height = 41
    Caption = 'Save Clipboard'
    TabOrder = 0
    OnClick = Button1Click
  end
  object Button2: TButton
    Left = 64
    Top = 288
    Width = 193
    Height = 41
    Caption = 'Restore Clipboard'
    TabOrder = 1
    OnClick = Button2Click
  end
  object Memo1: TMemo
    Left = 16
    Top = 8
    Width = 273
    Height = 193
    Lines.Strings = (
      'Memo1')
    TabOrder = 2
  end
  object Timer1: TTimer
    OnTimer = Timer1Timer
    Left = 16
    Top = 232
  end
end

Unit1.pas
========

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, ClipBrd;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Memo1: TMemo;
    Timer1: TTimer;
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    { Private declarations }
    FClipList:TList;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses Unit2;

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
  FClipList:=TList.Create;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  FClipList.Free;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Screen.Cursor:=crHourGlass;
  GetClippedDataToList(FClipList,Application.Handle);
  Screen.Cursor:=crDefault;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  Screen.Cursor:=crHourGlass;
  SetClippedDataFromList(FClipList,Application.Handle);
  FreeAllList(FClipList);
  Screen.Cursor:=crDefault;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var GetClipText:Boolean;
begin
Timer1.Enabled:=False;
Button1.click;

    keybd_event(VK_CONTROL, MapVirtualKey(VK_CONTROL, 0), 0, 0);
    keybd_event(Ord('C'), MapVirtualKey(Ord('C'), 0), 0, 0);
    keybd_event(Ord('C'), MapVirtualKey(Ord('C'), 0), KEYEVENTF_KEYUP, 0);
    keybd_event(VK_CONTROL, MapVirtualKey(VK_CONTROL, 0), KEYEVENTF_KEYUP, 0);
  try
    GetClipText:=False;
    while not GetClipText do
    begin
      if CanOpenClipBoard(Application.Handle) then
      begin
        Memo1.Lines.Text := Clipboard.AsText;
        GetClipText:=True;
      end
      else Sleep(10);
    end;
  except
  end;
  Button2.Click;
Timer1.Enabled:=True;
end;

end.

Unit2.pas
===========

unit Unit2;

interface

uses Windows, Classes, SysUtils, Clipbrd;


type
  PClips = ^TClips;
  TClips = record
    cf:   Word;
    buf:  Pointer;
    size: Cardinal;
  end;

procedure GetClippedDataToList(var List:TList;Handle:HWND);
procedure SetClippedDataFromList(var List:TList;Handle:HWND);
procedure FreeAllList(Var List:TList);

Function CanOpenClipBoard(Handle:HWND):Boolean;

implementation

procedure GetClippedDataToList(var List:TList;Handle:HWND);
var i:Integer;    hmem: Cardinal;
    lock: Pointer; blk: PClips;
    FormatCount:Integer;
begin
  FormatCount:=Clipboard.FormatCount;
  for i:=0 to Clipboard.FormatCount-1 do
  begin
    New(blk);
    blk.cf := Clipboard.Formats[i];
    List.Add(blk);
  end;
  if OpenClipboard(Handle) then
  begin
     for i:=0 to FormatCount-1 do
     begin
        blk:= List.Items[i];
        hmem := GetClipboardData(blk.cf);
        if hmem = 0 then blk.buf := nil
        else
        begin
           blk.size := GlobalSize(hmem);
           blk.buf := AllocMem(blk.size);
           lock := GlobalLock(hmem);
           CopyMemory(blk.buf, lock, blk.size);
           GlobalUnlock(hmem);
        end;
     end;
     CloseClipboard;
  end;
end;

procedure SetClippedDataFromList(var List:TList;Handle:HWND);
var i:Integer;blk: PClips;
    hmem: Cardinal;
    lock: Pointer;
begin
  Clipboard.Clear;
  if OpenClipboard(Handle) then
  begin
     for i:=0 to List.Count-1 do
     begin
       blk := List.Items[i];
       try
         hmem := GlobalAlloc(GMEM_DDESHARE or GMEM_MOVEABLE, blk.size);
         lock := GlobalLock(hmem);
         CopyMemory(lock, blk.buf, blk.size);
         SetClipboardData(blk.cf, hmem)
       finally
         GlobalUnlock(hmem);
       end;
     end;
     CloseClipboard;
  end;
end;

procedure FreeAllList(Var List:TList);
var i:Integer; blk: PClips;
begin
  for i:=List.Count-1 downto 0 do
  begin
     blk:=List.Items[i];
     FreeMem(blk.buf);
     Dispose(blk);
     List.Delete(i);
  end;
end ;

Function CanOpenClipBoard(Handle:HWND):Boolean;
begin
  Result:=OpenClipboard(Handle);
end;

end.
0
 
diniludCommented:
Program1.dpr
=============

program Project2;

uses
  Forms,
  Unit1 in 'Unit1.pas' {Form1},
  Unit2 in 'Unit2.pas';

{$R *.res}

begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.


Unit.dfm
========

object Form1: TForm1
  Left = 178
  Top = 229
  Width = 325
  Height = 202
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  OnClose = FormClose
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object Button1: TButton
    Left = 56
    Top = 24
    Width = 193
    Height = 41
    Caption = 'Save Clipboard'
    TabOrder = 0
    OnClick = Button1Click
  end
  object Button2: TButton
    Left = 56
    Top = 96
    Width = 193
    Height = 41
    Caption = 'Restore Clipboard'
    TabOrder = 1
    OnClick = Button2Click
  end
end



Unit1.pas
=========

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
    FClipList:TList;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses Unit2;

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
  FClipList:=TList.Create;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  FClipList.Free;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Screen.Cursor:=crHourGlass;
  GetClippedDataToList(FClipList,Handle);
  Screen.Cursor:=crDefault;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  Screen.Cursor:=crHourGlass;
  SetClippedDataFromList(FClipList,Handle);
  FreeAllList(FClipList);
  Screen.Cursor:=crDefault;
end;

end.

Unit2.pas
=========

unit Unit2;

interface

uses Windows, Classes, SysUtils, Clipbrd;


type
  PClips = ^TClips;
  TClips = record
    cf:   Word;
    buf:  Pointer;
    size: Cardinal;
  end;

procedure GetClippedDataToList(var List:TList;Handle:HWND);
procedure SetClippedDataFromList(var List:TList;Handle:HWND);
procedure FreeAllList(Var List:TList);

implementation

procedure GetClippedDataToList(var List:TList;Handle:HWND);
var i:Integer;    hmem: Cardinal;
    lock: Pointer; blk: PClips;
    FormatCount:Integer;
begin
  FormatCount:=Clipboard.FormatCount;
  for i:=0 to Clipboard.FormatCount-1 do
  begin
    New(blk);
    blk.cf := Clipboard.Formats[i];
    List.Add(blk);
  end;
  if OpenClipboard(Handle) then
  begin
     for i:=0 to Clipboard.FormatCount-1 do
     begin
        blk:= List.Items[i];
        hmem := GetClipboardData(blk.cf);
        if hmem = 0 then blk.buf := nil
        else
        begin
           blk.size := GlobalSize(hmem);
           blk.buf := AllocMem(blk.size);
           lock := GlobalLock(hmem);
           CopyMemory(blk.buf, lock, blk.size);
           GlobalUnlock(hmem);
        end;
     end;
     CloseClipboard;
  end;
end;

procedure SetClippedDataFromList(var List:TList;Handle:HWND);
var i:Integer;blk: PClips;
    hmem: Cardinal;
    lock: Pointer;
begin
  Clipboard.Clear;
  if OpenClipboard(Handle) then
  begin
     for i:=0 to List.Count-1 do
     begin
       blk := List.Items[i];
       try
         hmem := GlobalAlloc(GMEM_DDESHARE or GMEM_MOVEABLE, blk.size);
         lock := GlobalLock(hmem);
         CopyMemory(lock, blk.buf, blk.size);
         SetClipboardData(blk.cf, hmem)
       finally
         GlobalUnlock(hmem);
       end;
     end;
     CloseClipboard;
  end;
end;

procedure FreeAllList(Var List:TList);
var i:Integer; blk: PClips;
begin
  for i:=List.Count-1 downto 0 do
  begin
     blk:=List.Items[i];
     FreeMem(blk.buf);
     Dispose(blk);
     List.Delete(i);
  end;
end ;


end.


0
 
Dream-Author Commented:
I tried this code and just pressing the buttons seems to work ok. But when I to use it as follows I get a "Cannot Open Cliboard" Exception and after two attempts an Access Violation.

On a Global Hotkeypress (could also be tested using a timer to trigger this while another app is in focus):

 Button1.click;

    keybd_event(VK_CONTROL, MapVirtualKey(VK_CONTROL, 0), 0, 0);
    keybd_event(Ord('C'), MapVirtualKey(Ord('C'), 0), 0, 0);
    keybd_event(Ord('C'), MapVirtualKey(Ord('C'), 0), KEYEVENTF_KEYUP, 0);
    keybd_event(VK_CONTROL, MapVirtualKey(VK_CONTROL, 0), KEYEVENTF_KEYUP, 0);

  Memo1.Lines.Add( Clipboard.AsText );

  Button2.Click;

I am Backing up the clipboard, then sending a Ctrl-C to the focused application, putting the contents into a Memo and then restoring the clipboard. In this example it is just text but could be a different clipboard format.

Any Ideas?
0
Get expert help—faster!

Need expert help—fast? Use the Help Bell for personalized assistance getting answers to your important questions.

 
diniludCommented:
>>"Cannot Open Cliboard" Exception

because that time some other application is using the clipboard.

0
 
Dream-Author Commented:
Right. But what would be a good solution to the problem?

I think I can insert my app into the clipboard chain and trigger the copying to the memo once the copying from the other app is done.

Any other ways to solve it?
0
 
Dream-Author Commented:
I just tried the Clipboard chain approach and the delay approach you posted. They both seem to work.

Thank you very much I really appreciate it!
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.