FireMonkeyで画像をクリップボードで処理するには (ID:41507)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

DEKOさん  ありがとうございます。
やはり、このHPしかないようですね。
そのまま、やってみてもエラーばかりでしたが、適当にいじっていくと動くようになりました。
でも・・・・本当にこれでいいのかまったく自信がありません。
ソースをすべて書きますので、添削いただければ幸いです。
”<====ORG  ”の部分はHPからの元のソースです。

uses
  System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants, Winapi.Windows  ,
  FMX.Types, FMX.Controls, FMX.Forms, FMX.Dialogs,  FMX.Objects   ,FMX.Platform  ;

//  Winapi.Windows   の位置に注意が必要みたいです  なぜ？？

type
  TForm1 = class(TForm)
    Btn_To_Clip_: TButton;
    Btn_From_Clip_: TButton;
    Image1:  TImage;
    procedure Btn_To_Clip_Click(Sender: TObject);
    procedure Btn_From_Clip_Click(Sender: TObject);
  private
    { private 宣言 }

function  CanPasteBitmapFromClipboard: Boolean;
     procedure CopyBitmapToClipboard(Bitmap: TBitmap);
     function  PasteBitmapFromClipboard(Bitmap: TBitmap): Boolean;
  public
    { public 宣言 }

end;

var
  Form1: TForm1;

implementation

{$R *.fmx}

procedure TForm1.Btn_To_Clip_Click(Sender: TObject);
var
  MyBitmap:TBitmap;
begin
  MyBitmap := TBitmap.Create(0,0);
  try
    MyBitmap.Assign(Image1.Bitmap);
    CopyBitmapToClipboard(MyBitmap );
  finally
    MyBitmap.Free;
  end;
end;

procedure TForm1.Btn_From_Clip_Click(Sender: TObject);
var
  MyBitMap:TBitMap;
begin
  MyBitmap := TBitmap.Create(0,0);
  try
    PasteBitmapFromClipboard(MyBitMap);
    Image1.Bitmap.Assign(MyBitMap);
  finally
    MyBitMap.Free;
  end;
end;

function TForm1.CanPasteBitmapFromClipboard: Boolean;
begin
  Result := IsClipboardFormatAvailable(CF_DIB);
end;

procedure TForm1.CopyBitmapToClipboard(Bitmap: TBitmap);
var
  BitsSize: Integer;
  MemObj  : HGLOBAL;
  Ptr     : PBitmapInfoHeader;
begin
  BitsSize := Bitmap.Width  * Bitmap.Height * 4; //<=====ORG

MemObj := GlobalAlloc(GMEM_MOVEABLE and GMEM_DDESHARE, SizeOf(TBitmapInfoHeader) + BitsSize);
  if MemObj = 0 then RaiseLastOSError;
  Ptr := GlobalLock(MemObj);
  if Ptr = nil then
  begin
    GlobalFree(MemObj);
    RaiseLastOSError;
  end;
  //fill out the info header
  FillChar(Ptr^, SizeOf(Ptr^), 0);
  Ptr.biSize := SizeOf(TBitmapInfoHeader);
  Ptr.biPlanes := 1;
  Ptr.biBitCount := 32;
  Ptr.biCompression := BI_RGB;
  //Ptr.biWidth := Bitmap.Width;
  //Ptr.biWidth := Bitmap.bmWidth; //<=====ORG
  Ptr.biWidth := Bitmap.Width;

if Ptr.biWidth <= 0 then Ptr.biWidth := 1;
  //Ptr.biHeight := -Bitmap.Height;
  //Ptr.biHeight := -Bitmap.bmHeight;  //<=====ORG

Ptr.biHeight := -Bitmap.Height;

if Ptr.biHeight >= 0 then Ptr.biHeight := -1;
  //copy over the image bits
  Inc(Ptr);
  if BitsSize <> 0 then
    Move(Bitmap.StartLine^, Ptr^, BitsSize);   //<======ORG

GlobalUnlock(MemObj);
  //assign the completed DIB memory object to the clipboard
  OpenClipboard(0);
  try
    EmptyClipboard;
    //if not (SetClipboardData(CF_DIB, MemObj)) then     // <=====ORG
    if (SetClipboardData(CF_DIB, MemObj)=0) then          // <=====????
    //if (SetClipboardData(CF_DIB, MemObj)0) then        // <=====????
    begin
      GlobalFree(MemObj);
      RaiseLastOSError;
    end;
  finally
    CloseClipboard;
  end;
end;

function TForm1.PasteBitmapFromClipboard(Bitmap: TBitmap): Boolean;
var
  Header: TBitmapFileHeader;
  MemObj: HGLOBAL;
  Ptr   : PBitmapInfoHeader;
  Stream: TMemoryStream;
begin
  Ptr := nil;
  Stream := nil;
  OpenClipboard(0);
  try
    MemObj := GetClipboardData(CF_DIB);
    if MemObj = 0 then Exit(False);
    Ptr := GlobalLock(MemObj);
    if Ptr = nil then Exit(False);
    FillChar(Header, SizeOf(Header), 0);
    Header.bfType := $4D42;
    Header.bfSize := SizeOf(Header) + GlobalSize(MemObj);
    Header.bfOffBits := SizeOf(Header) + Ptr.biSize;
    Stream := TMemoryStream.Create;
    Stream.WriteBuffer(Header, SizeOf(Header));
    Stream.WriteBuffer(Ptr^, Header.bfSize - SizeOf(Header));
    Stream.Position := 0;
    Bitmap.LoadFromStream(Stream);    //<=====ORG

Result := True;
  finally
    if Ptr <> nil then GlobalUnlock(MemObj);
    CloseClipboard;
    Stream.Free;
  end;
end;

←解決時は質問者本人がここをチェックしてください。

戻る