imageにgif画像を使用するには？ (ID:5821)

名前

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

本文

Webにdelphi用のサンプルコードが無かったのでここに書きます。
このまんま使って使えると思います。

//
unit OlePictures;

interface
  uses
Windows,SysUtils,Classes,Graphics,ActiveX;

type
  TOleBITMAP = Class(TBitmap)
  Public
   Procedure Loadfromstream (Stream: TStream);override;
  end;
//
function GetPicturetype(const header,header2:Longword):byte;
function LoadOlepicfile(var Picture:Tbitmap;const filename:string):byte;
function LoadOlepicStream(var Picture:Tbitmap; strm:Tstream):byte;

const
 G_BMP    = $21;
 G_EMF    = $22;
 G_WMF    = $23;
 G_ICO    = $24;
 G_CUR    = $25;
 G_ANI    = $26;
 G_JFIF   = $11;
 G_EXIF   = $12;
 G_GIF    = $13;
 G_TGA    = $31;
 G_SVG    = $32;
 G_SWF    = $33;

CMP_ZLB    = $0000DA78;//zlib and$0000FFFF   $51
 WIN_BMP    = $00004D42;//bmp and$0000FFFF    $21
 WIN_EMF    = $00000001;//EMF??               $22
 WIN_EMF2   = $464D4520;//EMF OFF $28
 WIN_WMF    = $9AC6CDD7;//WMF                 $23
 WIN_RIFF   = $46464952;//ANI                 $26
 OLE_JFIF   = $E0FFD8FF;//JFIF                $11
 OLE_EXIF   = $E1FFD8FF;//EXIF                $12
 OLE_GIF    = $38464947;//GIF8                $13
 WIN_ICO    = $00010000;//ICO                 $24
// WIN_CUR    = $00020000;//CUR                 $25
 WIN_RES    = $20200001 ;//CUR,ico                 $25
 GRA_TGAP   = $00010100;//tga PALLET           $31
 GRA_TGA    = $00020000;//tga RGB             $31
 GRA_TGAM   = $00030000;//tga MONO             $31
 GRA_SVG    = $6776733C;//SVG text            $32
 GRA_SWF    = $00535746;//SWF and $00FFFFFF   $33
implementation

Procedure TOleBitmap.loadfromstream(Stream: TStream);
begin
 LoadOlepicStream(Tbitmap(self),stream);
end;

function GetPicturetype(const header,header2:Longword):byte;
begin
result:=0;
 case header of
   OLE_JFIF:result:=$11;
   OLE_EXIF:result:=$12;
   OLE_GIF :result:=$13;
   WIN_ICO    :result:=G_ICO;//EMF??
   WIN_EMF    :result:=G_EMF;//EMF??
   WIN_WMF    : result:=$23;//WMF
   WIN_RIFF   : result:=$26;//ANI
   GRA_TGA    :
    if header2 = WIN_RES then result:= G_CUR else result:=G_TGA;
   GRA_TGAP   : result:=G_TGA;//tga
   GRA_TGAM   : result:=G_TGA;//tga
   GRA_SVG    : result:=$32;//SVG text            $32

else
   if (header and $00FFFFFF) = GRA_SWF then result:= $33;
   if (header and $0000FFFF) = WIN_BMP then result:= $21;
   if (header and $0000FFFF) = CMP_ZLB then result:= $51;
  end;
end;

const
 IID_IPICTURE:TGUID ='{7BF80980-BF32-101A-8BBB-00AA00300CAB}';

function LoadOlepicStream(var Picture:Tbitmap; strm:Tstream):byte;
var
hr:hresult;
iPicture1:IPicture;//Disp;
istream1:IStream;
//
nFileSize,pheader,pheader2:Longword;
hGlobal:Thandle;
lWidth,lHeight,FWidth,FHeight:integer;
pdata:Pointer;
rc:Trect;
flg:smallint;
ptype:byte;
begin
result:=0;
  if strm.Read(pheader,4) <4 then exit;
  if strm.Read(pheader2,4) <4 then exit;
  strm.Seek(0,soFromBeginning);
  ptype:=GetPicturetype(pheader,Pheader2);
// if ((ptype <$11) or (ptype > $13)) then Exit;
if  ptype in [G_BMP,G_CUR,G_ICO,G_EMF,G_WMF ]then
   picture.PixelFormat:=pf24bit else
if ((ptype <G_JFIF) or (ptype > G_GIF)) then Exit;
if not (picture.PixelFormat in [pf1bit,pf24bit,pf32bit])
  then picture.PixelFormat:=pf24bit;

nFileSize:=strm.Size;
  hGlobal := GlobalAlloc(GMEM_MOVEABLE, nFileSize);
  try
   pData := GlobalLock(hGlobal);
   strm.ReadBuffer(pdata^,nFileSize);
   GlobalUnlock(hGlobal);
   iStream1:=nil;
   HR:= CreateStreamOnHGlobal(hGlobal, TRUE, iStream1);
   IF hr <> s_ok THEN EXIT;
   HR := OleLoadPicture(istream1, nFileSize, FALSE, IID_IPICTURE,iPicture1);
   IF hr <> s_ok THEN EXIT;

iPicture1.get_Width(lWidth);
   iPicture1.get_Height(lHeight);

FWidth:= MulDiv(lWidth, GetDeviceCaps(GetDC(0), LOGPIXELSX), 2540);
   FHeight:=MulDiv(lHeight, GetDeviceCaps(GetDC(0), LOGPIXELSY), 2540);
   Picture.Width:= FWidth;
   Picture.Height:=FHeight;
   rc.Top:=0;
   rc.Left:=0;
   rc.Bottom:=Picture.Height;
   rc.Right:=Picture.Width;

if ptype in[G_CUR,G_ICO,G_GIF,G_WMF,G_EMF] then begin
    if (Picture.TransparentColor and $00FFFFFF) =$FFFFFF then Picture.TransparentColor:=$FD017F;
    Picture.Canvas.Brush.Color:=Picture.TransparentColor;//
    Picture.Canvas.Brush.Style:=bssolid;
    Picture.Canvas.FillRect(rc);
    Picture.Transparent:=true;
   end;
   Ipicture1.get_Type(flg);
  ptype:=byte(flg);

iPicture1.Render(
   Picture.Canvas.Handle,0,0,Picture.Width,Picture.Height,
     0, lHeight, lWidth, -lHeight, rc);

result:=ptype;

finally
   GlobalFree(hGlobal);
  end;

end;

function LoadOlepicfile(var Picture:Tbitmap;const filename:string):byte;
var
Fs:Tfilestream;
begin
  Fs := TFileStream.Create(FileName, fmOpenRead);
  try
  result:=LoadOlePicStream(Picture,Fs);
  finally
 Fs.Free;
 end;
end;

initialization
 TPicture.RegisterFileFormat('gif','compuserve graphic',TOleBitmap);
 TPicture.RegisterFileFormat('jpg','jpeg',TOleBitmap);

end.

このユニットでJPEGを使わない場合はJPEGの部分をコメントアウトすればよいです。
TOLEBitmapを使わない場合はinitialization以降をコメントアウトすればよいです。
他にもWMF,curなども登録すればOpenPictureDialogでも使えます。
透明色処理は適当ですが結構うまく動きます。

テストフォーム

unit test11;

interface

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

type
  TForm1 = class(TForm)
    Bt1: TButton;
    Im1: TImage;
    OPD1: TOpenPictureDialog;
    procedure Bt1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Bt1Click(Sender: TObject);
begin
if OPD1.Execute then
begin
 Im1.Picture.LoadFromFile(OPD1.FileName);
end;
end;

end.

適当にOpenPictureDialogとTimage、Buttonをフォームに貼り付けて
名称をOPD1,Im1,Bt1としています。
Delphi6で420kbyte程度です。

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

戻る