Delphi Developer's Kit 1996/Delphi Developer's Kit 1996.iso/power/source8/tmulti.pas

Pascal/Delphi Source File | 1995-12-22 | 25.0 KB | 889 lines

{Copyright 1995 by
 Kevin Adams, 74742,1444
 Jan Dekkers, 72130,353

No part of this Unit may be copied in any way.
However, you may derive other objects from
TMultiImage.

Part of Imagelib VCL/DLL Library.

Written by Jan Dekkers and Kevin Adams}


unit TMulti;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Forms,
  Controls, Extctrls, StdCtrls, DLL22LIN, Menus, Mask, Buttons, SetSrMsg,
  printers;



type
  TMultiImage = class(TCustomControl)
  private
    FPicture            : TPicture;
    FAutoSize           : Boolean;
    FBorderStyle        : TBorderStyle;
    FStretch            : Boolean;
    FCenter             : Boolean;
    FReserved           : Byte;
    FFilename           : TFileName;
    Fdither             : byte;
    FResolution         : byte;
    FSaveQuality        : byte;
    FSaveSmooth         : byte;
    FSaveFileName       : TFileName;
    Temps               : TFileName;
    BitMsg              : TBitmap;
    SMessageLeft        : Integer;
    SMessageRight       : Integer;
    SMessageTop         : Integer;
    ScreenWd            : Integer;
    ScreenHt            : Integer;
    BitWidth            : Integer;
    DelayCounter        : LongInt;
    function GetCanvas: TCanvas;
    procedure PictureChanged(Sender: TObject);
    procedure SetAutoSize(Value: Boolean);
    procedure SetCenter(Value: Boolean);
    procedure SetPicture(Value: TPicture);
    procedure SetStretch(Value: Boolean);
    procedure SetBorderStyle(Value: TBorderStyle);
    procedure WMCut(var Message: TMessage); message WM_CUT;
    procedure WMCopy(var Message: TMessage); message WM_COPY;
    procedure WMPaste(var Message: TMessage); message WM_PASTE;
  protected
    function GetPalette: HPALETTE; override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyPress(var Key: Char); override;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure PrintICOWMF(X, Y, pWidth, pHeight: Integer);
    procedure PrintBitMap(X, Y, pWidth, pHeight: Integer);
    Procedure MoveMsg(Var WinMsg : TMessage); message WM_Trigger;
    procedure LoadMessageFromFile(MessageName : TFileName);
    Function Delay(Ms : Integer) : boolean;
  public
    BFiletype           :  String;
    Bwidth              :  Integer;
    BHeight             :  Integer;
    Bbitspixel          :  Integer;
    Bplanes             :  Integer;
    Bnumcolors          :  Integer;
    BSize               :  Longint;
    Bcompression        :  String;
    MessageRunning      :  Boolean;
    MsgText             :  String;
    MsgFont             :  TFont;
    MsgBkGrnd           :  TColor;
    MsgSpeed            :  Integer;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure CopyToClipboard;
    procedure CutToClipboard;
    procedure PasteFromClipboard;
    property Canvas: TCanvas read GetCanvas;
    function GetMultiBitmap : String;
    Procedure WriteMultiName(Name : String);
    procedure Paint; override;
    function GetSmooth : Byte;
    procedure SetSmooth(smooth : Byte);
    function GetQuality : Byte;
    procedure SetQuality(Quality : Byte);
    function GetDither : Byte;
    procedure SetDither(dith : Byte);
    function GetRes : Byte;
    procedure SetRes(res : Byte);
    function GetSaveFileName : TFilename;
    procedure SetSaveFileName(fn : TFilename);
    procedure SaveAsJpg(FN : TFileName);
    procedure SaveAsBMP(FN : TFileName);
    function GetInfoAndType(filename : TFilename) : Boolean;
    {scrolling message stuff}
    Procedure Trigger;
        procedure CreateMessage(MessagePath : String; AutoLoad : Boolean);
    procedure SaveCurrentMessage(MessageName : TFileName);
    procedure NewMessage;
    Procedure FreeMsg;
    {printing}
    procedure PrintMultiImage(X, Y, pWidth, pHeight: Integer);
  published
    property Align;
    property AutoSize: Boolean read FAutoSize write SetAutoSize default False;
    property Center: Boolean read FCenter write SetCenter default False;
    property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsNone;
    property DragCursor;
    property DragMode;
    property Enabled;
    property JPegDither : Byte read GetDither write SetDither;
    property JPegResolution : Byte read GetRes write SetRes;
    property Picture: TPicture read FPicture write SetPicture;
    property JPegSaveQuality : Byte read GetQuality write SetQuality;
    property JPegSaveSmooth : Byte read GetSmooth write SetSmooth;
    property DefSaveFileName : TFileName read GetSaveFileName write SetSaveFileName;
    property ImageName  : String read GetMultiBitmap write WriteMultiName;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Stretch: Boolean read FStretch write SetStretch default False;
    property Visible;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;


var
 TMultiImageCallBack   : TCallBackFunction;

 {------------------------------------------------------------------------}

implementation
  uses Consts, Clipbrd, Dialogs, ToolHelp;

{------------------------------------------------------------------------
 TMultiImage.
------------------------------------------------------------------------}


constructor TMultiImage.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FPicture := TPicture.Create;
  FPicture.OnChange := PictureChanged;
  FFilename:='';
  Fdither:=4;
  FResolution:=8;
  FSaveQuality:=25;
  FSaveSmooth:=0;
  FBorderStyle := bsNone;
  Picture.Graphic := nil;
  Height := 105;
  Width := 105;
  MsgFont:=TFont.Create;
  BitMsg := TBitmap.Create;
  MessageRunning:=False;
  SetupMsg:=Nil;
  DelayCounter:=0;
 end;
{------------------------------------------------------------------------}


destructor TMultiImage.Destroy;
begin
  FPicture.Free;
  MsgFont.Free;
  BitMsg.Free;
  inherited Destroy;
end;
{------------------------------------------------------------------------}

function TMultiImage.GetPalette: HPALETTE;
begin
  Result := 0;
  if FPicture.Graphic is TBitmap then
    Result := TBitmap(FPicture.Graphic).Palette;
end;
{------------------------------------------------------------------------}

procedure TMultiImage.SetBorderStyle(Value: TBorderStyle);
begin
  if FBorderStyle <> Value then
  begin
    FBorderStyle := Value;
    RecreateWnd;
  end;
end;
{------------------------------------------------------------------------}

procedure TMultiImage.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  if FBorderStyle = bsSingle then
    Params.Style := Params.Style or WS_BORDER;
end;
{------------------------------------------------------------------------}

procedure TMultiImage.Paint;
var
  Dest : TRect;
begin
  if csDesigning in ComponentState then
    with inherited Canvas do
    begin
      Pen.Style := psDash;
      Brush.Style := bsClear;
      Rectangle(0, 0, Width, Height);
    end;
  if Stretch then
    Dest := ClientRect
  else if Center then
    Dest := Bounds((Width - Picture.Width) div 2, (Height - Picture.Height) div 2,
      Picture.Width, Picture.Height)
  else
    Dest := Rect(0, 0, Picture.Width, Picture.Height);
  with inherited Canvas do
    StretchDraw(Dest, Picture.Graphic);

  if (MessageRunning) and (Picture = nil) then FreeMsg;
end;

{------------------------------------------------------------------------}

function TMultiImage.GetCanvas: TCanvas;
var
  Bitmap: TBitmap;
begin
  if Picture.Graphic = nil then
  begin
    Bitmap := TBitmap.Create;
    try
      Bitmap.Width := Width;
      Bitmap.Height := Height;
      Picture.Graphic := Bitmap;
    finally
      Bitmap.Free;
    end;
  end;
  if Picture.Graphic is TBitmap then
    Result := TBitmap(Picture.Graphic).Canvas
  else
    raise EInvalidOperation.Create(LoadStr(SImageCanvasNeedsBitmap));
end;
{------------------------------------------------------------------------}

procedure TMultiImage.SetAutoSize(Value: Boolean);
begin
  FAutoSize := Value;
  PictureChanged(Self);
end;
{------------------------------------------------------------------------}

procedure TMultiImage.SetCenter(Value: Boolean);
begin
  if FCenter <> Value then
  begin
    FCenter := Value;
    Invalidate;
  end;
end;
{------------------------------------------------------------------------}

procedure TMultiImage.SetPicture(Value: TPicture);
begin
  FPicture.Assign(Value);
end;
{------------------------------------------------------------------------}

procedure TMultiImage.SetStretch(Value: Boolean);
begin
  FStretch := Value;
  Invalidate;
end;
{------------------------------------------------------------------------}

procedure TMultiImage.PictureChanged(Sender: TObject);
begin
  if AutoSize and (Picture.Width > 0) and (Picture.Height > 0) then
    SetBounds(Left, Top, Picture.Width, Picture.Height);
  if (Picture.Graphic is TBitmap) and (Picture.Width = Width) and
    (Picture.Height = Height) then
    ControlStyle := ControlStyle + [csOpaque] else
    ControlStyle := ControlStyle - [csOpaque];
  Invalidate;
end;
{------------------------------------------------------------------------}

function TMultiImage.GetDither : Byte;
begin
  GetDither:=Fdither
end;
{------------------------------------------------------------------------}

procedure TMultiImage.SetDither(dith : Byte);
begin
  Fdither:=4;
  case dith of
            0..4 :Fdither:=dith;
  end;
end;
{------------------------------------------------------------------------}

function TMultiImage.GetRes : Byte;
begin
  GetRes:=FResolution;
end;
{------------------------------------------------------------------------}


procedure TMultiImage.SetRes(res : Byte);
begin
  FResolution:=8;
  case res of
            4 :FResolution:=res;
            8 :FResolution:=res;
            24 :FResolution:=res;
  end;
end;
{------------------------------------------------------------------------}

Procedure TMultiImage.WriteMultiName(Name : String);
begin
  FFilename:=Name;
  GetMultiBitmap;
end;
{------------------------------------------------------------------------}


function TMultiImage.GetMultiBitmap :  String;
var    bitmap     : TBitMap;
       Pextension : string[4];
       OnExcept   : Boolean;
       f          : file of byte;
label  BreakIt;

begin
  OnExcept:=False;
  if not FileExists(FFilename) then begin
     Picture.Graphic := nil;
     temps:='file not found';
     GetMultiBitmap:=temps;
     exit;
  end;

  if FResolution <> 4 then if FResolution <> 8 then if FResolution <> 24 then
   FResolution:=8;

  if (FDither < 0) or (FDither > 4) then FDither:=4;

  Pextension:=UpperCase(ExtractFileExt(FFilename));

  if (Pextension =  '.WMF') or (Pextension =  '.ICO') then begin
    FreeMsg;
    Picture.LoadFromFile(FFilename);
    Temps:='Non JPeg, BMP, GIF or PCX Image';
    GetMultiBitmap:=Temps;
    GetInfoAndType(FFileName);
    exit;
  end;

 if (UpperCase(FFilename) = temps) and (Picture.Bitmap <> nil) then
   Goto BreakIt;

 if Pextension = '.SCM' then begin
    try
     LoadMessageFromFile(FFileName);
    except
     Picture.Graphic := nil;
     OnExcept:=True;
    end;
    if OnExcept then Goto BreakIt;
    GetInfoAndType(FFileName);
 end;

 if Pextension = '.BMP' then begin
    try
     FreeMsg;
     Bitmap := TBitmap.Create;
     if not bmpfile(FFileName, Bitmap, TMultiImageCallBack) then
       MessageDlg('Reading bmp file failed', mtInformation, [mbOk], 0);
    except
     Picture.Graphic := nil;
     Bitmap.Free;
     OnExcept:=True;
    end;
     if OnExcept then Goto BreakIt;
     Picture.Graphic:=Bitmap;
     Bitmap.Free;
     GetInfoAndType(FFileName);
 end;

 if Pextension = '.GIF' then begin
    try
     FreeMsg;
     Bitmap := TBitmap.Create;
     if not Giffile(FFileName, Bitmap, TMultiImageCallBack) then
       MessageDlg('Reading gif file failed', mtInformation, [mbOk], 0);
    except
     Picture.Graphic := nil;
     Bitmap.Free;
     OnExcept:=True;
    end;
     if OnExcept then Goto BreakIt;
     Picture.Graphic:=Bitmap;
     Bitmap.Free;
     GetInfoAndType(FFileName);
 end;

 if Pextension = '.PCX' then begin
    try
     FreeMsg;
     Bitmap := TBitmap.Create;
     if not PCXfile(FFileName, Bitmap, TMultiImageCallBack) then
       MessageDlg('Reading pcx file failed', mtInformation, [mbOk], 0);
    except
     Picture.Graphic := nil;
     Bitmap.Free;
     OnExcept:=True;
    end;
     if OnExcept then Goto BreakIt;
     Picture.Graphic:=Bitmap;
     Bitmap.Free;
     GetInfoAndType(FFileName);
 end;

 if Pextension = '.JPG' then begin
    try
     FreeMsg;
     Bitmap := TBitmap.Create;
     if not jpgfile(FFilename, FResolution, Fdither, Bitmap, TMultiImageCallBack) then
       MessageDlg('Reading jpg file failed', mtInformation, [mbOk], 0);
    except
     Picture.Graphic := nil;
     Bitmap.Free;
     OnExcept:=True;
    end;
     if OnExcept then Goto BreakIt;
     Picture.Graphic:=Bitmap;
     Bitmap.Free;
     GetInfoAndType(FFileName);
 end;

 BreakIt:
 Temps:=UpperCase(FFilename);
 GetMultiBitmap:=Temps;
end;
{------------------------------------------------------------------------}

function TMultiImage.GetSmooth : Byte;
begin
  GetSmooth:=FSaveSmooth;
end;
{------------------------------------------------------------------------}

procedure TMultiImage.SetSmooth(Smooth : Byte);
begin
  if (Smooth > 100) or (Smooth < 0) then FSaveSmooth:=5 else
   FSaveSmooth:=Smooth;
end;
{------------------------------------------------------------------------}

function TMultiImage.GetQuality : Byte;
begin
  GetQuality:=FSaveQuality;
end;
{------------------------------------------------------------------------}

procedure TMultiImage.SetQuality(Quality : Byte);
begin
  if (Quality > 100) OR (Quality < 1) then FSaveQuality:=25 else
   FSaveQuality:=Quality;
end;
{------------------------------------------------------------------------}

function TMultiImage.GetSaveFileName : TFilename;
begin
  GetSaveFileName:=FSaveFileName;
end;
{------------------------------------------------------------------------}

procedure TMultiImage.SetSaveFileName(fn : TFilename);
begin
 if fn <> '' then
   FSaveFileName:=fn
 else
   FSaveFileName:='';
end;


{------------------------------------------------------------------------}
procedure TMultiImage.SaveAsBMP(FN : TFileName);
begin
   if fn <> '' then FSaveFileName:=fn;
  try
    if not putbmpfile(FSaveFileName, picture.Bitmap, TMultiImageCallBack) then
      MessageDlg('Writing bmp file failed', mtInformation, [mbOk], 0);
  except

  end;
end;

{------------------------------------------------------------------------}

procedure TMultiImage.SaveAsJpg(FN : TFileName);
begin
   if fn <> '' then FSaveFileName:=fn;
  try
   if not putjpgfile(FSaveFileName, FSaveQuality, FSaveSmooth, picture.Bitmap, TMultiImageCallBack) then
      MessageDlg('Writing jpg file failed', mtInformation, [mbOk], 0);
  except

  end;
end;

{------------------------------------------------------------------------}
function TMultiImage.GetInfoAndType(filename : TFilename) : Boolean;
var
  Pextension : string[4];
  f          : file of byte;
begin
 Pextension:=UpperCase(ExtractFileExt(Filename));

 if (Pextension =  '.WMF') or (Pextension =  '.ICO') or (Pextension =  '.SCM') then begin

   if fileexists(Filename) then begin
    Delete(Pextension,1,1);
    BFiletype           := Pextension;
    Bwidth              := Picture.width;
    BHeight             := Picture.Height;
    Bbitspixel          := 0;
    Bplanes             := 0;
    Bnumcolors          := 0;
    Bcompression        := Pextension;
    AssignFile(f, FFileName);
    Reset(f);
    Bsize := FileSize(f);
    CloseFile(f);
    GetInfoAndType:=true;
    exit;
   end else

   begin
    BFiletype           := 'ERR';
    Bwidth              := -1;
    BHeight             := -1;
    Bbitspixel          := -1;
    Bplanes             := -1;
    Bnumcolors          := -1;
    Bcompression        := 'ERR';
    Bsize               := -1;
    GetInfoAndType      := false;
    exit;
   end;
  end;

  GetInfoAndType:=GetFileInfo(filename,
                              BFileType,
                              Bwidth,
                              BHeight,
                              Bbitspixel,
                              Bplanes,
                              Bnumcolors,
                              Bcompression);
   AssignFile(f, FileName);
   Reset(f);
   Bsize := FileSize(f);
   CloseFile(f);
 end;
{------------------------------------------------------------------------
 ClipBoard stuff
------------------------------------------------------------------------}

procedure TMultiImage.WMCut(var Message: TMessage);
begin
  CutToClipboard;
end;
{------------------------------------------------------------------------}

procedure TMultiImage.WMCopy(var Message: TMessage);
begin
  CopyToClipboard;
end;
{------------------------------------------------------------------------}

procedure TMultiImage.WMPaste(var Message: TMessage);
begin
  PasteFromClipboard;
end;
{------------------------------------------------------------------------}

procedure TMultiImage.CopyToClipboard;
begin
  if Picture.Graphic <> nil then Clipboard.Assign(Picture);
end;
{------------------------------------------------------------------------}

procedure TMultiImage.CutToClipboard;
begin
  if Picture.Graphic <> nil then
  begin
    CopyToClipboard;
    Picture.Graphic := nil;
  end;
end;
{------------------------------------------------------------------------}

procedure TMultiImage.PasteFromClipboard;
begin
  if Clipboard.HasFormat(CF_PICTURE) then begin
    MessageRunning:=False;
    Picture.Assign(Clipboard);
  end;
end;
{------------------------------------------------------------------------}

procedure TMultiImage.KeyDown(var Key: Word; Shift: TShiftState);
begin
  inherited KeyDown(Key, Shift);
  case Key of
    VK_INSERT:
      if ssShift in Shift then PasteFromClipBoard else
        if ssCtrl in Shift then CopyToClipBoard;
    VK_DELETE:
      if ssShift in Shift then CutToClipBoard;
  end;
end;
{------------------------------------------------------------------------}

procedure TMultiImage.KeyPress(var Key: Char);
begin
  inherited KeyPress(Key);
  case Key of
    ^X: CutToClipBoard;
    ^C: CopyToClipBoard;
    ^V: PasteFromClipBoard;
  end;
end;
{------------------------------------------------------------------------
 scrolling message stuff
------------------------------------------------------------------------}

procedure TMultiImage.LoadMessageFromFile(MessageName : TFileName);
var
  Msg      : TLabel;
begin
  Picture.Assign(nil);
  ScreenWd:=Width;
  ScreenHt:=Height;
  Msg := TLabel.Create(Self);
  readmessagefromfile(MessageName, MsgFont, MsgSpeed, MsgBkGrnd, MsgText);
  Refresh;
  if MsgText[Length(MsgText)] <> ' ' then MsgText:=MsgText+' ';
  Msg.Parent :=Self;
  Msg.Visible := False;
  Msg.Font := MsgFont;
  Msg.Caption := MsgText;
  BitWidth:=Msg.Width;
  SMessageLeft := ScreenWd;
  SMessageRight := ScreenWd + Msg.Width;
  SMessageTop := (ScreenHt - Msg.Height) Div 2;
  BitMsg.Width := Msg.Width;
  BitMsg.Height := Msg.Height;

  with Canvas do begin
    Brush.Style := bsSolid;
    Brush.Color:=MsgBkGrnd;
    Rectangle(0, 0, Width, Height);
  end;

  with BitMsg.Canvas do begin
    Brush.Color := MsgBkGrnd;
    Font := Msg.Font;
    TextOut(0,0,Msg.Caption);
  end;

   Msg.Free;
   Msg := nil;
   MessageRunning:=True;
end;
{------------------------------------------------------------------------}

procedure TMultiImage.NewMessage;
var
  Msg      : TLabel;
begin
  if MsgText = '' then exit;
  if MsgText[Length(MsgText)] <> ' ' then MsgText:=MsgText+' ';
  Picture.Assign(nil);
  ScreenWd:=Width;
  ScreenHt:=Height;
  Msg := TLabel.Create(Self);
  Refresh;
  Msg.Parent :=Self;
  Msg.Visible := False;
  Msg.Font := MsgFont;
  Msg.Caption := MsgText;
  BitWidth:=Msg.Width;
  SMessageLeft := ScreenWd;
  SMessageRight := ScreenWd + Msg.Width;
  SMessageTop := (ScreenHt - Msg.Height) Div 2;
  BitMsg.Width := Msg.Width;
  BitMsg.Height := Msg.Height;

  with Canvas do begin
    Brush.Style := bsSolid;
    Brush.Color:=MsgBkGrnd;
    Rectangle(0, 0, Width, Height);
  end;

  with BitMsg.Canvas do begin
    Brush.Color := MsgBkGrnd;
    Font := Msg.Font;
    TextOut(0,0,Msg.Caption);
  end;

   Msg.Free;
   Msg := nil;
   MessageRunning:=True;
end;
{------------------------------------------------------------------------}

procedure TMultiImage.SaveCurrentMessage(MessageName : TFileName);
begin
  WriteMessageToFile(MessageName, MsgFont, MsgSpeed, MsgBkGrnd, MsgText);
end;
{------------------------------------------------------------------------}

procedure TMultiImage.CreateMessage(MessagePath : String; AutoLoad : Boolean);
var
 SaveDlg : TSaveDialog;
 MsName  : TFilename;
begin
 Application.CreateForm(TSetupMsg, SetupMsg );
 SetupMsg.ShowModal;
 MsName:='';
 if SetupMsg.ModalResult = mrOK then begin
   SaveDlg :=TSaveDialog.Create(self);
   SaveDlg.DefaultExt:='scm';
   SaveDlg.Filter:='scrollmessage|*.scm';
   SaveDlg.Options:=[ofOverwritePrompt];
   SaveDlg.InitialDir:=MessagePath;
   if SaveDlg.Execute then begin
    MsName:=SaveDlg.Filename;
    WriteMessageToFile(MsName, SetupMsg.MessageFont, SetupMsg.MessageSpeed,
                       SetupMsg.MessageColor, SetupMsg.MessageMsg);
   end;
   SaveDlg.free;
 end;

 SetupMsg.destroy;
 SetupMsg:=Nil;

 if (AutoLoad) and (MsName <> '')  then
   LoadMessageFromFile(MsName)
 else
   NewMessage;
end;
{------------------------------------------------------------------------}

Procedure TMultiImage.FreeMsg;
Begin
  Picture.Assign(nil);
  MessageRunning:=False;
end;
{------------------------------------------------------------------------}

Function TMultiImage.Delay(Ms : Integer) : boolean;
Begin
 Inc(DelayCounter);
 if DelayCounter > MS then begin
    DelayCounter:=0;
    Result:=true;
 end else
  Result:=false;
end;
{------------------------------------------------------------------------}

Procedure TMultiImage.MoveMsg(Var WinMsg : TMessage);
Begin
  if Not MessageRunning then exit;
  if not Delay(MsgSpeed) then exit;
  Dec(SMessageLeft,1);
  Dec(SMessageRight,1);
  if SMessageRight < 0 then begin
    SMessageLeft := ScreenWd;
    SMessageRight := SMessageLeft + BitWidth;
  end;
  Picture.Bitmap.Canvas.Draw(SMessageLeft,SMessageTop,BitMsg);
end;
{------------------------------------------------------------------------}

Procedure TMultiImage.Trigger;
Begin
  PostMessage(Handle, WM_Trigger, 0, 0);
  if visible then
   if SetupMsg <> nil then SetupMsg.Trigger;
End;

{------------------------------------------------------------------------
Printing Stuff
------------------------------------------------------------------------}

procedure TMultiImage.PrintMultiImage(X, Y, pWidth, pHeight: Integer);
begin
 if Picture.Graphic.Empty then exit;

 if (BFiletype = 'ICO') or (BFiletype = 'WMF') then
   PrintICOWMF(X, Y, pWidth, pHeight)
 else
   PrintBitMap(X, Y, pWidth, pHeight)
end;
{---------------------------------------------------------------------}

procedure TMultiImage.PrintBitMap(X, Y, pWidth, pHeight: Integer);
var
  Info     : PBitmapInfo;
  InfoSize : Integer;
  Image    : Pointer;
  ImageSize: Longint;
begin
   if (pWidth < 1) or (pHeight < 1) then begin
      pWidth:=Picture.Bitmap.Width;
      pHeight:=Picture.Bitmap.Height;
   end;

   Printer.Begindoc;

    with Picture.Bitmap do begin
      GetDIBSizes(Handle, InfoSize, ImageSize);
      Info := MemAlloc(InfoSize);
      try
        Image := MemAlloc(ImageSize);
        try
          GetDIB(Handle, Palette, Info^, Image^);
          with Info^.bmiHeader do
           StretchDIBits(Printer.Canvas.Handle, X, Y, pWidth,
            pHeight, 0, 0, biWidth, biHeight, Image, Info^,
            DIB_RGB_COLORS, SRCCOPY)
         finally
          FreeMem(Image, ImageSize);
         end;
      finally
       FreeMem(Info, InfoSize);
      end;
    end;
    Printer.Enddoc;
  end;
{---------------------------------------------------------------------}

procedure TMultiImage.PrintICOWMF(X, Y, pWidth, pHeight: Integer);
begin
   if (pWidth < 1) or (pHeight < 1) then begin
    pWidth:=Picture.Graphic.Width;
    pHeight:=Picture.Graphic.Height;
   end;

   Printer.Begindoc;

   Printer.Canvas.StretchDraw(Rect(X, Y, pWidth, pHeight), Picture.Graphic);

   Printer.Enddoc;
end;
{------------------------------------------------------------------------
end TMultiImage
------------------------------------------------------------------------}


begin
 TMultiImageCallBack:=nil;
end.