unit1.pas

基于DELPHI的图片浏览系统设计与实现

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Image1: TImage;
    ListBox1: TListBox;
    OpenDialog1: TOpenDialog;
    Button2: TButton;
    SaveDialog1: TSaveDialog;
    Button3: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure SaveToAvi;
    procedure Button3Click(Sender: TObject);
    procedure InternalGetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: Integer; var ImageSize: DWORD);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses AVI;

{$R *.dfm}

procedure InitializeBitmapInfoHeader(Bitmap: HBITMAP; var BI: TBitmapInfoHeader);
var
BM: Windows.TBitmap;
begin
GetObject(Bitmap, SizeOf(BM), @BM);
  with BI do begin
    biSize := SizeOf(BI);
    biWidth := BM.bmWidth;
    biHeight := BM.bmHeight;
    biBitCount := 8;
    biPlanes := 1;
    biXPelsPerMeter := 0;
    biYPelsPerMeter := 0;
    biClrUsed := 256;
    biClrImportant := 0;
    biCompression := BI_RGB;
    biSizeImage := ((8*biWidth + 31) div 32) * 4 * biHeight;
  end;
end; (* InitializeBitmapInfoHeader *)

procedure TForm1.InternalGetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: Integer; var ImageSize: DWORD);
var BI: TBitmapInfoHeader;
begin
  InitializeBitmapInfoHeader(Bitmap, BI);
  with BI do begin
    InfoHeaderSize := SizeOf(TBitmapInfoHeader) + SizeOf(TRGBQuad) * 256;
  end;
  ImageSize := BI.biSizeImage;
end; (* InternalGetDIBSizes *)

function InternalGetDIB(Bitmap: HBITMAP; var BitmapInfo; var Bits): Boolean;
var
  Focus: HWND;
  DC: HDC;
begin
  InitializeBitmapInfoHeader(Bitmap, TBitmapInfoHeader(BitmapInfo));
  Focus := GetFocus;
  DC := GetDC(Focus);
  try
    Result := GetDIBits(DC, Bitmap, 0, TBitmapInfoHeader(BitmapInfo).biHeight, @Bits, TBitmapInfo(BitmapInfo), DIB_RGB_COLORS) <> 0;
    TBitmapInfoHeader(BitmapInfo).biClrUsed := 256;//GetDIBits screws this up
  finally
    ReleaseDC(Focus, DC);
  end;
end; (* InternalGetDIB *)

procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
ListBox1.Items.Add(OpenDialog1.FileName);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
if SaveDialog1.Execute then
SaveToAvi;
end;

procedure TForm1.SaveToAvi;
var
 Reponse : Integer;
 C,C1:LongInt;
 Cp:LongWord;
 PFile1: PAVIFile;
 NewAvi: PAVIStream;
 MyNewAvi: PAVIStream;
 AviInfo: PAviStreamInfo;
 Image:Pointer;
 InfoSize   : Dword ;
 ImageSize  : Dword ;
 BitmapInfo:PBitmapInfo;

 FBitmapInfo: PBitmapInfoHeader;
     FBitmapSize: DWORD;
         FBitmapInfoSize: Integer;
               FBitmapBits: Pointer;

 FAVICompressOptions: TAVICompressOptions;
begin



   AVIFileInit;//初始化
   Reponse:=AVIFileOpen(Pfile1,PChar(SaveDialog1.FileName),OF_WRITE or OF_CREATE,nil);
   if Reponse = 0 then
   begin
   //分配内存的大小
    GetDIBSizes(Image1.Picture.Bitmap.Handle, InfoSize, ImageSize);
    Image1.Refresh;




    InternalGetDIBSizes(Image1.Picture.Bitmap.Handle, FBitmapInfoSize, FBitmapSize);
      FBitmapInfo := AllocMem(FBitmapInfoSize);
      FBitmapBits := AllocMem(FBitmapSize);

     InternalGetDIB(Image1.Picture.Bitmap.Handle, FBitmapInfo^, FBitmapBits^);





   //分配内存
    GetMem(BitMapInfo,InfoSize);
    ZeroMemory(BitMapInfo,InfoSize);
    GetMem(Image,ImageSize);
    ZeroMemory(Image,ImageSize);
   //
    GetDIB(Image1.Picture.Bitmap.Handle,Image1.Picture.Bitmap.Palette,BitmapInfo^,Image^);

    Getmem(AviInfo,Sizeof(TAviStreamInfo));
    ZeroMemory(AviInfo,Sizeof(TAviStreamInfo));

    AviInfo^.fccType:=StreamTypeVideo;
 //   AviInfo^.fccHandler:=Bi_RGB;
    AviInfo^.dwScale:= 5000;
    AviInfo^.dwRate:=1000 ;
    AviInfo^.rcFrame:=Rect(0,0,BitMapInfo^.BmiHeader.BiWidth,BitMapInfo^.BmiHeader.BiHeight);
    AviInfo^.dwSuggestedBufferSize:=ImageSize;

 //   BitMapInfo^.BmiHeader.BiCompression:=Bi_RGB;

    // Creer le stream video du nouveau fichier AVI New
    Reponse := AVIFileCreateStream(PFile1,MyNewAvi,AviInfo);


  FAVICompressOptions.fccType := streamtypeVIDEO;
  FAVICompressOptions.fccHandler := mmioStringToFOURCC(Codec, 0);
  FAVICompressOptions.dwQuality := 10000;

  if AVIMakeCompressedStream(NewAvi, MyNewAvi, FAVICompressOptions, nil)=AVIERR_OK then begin

//  if  AVIStreamSetFormat(NewAvi,0,BitmapInfo,InfoSize) =AVIERR_OK then
if  AVIStreamSetFormat(NewAvi, 0, FBitmapInfo, FBitmapInfoSize)=AVIERR_OK  then
     ShowMessage(IntToStr(1));
  end;


//    AVIStreamSetFormat(MyNewAvi,0,BitmapInfo,InfoSize);

     For Cp:=0 to ListBox1.Items.count-1 do
 Begin


  Image1.Picture.LoadFromFile(ListBox1.Items[Cp]);
  Image1.Refresh;
  GetDIB(Image1.Picture.Bitmap.Handle,Image1.Picture.Bitmap.Palette,BitmapInfo^,Image^);
  Image1.Refresh;

  // Ecrit le stream video
 /// Reponse:=AVIStreamWrite(MyNewAvi,Cp,1,Image,ImageSize,AVIIF_KEYFRAME,@C,@C1);
  Reponse:=AVIStreamWrite(NewAvi,Cp,1,Image,ImageSize,AVIIF_KEYFRAME,nil,nil);
end;




    FreeMem(BitMapInfo);
    FreeMem(Image);
    Freemem(AviInfo);

    AVIStreamRelease(NewAvi);
    AVIStreamRelease(MyNewAvi);
    AVIFileRelease(Pfile1);


      FreeMem(FBitmapBits);
  FreeMem(FBitmapInfo);

    AVIFileExit;
  end;


end;

procedure TForm1.Button3Click(Sender: TObject);
var
a:TAVIFile;
b:integer;
begin
     a:=TAVIFile.Create('f:\a.avi',5,Image1.Picture.Bitmap.Handle);
     for  b:=0 to ListBox1.Items.Count-1 do
     begin
     Image1.Picture.LoadFromFile(ListBox1.Items.Strings[b]);
     a.AddBitmap(Image1.Picture.Bitmap.Handle);

     end;

     a.Free;
end;

end.