[Okta Webinar] Learn how to a build a cloud-first strategyRegister Now

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 778
  • Last Modified:

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.

0
Dream-
Asked:
Dream-
  • 3
  • 3
1 Solution
 
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
 
diniludCommented:
>>"Cannot Open Cliboard" Exception

because that time some other application is using the clipboard.

0
Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
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
 
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
 
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

Featured Post

Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

  • 3
  • 3
Tackle projects and never again get stuck behind a technical roadblock.
Join Now