解像度を変更したJpegをクリップボードから貼り付けるには？ (ID：25810)

名前

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

本文

// GetAPP0_Offset 過去ログより引用

function GetAPP0_Offset(Ms: TMemoryStream): Integer;
var
  p1, p2: PByte;
begin
  result := -1;
  p1 := Ms.Memory;
  while (Integer(p1) - Integer(Ms.Memory)) < Ms.Size do
  begin
    if p1^=$FF then
    begin
      p2:=p1;
      Inc(p2);
      if p2^=$E0 then
      begin
        result := Integer(p1) - Integer(Ms.Memory);
        exit;
      end;
    end;
    Inc(p1);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Bmp: TBitmap;
  Jpg: TJpegImage;
  Ms: TMemoryStream;
  APPO_Offset: Integer;
  Units, Hidpi, Lodpi: Byte;
  dpi: WORD;
  ExcelFile, ExcelSheet: String;
  MyFormat: Word;
  AData: THandle;
  APalette: HPALETTE;
begin
  Jpg := TJpegImage.Create;
  try
    Bmp := TBitmap.Create;
    Ms := TMemoryStream.Create;
    try
      Bmp.Width := 2955;
      Bmp.Height := 1622;
      SetStretchBltMode(Bmp.Canvas.Handle, HALFTONE);
      StretchBlt(Bmp.Canvas.Handle, 219, 0, 2736, 1622,
        Image1.Canvas.Handle, 0, 0, Image1.Picture.Width, Image1.Picture.Height, SRCCOPY);
      Jpg.Assign(Bmp);
      Jpg.SaveToStream(Ms);

APPO_Offset := GetAPP0_Offset(Ms);
      Ms.Position := APPO_Offset +2 +9;
      Units := 1;
      Ms.Write(Units, 1);

// 解像度を300に設定

dpi := 300;

Hidpi := HiByte(dpi);
      Lodpi := LoByte(dpi);
      Ms.Write(Hidpi, 1);
      Ms.Write(Lodpi, 1);
      Ms.Write(Hidpi, 1);
      Ms.Write(Lodpi, 1);
      Ms.Position:=0;

Jpg.LoadFromStream(Ms);
    finally
      Bmp.Free;
      Ms.Free;
    end;

ExcelFile := 'C:\Test.xls';
    ExcelSheet := 'Test';

try
      ExcelApplication1.Connect;
      ExcelApplication1.Visible[0] := True;
      ExcelWorkbook1.ConnectTo(ExcelApplication1.Workbooks.Open
        (ExcelFile, null, null, null, null, null,
        null, null, null, null, null, null, null, null, null, 0));
      ExcelWorksheet1.ConnectTo(ExcelWorkbook1.Worksheets[ExcelSheet] as _Worksheet);
      try

// SaveToClipboardFormatではBitmap形式になり解像度が72dpiに戻る

Jpg.SaveToClipboardFormat(MyFormat, AData, APalette);
        ClipBoard.SetAsHandle(MyFormat, AData);

// SaveToFileでは300dpiで出力できる

Jpg.SaveToFile('d:\test.jpg');

ExcelWorksheet1.Range['A1','A1'].Select;

// クリップボードからシートに画像貼り付け

ExcelWorksheet1.Paste;

except
        ExcelWorksheet1.Range['A1','A1'].Select;
      end;
      ExcelWorkbook1.SaveAs('c:\Test2.xls', Null, Null, Null, Null, Null,
        xlNoChange, Null, Null, Null, Null, Null, 0);
    finally
      ExcelApplication1.Disconnect;
    end;
  finally
    Jpg.Free;
  end;
end;

上記ソースで、Image1に表示された画像を拡大し、解像度を300に変更したJpegを
ExcelのSheetにクリップボード経由で貼り付けたいと思っています。
クリップボードを経由しなくてもいいんですが、それしか思いつきませんでした。

そこで、TJpegImage の SaveToClipboardFormat を使って見たんですが、
Bitmapに戻ってしまい、解像度も72dpiに戻ってしまいます。

SaveToFile を使うと300dpiのJpegで保存出来るので、SaveToClipboardFormat
を使っては無理なんだと勝手に思っています。

なにか良い方法はないでしょうか？
よろしくお願いします。

環境は、Delphi7 + Excel2003 です。

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

戻る