Delphi 如何从剪贴板保存PngImage

如何在不丢失透明度的情况下将图像保存到复制的文件ADOBEFIREWKS（剪贴板）或Photoshop

我正在使用delphi2009

先谢谢你

@特拉马 我试过这个代码，但没有透明度。我也不知道我是否做对了

  png := TPngimage.Create;
  try
    png.LoadFromClipboardFormat(CF_BITMAP,
      Clipboard.GetAsHandle(CF_BITMAP), CF_BITMAP);
    image1.Picture.Assign(png);
  finally
    png.Free;
  end;

---

根据我的同事使用以下测试代码对Adobe Photoshop CS 6 13.0 x32进行测试所证实的实证结果，我指出，保存Adobe Photoshop复制的剪贴板中的图像而不丢失透明度是不可能的，因为它不复制alpha通道数据

Adobe Photoshop（至少在上述版本中）使用24位像素格式传输剪贴板图像数据。而且，因为它是24位位图，所以不可能有alpha通道。不知道谁有Adobe Fireworks需要验证，但可以肯定的是，他们使用自己注册的剪贴板格式在产品之间传输图像，包括alpha通道

Adobe Photoshop剪贴板使用的or格式应该支持alpha通道，正如一些人所说（我没有尝试过），但这只适用于32位像素格式，而不适用于24位像素格式。唯一的剪贴板格式当然支持透明度，但与其他格式一样，图像必须以32位像素格式存储以保留alpha通道：

以下代码显示了有关当前复制的剪贴板内容的信息：

uses
  ActiveX;

function GetClipboardFormatString(Format: Word): string;
var
  S: string;
begin
  case Format of
    1: S := 'CF_TEXT';
    2: S := 'CF_BITMAP';
    3: S := 'CF_METAFILEPICT';
    4: S := 'CF_SYLK';
    5: S := 'CF_DIF';
    6: S := 'CF_TIFF';
    7: S := 'CF_OEMTEXT';
    8: S := 'CF_DIB';
    9: S := 'CF_PALETTE';
    10: S := 'CF_PENDATA';
    11: S := 'CF_RIFF';        
    12: S := 'CF_WAVE';
    13: S := 'CF_UNICODETEXT';
    14: S := 'CF_ENHMETAFILE';
    15: S := 'CF_HDROP';
    16: S := 'CF_LOCALE';
    17: S := 'CF_DIBV5';
    $0080: S := 'CF_OWNERDISPLAY';
    $0081: S := 'CF_DSPTEXT';
    $0082: S := 'CF_DSPBITMAP';
    $0083: S := 'CF_DSPMETAFILEPICT';
    $008E: S := 'CF_DSPENHMETAFILE';
    $0200: S := 'CF_PRIVATEFIRST';
    $02FF: S := 'CF_PRIVATELAST';    
    $0300: S := 'CF_GDIOBJFIRST';
    $03FF: S := 'CF_GDIOBJLAST';
  else
    begin      
      SetLength(S, 255);
      SetLength(S, GetClipboardFormatName(Format, PChar(S), 255));      
      if Length(S) = 0 then
        S := 'Unknown, unregistered clipboard format';
      Result := S + ' (' + IntToStr(Format) + ')';
      Exit;
    end;
  end; 
  Result := 'Standard clipboard format (' + S + ')';
end;

function GetClipboardFormats: string;
var
  S: string;
  FormatEtc: TFormatEtc;
  DataObject: IDataObject;
  EnumFormatEtc: IEnumFormatEtc;
begin
  Result := '';
  if Succeeded(OleGetClipboard(DataObject)) then
  begin
    if Succeeded(DataObject.EnumFormatEtc(DATADIR_GET, EnumFormatEtc)) then
    begin
      S := DupeString('-', 65) + sLineBreak +
        'Clipboard data formats: ' + sLineBreak +
        DupeString('-', 65) + sLineBreak;
      while EnumFormatEtc.Next(1, FormatEtc, nil) = S_OK do
        S := S + GetClipboardFormatString(FormatEtc.cfFormat) + sLineBreak;
      Result := S;
    end;
  end;
end;

function GetClipboardInfoDIB: string;
var
  S: string;
  ClipboardData: HGLOBAL;
  BitmapInfoHeader: PBitmapInfoHeader;
const
  BI_JPEG = 4;
  BI_PNG = 5;
begin
  Result := '';
  if OpenClipboard(0) then
  try
    ClipboardData := GetClipboardData(CF_DIB);
    if ClipboardData <> 0 then
    begin
      BitmapInfoHeader := GlobalLock(ClipboardData);
      if Assigned(BitmapInfoHeader) then
      try
        S := DupeString('-', 65) + sLineBreak +
          'Clipboard data of CF_DIB format: ' + sLineBreak +
          DupeString('-', 65) + sLineBreak +
          'Width: ' + IntToStr(BitmapInfoHeader.biWidth) + ' px' + sLineBreak +
          'Height: ' + IntToStr(BitmapInfoHeader.biHeight) + ' px' + sLineBreak +
          'Bit depth: ' + IntToStr(BitmapInfoHeader.biBitCount) + ' bpp' + sLineBreak +
          'Compression format: ';
        case BitmapInfoHeader.biCompression of
          BI_RGB:   S := S + 'Uncompressed format (BI_RGB)';
          BI_RLE8: S := S + 'RLE format for bitmaps with 8 bpp (BI_RLE8)';
          BI_RLE4: S := S + 'RLE format for bitmaps with 4 bpp (BI_RLE4)';
          BI_BITFIELDS: S := S + 'Not compressed with color masks (BI_BITFIELDS)';
          BI_JPEG: S := S + 'Compressed using JPEG file format (BI_JPEG)';
          BI_PNG:   S := S + 'Compressed using PNG file format (BI_PNG)';
        end;
        S := S + sLineBreak;
        Result := S;
      finally
        GlobalUnlock(ClipboardData);
      end;      
    end;
  finally
    CloseClipboard;
  end;
end;

function GetClipboardInfoDIBV5: string;
var
  S: string;
  ClipboardData: HGLOBAL;
  BitmapInfoHeader: PBitmapV5Header;
const
  BI_JPEG = 4;
  BI_PNG = 5;
begin
  Result := '';
  if OpenClipboard(0) then
  try
    ClipboardData := GetClipboardData(CF_DIBV5);
    if ClipboardData <> 0 then
    begin
      BitmapInfoHeader := GlobalLock(ClipboardData);
      if Assigned(BitmapInfoHeader) then
      try
        S := DupeString('-', 65) + sLineBreak +
          'Clipboard data of CF_DIBV5 format: ' + sLineBreak +
          DupeString('-', 65) + sLineBreak +
          'Width: ' + IntToStr(BitmapInfoHeader.bV5Width) + ' px' + sLineBreak +
          'Height: ' + IntToStr(BitmapInfoHeader.bV5Height) + ' px' + sLineBreak +
          'Bit depth: ' + IntToStr(BitmapInfoHeader.bV5BitCount) + ' bpp' + sLineBreak +
          'Compression format: ';
        case BitmapInfoHeader.bV5Compression of
          BI_RGB:   S := S + 'Uncompressed format (BI_RGB)';
          BI_RLE8: S := S + 'RLE format for bitmaps with 8 bpp (BI_RLE8)';
          BI_RLE4: S := S + 'RLE format for bitmaps with 4 bpp (BI_RLE4)';
          BI_BITFIELDS: S := S + 'Not compressed with color masks (BI_BITFIELDS)';
          BI_JPEG: S := S + 'Compressed using JPEG file format (BI_JPEG)';
          BI_PNG:   S := S + 'Compressed using PNG file format (BI_PNG)';
        end;
        S := S + sLineBreak;
        Result := S;
      finally
        GlobalUnlock(ClipboardData);
      end;      
    end;
  finally
    CloseClipboard;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  S: string;
begin
  S := GetClipboardFormats;
  if IsClipboardFormatAvailable(CF_DIB) then
    S := S + sLineBreak + GetClipboardInfoDIB;
  if IsClipboardFormatAvailable(CF_DIBV5) then
    S := S + sLineBreak + GetClipboardInfoDIBV5;
  ShowMessage(S);
end;

使用
ActiveX；
函数GetClipboardFormatString（格式：Word）：string；
变量
S:字符串；
开始
案例格式
1:S:='CF_TEXT'；
2:S:=“CF_位图”；
3:S:=“CF_METAFILEPICT”；
4:S:=“CF_SYLK”；
5:S:=“CF_DIF”；
6:S:=“CF_TIFF”；
7:S:=“CF_OEMTEXT”；
8:S:='CF_DIB'；
9:S:=“CF_调色板”；
10:S:=“CF_PENDATA”；
11:S:=“CF_RIFF”；
12:S:=‘CF_波’；
13:S:='CF_unicodext'；
14:S:=“CF_ENHMETAFILE”；
15:S:=“CF_HDROP”；
16:S:='CF_LOCALE'；
17:S:=“CF_DIBV5”；
$0080:S:='CF_OWNERDISPLAY'；
$0081:S:='CF_DSPTEXT'；
$0082:S:=“CF_DSPBITMAP”；
$0083:S:=“CF_DSPMETAFILEPICT”；
$008E:S:='CF_DSPENHMETAFILE'；
$0200:S:=“CF_PRIVATEFIRST”；
$02FF:S:='CF_PRIVATELAST'；
$0300:S:=“CF_GDIOBJFIRST”；
$03FF:S:='CF_gdiobjast'；
其他的
开始
设定长度（S，255）；
SetLength（S，GetClipboardFormatName（格式，PChar，255））；
如果长度=0，则
S:=“未知、未注册的剪贴板格式”；
结果：=S+'（'+IntToStr（格式）+'）；
出口
结束；
结束；
结果：='标准剪贴板格式（'+S+'）；
结束；
函数GetClipboardFormats:字符串；
变量
S:字符串；
FormatEtc:TFormatEtc；
数据对象：IDataObject；
EnumFormatEtc：IEnumFormatEtc；
开始
结果：=''；
如果成功（OleGetClipboard（DataObject）），则
开始
如果成功（DataObject.EnumFormatEtc（DATADIR\u GET，EnumFormatEtc）），则
开始
S:=双列（'-'，65）+滑动断裂+
'剪贴板数据格式：'+sLineBreak+
双股（'-'，65）+滑裂；
而EnumFormatEtc.Next（1，FormatEtc，nil）=S_OK do
S:=S+GetClipboardFormatString（FormatEtc.cfFormat）+sLineBreak；
结果：=S；
结束；
结束；
结束；
函数getClipboardInfo:string；
变量
S:字符串；
剪贴簿数据：HGLOBAL；
BitMapInfo头：PBITMapInfo头；
常数
BI_JPEG=4；
biu PNG=5；
开始
结果：=''；
如果打开剪贴板（0），则
尝试
剪贴簿数据：=获取剪贴簿数据（CF_DIB）；
如果剪贴板数据为0，则
开始
BitMapInfo头：=GlobalLock（剪贴板数据）；
如果已分配（BitMapInfo标头），则
尝试
S:=双列（'-'，65）+滑动断裂+
“CF_DIB格式的剪贴板数据：”+sLineBreak+
双圈（'-'，65）+滑环+
'宽度：'+IntToStr（bitmapinfo.biWidth）+'px'+sLineBreak+
'高度：'+IntToStr（bitmapinfo.biHeight）+'px'+sLineBreak+
'位深度：'+IntToStr（BitMapInfo头文件.biBitCount）+'bpp'+sLineBreak+
'压缩格式：'；
大小写为BitMapInfo的Header.b压缩
BI_RGB:S:=S+“未压缩格式（BI_RGB）”；
BI_RLE8:S:=S+“用于8 bpp位图的RLE格式（BI_RLE8）”；
BI_RLE4:S:=S+“用于4bpp位图的RLE格式（BI_RLE4）”；
BI_位字段：S:=S+'未使用颜色掩码（BI_位字段）进行压缩'；
BI_JPEG:S:=S+‘使用JPEG文件格式（BI_JPEG）压缩’；
BI_PNG:S:=S+'使用PNG文件格式（BI_PNG）进行压缩'；
结束；
S:=S+sLineBreak；
结果：=S；
最后
GlobalUnlock（剪贴板数据）；
结束；
结束；
最后
关闭剪贴板；
结束；
结束；
函数getClipboardInfo:string；
变量
S:字符串；
剪贴簿数据：HGLOBAL；
BitMapInfo头：PBITMAPV5头；
常数
BI_JPEG=4；
biu PNG=5；
开始
结果：=''；
如果打开剪贴板（0），则
尝试
剪贴簿数据：=获取剪贴簿数据（CF_DIBV5）；
如果剪贴板数据为0，则
开始
BitMapInfo头：=GlobalLock（剪贴板数据）；
如果已分配（BitMapInfo标头），则
尝试
S:=双列（'-'，65）+滑动断裂+
“CF_DIBV5格式的剪贴板数据：”+sLineBreak+
双圈（'-'，65）+滑环+
'Width:'+IntToStr（BitMapInfo.bV5Width）+'px'+sLineBreak+
'Height:'+IntToStr（BitMapInfo.bV5Height）+'px'+sLineBreak+
'位深度：'+IntToStr（BitMapInfo头文件.bV5BitCount）+'bpp'+sLineBreak+
'压缩格式：'；
案例BitmapInfoHeader.BV5压缩
BI_RGB:S:=S+“未压缩格式（BI_RGB）”；
BI_RLE8:S:=S+“用于8 bpp位图的RLE格式（BI_RLE8）”；
BI_RLE4:S:=S+“用于4bpp位图的RLE格式（BI_RLE4）”；
BI_位字段：S:=S+'未使用颜色m压缩
unit EG_ClipboardBitmap32;
{
  Author William Egge. egge@eggcentric.com
  January 17, 2002
  Compiles with ver 1.2 patch #1 of Graphics32

  This unit will copy and paste Bitmap32 pixels to the clipboard and retain the
  alpha channel.

  The clipboard data will still work with regular paint programs because this
  unit adds a new format only for the alpha channel and is kept seperate from
  the regular bitmap storage.
}

interface

uses
  ClipBrd, Windows, SysUtils, GR32;

procedure CopyBitmap32ToClipboard(const Source: TBitmap32);
procedure PasteBitmap32FromClipboard(const Dest: TBitmap32);
function CanPasteBitmap32: Boolean;

implementation

const
  RegisterName = 'G32 Bitmap32 Alpha Channel';
  GlobalUnlockBugErrorCode = ERROR_INVALID_PARAMETER;

var
  FAlphaFormatHandle: Word = 0;

procedure RaiseSysError;
var
  ErrCode: LongWord;
begin
  ErrCode := GetLastError();
  if ErrCode <> NO_ERROR then
    raise Exception.Create(SysErrorMessage(ErrCode));
end;

function GetAlphaFormatHandle: Word;
begin
  if FAlphaFormatHandle = 0 then
  begin
    FAlphaFormatHandle := RegisterClipboardFormat(RegisterName);
    if FAlphaFormatHandle = 0 then
      RaiseSysError;
  end;
  Result := FAlphaFormatHandle;
end;

function CanPasteBitmap32: Boolean;
begin
  Result := Clipboard.HasFormat(CF_BITMAP);
end;

procedure CopyBitmap32ToClipboard(const Source: TBitmap32);
var
  H: HGLOBAL;
  Bytes: LongWord;
  P, Alpha: PByte;
  I: Integer;
begin
  Clipboard.Assign(Source);
  if not OpenClipboard(0) then
    RaiseSysError
  else
    try
      Bytes := 4 + (Source.Width * Source.Height);
      H := GlobalAlloc(GMEM_MOVEABLE and GMEM_DDESHARE, Bytes);
      if H = 0 then
        RaiseSysError;
      P := GlobalLock(H);
      if P = nil then
        RaiseSysError
      else
        try
          PLongWord(P)^ := Bytes - 4;
          Inc(P, 4);
          // Copy Alpha into Array
          Alpha := Pointer(Source.Bits);
          Inc(Alpha, 3); // Align with Alpha
          for I := 1 to (Source.Width * Source.Height) do
          begin
            P^ := Alpha^;
            Inc(Alpha, 4);
            Inc(P);
          end;
        finally
          if (not GlobalUnlock(H)) then
            if (GetLastError() <> GlobalUnlockBugErrorCode) then
              RaiseSysError;
        end;
      SetClipboardData(GetAlphaFormatHandle, H);
    finally
      if not CloseClipboard then
        RaiseSysError;
    end;
end;

procedure PasteBitmap32FromClipboard(const Dest: TBitmap32);
var
  H: HGLOBAL;
  ClipAlpha, Alpha: PByte;
  I, Count, PixelCount: LongWord;
begin
  if Clipboard.HasFormat(CF_BITMAP) then
  begin
    Dest.BeginUpdate;
    try
      Dest.Assign(Clipboard);
      if not OpenClipboard(0) then
        RaiseSysError
      else
        try
          H := GetClipboardData(GetAlphaFormatHandle);
          if H <> 0 then
          begin
            ClipAlpha := GlobalLock(H);
            if ClipAlpha = nil then
              RaiseSysError
            else
              try
                Alpha := Pointer(Dest.Bits);
                Inc(Alpha, 3); // Align with Alpha
                Count := PLongWord(ClipAlpha)^;
                Inc(ClipAlpha, 4);
                PixelCount := Dest.Width * Dest.Height;
                Assert(Count = PixelCount,
                  'Alpha Count does not match Bitmap pixel Count,
                  PasteBitmap32FromClipboard(const Dest: TBitmap32);');

                // Should not happen, but if it does then this is a safety catch.
                if Count > PixelCount then
                  Count := PixelCount;

                for I := 1 to Count do
                begin
                  Alpha^ := ClipAlpha^;
                  Inc(Alpha, 4);
                  Inc(ClipAlpha);
                end;
              finally
                if (not GlobalUnlock(H)) then
                  if (GetLastError() <> GlobalUnlockBugErrorCode) then
                    RaiseSysError;
              end;
          end;
        finally
          if not CloseClipboard then
            RaiseSysError;
        end;
    finally
      Dest.EndUpdate;
      Dest.Changed;
    end;
  end;
end;

end.

On Error Resume Next
Set Ps = CreateObject("Photoshop.Application")
Set Shell = CreateObject("WScript.Shell")
Set FileSystem = CreateObject("Scripting.FileSystemObject") 

Dim PNGFileName
PNGFileName = Shell.CurrentDirectory & "\psClipboard.png"

If FileSystem.FileExists(PNGFileName) Then 
    FileSystem.DeleteFile PNGFileName
End If

Set Doc = Ps.Documents.Add(1,1,72,"psClipboard",,3)

Doc.Paste()
Doc.RevealAll()

If Err.Number = 0 Then 
    set PNGSaveOptions = CreateObject("Photoshop.PNGSaveOptions")
    doc.saveAs PNGFileName, PNGSaveOptions
End If

doc.Close()