PC World Komputer 1997 May/Pcwk0597.iso/delphi/imagelib/tmultip.pa_/tmultip.pa

Text File | 1995-11-19 | 37.9 KB | 1,315 lines

{$X+,I-,R-,F+,T-}   {<<<<  This is a switch. Don't delete it}

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

With thanks to Andy Satori for his Visual Component advise. Andy can
be reached on CIS [71221,2010] or http://TheClassifieds.Com

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

Part of Imagelib VCL/DLL Library. Uses ImageLib 3.0 Changed the callback
to a function instead of a procedure to let the user cancel out.

Bug fixes:

Changed callback in version 2.21 to a function with cdecl using the
C calling convention.

Version 2.2.2 Added property ImageLibPalette which If set to True will
use the ImageLib Way to paint. If False it will paint the Delphi way.
This is a fix of a Stretchdraw Delphi bug which doesn't paint correctly
256 color palettes on 256 color Video cards

Bug fix in respect to the filemode. If file was in read only mode
an error occured}


unit TMultiP; {To be used with version 3.0 of imagelib vcl}

interface

uses Setcr30, Setsr30,
     SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Forms,
     Controls, Extctrls, StdCtrls, DLL30, Menus, Mask, Buttons, Printers;


type
  TPMultiImage = class(TCustomControl)
  private
    FPicture            : TPicture;
    FAutoSize           : Boolean;
    FBorderStyle        : TBorderStyle;
    FStretch            : Boolean;
    FCenter             : Boolean;
    FReserved           : Byte;
    FFilename           : TFilename;
    FDither             : Boolean;
    FReadResolution     : TResolution;
    FWriteResolution    : TResolution;
    FInterlaced         : Boolean;
    FSaveQuality        : Byte;
    FSaveSmooth         : Byte;
    FSaveFilename       : TFilename;
    FImageLibPalette    : Boolean;
    Temps               : TFilename;
    BitMsg              : TBitmap;
    SMessageLeft        : Integer;
    SMessageRight       : Integer;
    SMessageTop         : Integer;
    ScreenWd            : Integer;
    ScreenHt            : Integer;
    BitWidth            : Integer;
    DelayCounter        : Longint;
    OldColor            : TColor;
    SMessageBottom      : Integer;
    BitHeight           : Integer;
    Creditcounter       : Integer;
    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;
    Procedure MoveCredMsg(Var WinMsg : TMessage); message WM_CTrigger;
    procedure LoadCreditMessageFromFile(MessageName : TFilename);
  public
    BFiletype           :  String;
    Bwidth              :  Integer;
    BHeight             :  Integer;
    Bbitspixel          :  Integer;
    Bplanes             :  Integer;
    Bnumcolors          :  Integer;
    BSize               :  Longint;
    Bcompression        :  String;
    {Messages}
    MessageRunning      :  Boolean;
    MsgText             :  String;
    MsgFont             :  TFont;
    MsgBkGrnd           :  TColor;
    MsgSpeed            :  Integer;
    {credit message}
    CreditBoxList       :  TStringList;
    CMessageRunning     :  Boolean;
    ResProgName         :  String;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure CopyToClipboard;
    procedure CutToClipboard;
    procedure PasteFromClipboard;
    function GetMultiBitmap : String;
    Procedure WriteMultiName(Name : String);
    procedure Paint; override;
    procedure PaintTheDelpiWay;
    function GetSmooth : Byte;
    procedure SetSmooth(smooth : Byte);
    function GetQuality : Byte;
    procedure SetQuality(Quality : Byte);
    procedure SetReadRes(Res : TResolution);
    procedure SetWriteRes(Res : TResolution);
    function GetSaveFilename : TFilename;
    procedure SetSaveFilename(fn : TFilename);
    procedure SaveAsJpg(FN : TFilename);
    procedure SaveAsBMP(FN : TFilename);
    procedure SaveAsPNG(FN : TFilename);
    procedure SaveAsGIF(FN : TFilename);
    procedure SaveAsPCX(FN : TFilename);
    function GetInfoAndType(Filename : TFilename) : Boolean;
    {function LoadBMPFromResource(ProgName, BMPResName : String) : Boolean;}
    {scrolling message}
    Procedure Trigger;
    procedure CreateMessage(MessagePath : String; AutoLoad : Boolean);
    procedure SaveCurrentMessage(MessageName : TFilename);
    procedure NewMessage;
    Procedure FreeMsg;
    {credit message}
    procedure CreateCreditMessage(MessagePath : String; AutoLoad : Boolean);
    procedure SaveCurrentCreditMessage(MessageName : TFilename);
    procedure NewCreditMessage;
    {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 Color;
    property DragCursor;
    property DragMode;
    property DefSaveFilename : TFilename read GetSaveFilename write SetSaveFilename;
    property Enabled;
    property Picture: TPicture read FPicture write SetPicture;
    property ImageName  : String read GetMultiBitmap write WriteMultiName;
    property ImageLibPalette : Boolean read FImageLibPalette write FImageLibPalette default True;
    property ImageDither : Boolean read FDither write FDither;
    property ImageReadRes : TResolution read FReadResolution write SetReadRes;
    property ImageWriteRes : TResolution read FWriteResolution write SetWriteRes;
    property JPegSaveQuality : Byte read GetQuality write SetQuality;
    property JPegSaveSmooth : Byte read GetSmooth write SetSmooth;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property ParentColor default False;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property PNGInterLaced : Boolean read FInterlaced write FInterlaced default False;
    property ShowHint;
    property Stretch: Boolean read FStretch write SetStretch default False;
    property TabOrder;
    property TabStop default True;
    property Visible;
  end;


var
 TPMultiImageCallBack   : TCallBackFunction;

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

implementation

  uses   Consts, Clipbrd, Dialogs;

{------------------------------------------------------------------------
 TPMultiImage.
------------------------------------------------------------------------}

constructor TPMultiImage.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FPicture := TPicture.Create;
  FPicture.OnChange := PictureChanged;
  FFilename:='';
  FDither:=True;
  FReadResolution := Color256;
  FWriteResolution := Color256;
  FSaveQuality:=25;
  FSaveSmooth:=0;
  FBorderStyle := bsNone;
  FImageLibPalette:=True;
  FInterlaced:=False;
  Picture.Graphic := nil;
  Height := 105;
  Width := 105;
  MsgFont:=TFont.Create;
  BitMsg := TBitmap.Create;
  MessageRunning:=False;
  CMessageRunning:=False;
  SetupMsg30:=Nil;
  SetupCredMsg30:=Nil;
  DelayCounter:=0;
  Color:=clBtnFace;
  CreditBoxList:=TStringList.Create;
  Creditcounter:=0;
  ResProgName:='';
 end;
{------------------------------------------------------------------------}

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

function TPMultiImage.GetPalette: HPALETTE;
begin
  Result := 0;
  If ImageLibPalette then Exit;
  If FPicture.Graphic is TBitmap then
    Result := TBitmap(FPicture.Graphic).Palette;
end;
{------------------------------------------------------------------------}

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

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

procedure TPMultiImage.Paint;
var
  W, H: Integer;
  R: TRect;
  S: String[63];
  OldBitmap : HBitmap;
  MemDC : HDC;
  hOldPal : HPalette;
begin

  If csDesigning in ComponentState then
    with Canvas do
    begin
      Pen.Style := psDash;
      Brush.Style := bsClear;
      Rectangle(0, 0, Width, Height);
    end;

  If (BFileType = 'ICO') or (BFileType = 'WMF') or (not ImageLibPalette) then begin
      PaintTheDelpiWay;
      Exit;
  end;

  with Canvas do begin
    Brush.Style := bsSolid;
    Brush.Color := Color;

    If Picture.Graphic <> nil then
    If Stretch then begin

      hOldPal := SelectPalette(Canvas.handle,Picture.Bitmap.Palette,False);
      RealizePalette(Canvas.handle);
      MemDC := CreateCompatibleDC(Canvas.handle);
      OldBitmap := SelectObject(MemDC,Picture.Bitmap.Handle);
      SetStretchBltMode(canvas.handle,STRETCH_DELETESCANS);
      StretchBlt(Canvas.handle,
                 ClientRect.Left,
                 ClientRect.Top,
                 ClientRect.Right,
                 ClientRect.Bottom,
                 MemDC,
                 ClientRect.Left,
                 ClientRect.Top,
                 Picture.Bitmap.Width,
                 Picture.Bitmap.Height,
                 SrcCopy);

      SelectObject(MemDC,OldBitmap);
      DeleteDC(MemDC);
      SelectPalette(Canvas.handle,hOldPal,False);

     end else begin

      SetRect(R, 0, 0, Picture.Width, Picture.Height);
      If Center then OffsetRect(R, (ClientWidth - Picture.Width) div 2,
          (ClientHeight - Picture.Height) div 2);

      hOldPal := SelectPalette(Canvas.handle,Picture.Bitmap.Palette,False);
      RealizePalette(Canvas.handle);
      MemDC := CreateCompatibleDC(Canvas.handle);
      OldBitmap := SelectObject(MemDC,Picture.Bitmap.Handle);

      BitBlt(Canvas.handle,
             R.Left,
             R.Top,
             Picture.Bitmap.Width,
             Picture.Bitmap.Height,
             MemDC,
             0,
             0,
             srcCopy);

      SelectObject(MemDC,OldBitmap);
      DeleteDC(MemDC);
      SelectPalette(Canvas.handle,hOldPal,False);
    end;

    If (GetParentForm(Self).ActiveControl = Self) and
      not (csDesigning in ComponentState) then
    begin
      Brush.Color := clWindowFrame;
      FrameRect(ClientRect);
    end;

  end;
  If (MessageRunning) and (Picture = nil) then FreeMsg;
  If (CMessageRunning) and (Picture = nil) then FreeMsg;
end;
{------------------------------------------------------------------------}

procedure TPMultiImage.PaintTheDelpiWay;
var
  Dest : TRect;
begin
  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);
    Canvas.StretchDraw(Dest, Picture.Graphic);
end;
{------------------------------------------------------------------------}


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

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

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

procedure TPMultiImage.SetStretch(Value: Boolean);
begin
  If FStretch <> Value then
  begin
    FStretch := Value;
    Invalidate;
  end;
end;
{------------------------------------------------------------------------}

procedure TPMultiImage.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;
{------------------------------------------------------------------------}

procedure TPMultiImage.SetReadRes(Res : TResolution);
begin
  FReadResolution := Res;
end;
{------------------------------------------------------------------------}

procedure TPMultiImage.SetWriteRes(Res : TResolution);
begin
  FWriteResolution := Res;
end;
{------------------------------------------------------------------------}

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


function TPMultiImage.GetMultiBitmap :  String;
var    Bitmap     : TBitmap;
       Pextension : String[4];
       OnExcept   : Boolean;
       F          : file of Byte;
       Dith       : Integer;
       ReadRes    : Integer;

label  BreakIt;

begin
  OnExcept:=False;

  Pextension:=UpperCase(ExtractFileExt(FFilename));

  If Pextension <>  '.RES' then
  If not FileExists(FFilename) then begin
     Picture.Graphic := nil;
     Temps:='file not found';
     GetMultiBitmap:=Temps;
     Exit;
  end;

  If FReadResolution = Color16 then ReadRes := 4;
  If FReadResolution = Color256 then ReadRes := 8;
  If FReadResolution = ColorTrue then ReadRes := 24;

  If FDither then
    Dith:=1
  else
    Dith:=0;

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

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

 If Pextension = '.CMS' then begin
    try
     FreeMsg;
     LoadCreditMessageFromFile(FFilename);
    except
     Picture.Graphic := nil;
     OnExcept:=True;
    end;
    If OnExcept then Goto BreakIt;
    GetInfoAndType(FFilename);
 end;

 If csDesigning in ComponentState then
  If (UpperCase(FFilename) = Temps) and (Picture.Bitmap <> nil) then Goto BreakIt;

 If Pextension = '.BMP' then begin
   try
     FreeMsg;
     Bitmap := TBitmap.Create;
     If not bmpfile(FFilename, ReadRes, Dith, Bitmap, TPMultiImageCallBack) 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 = '.RES' then begin
   try
     FreeMsg;
     Bitmap := TBitmap.Create;
     If not resfile(ResProgName, JustName(FFilename), Handle, Bitmap) then
       MessageDlg('Reading resource 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 = '.PNG' then begin
    try
     FreeMsg;
     Bitmap := TBitmap.Create;
     If not pngfile(FFilename, ReadRes, Dith, Bitmap, TPMultiImageCallBack) then
       MessageDlg('Reading png 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, ReadRes, Dith, Bitmap, TPMultiImageCallBack) 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, ReadRes, Dith, Bitmap, TPMultiImageCallBack) 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, ReadRes, Dith, Bitmap, TPMultiImageCallBack) 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 TPMultiImage.GetSmooth : Byte;
begin
  GetSmooth:=FSaveSmooth;
end;
{------------------------------------------------------------------------}

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

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

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

function TPMultiImage.GetSaveFilename : TFilename;
begin
  GetSaveFilename:=FSaveFilename;
end;
{------------------------------------------------------------------------}

procedure TPMultiImage.SetSaveFilename(fn : TFilename);
begin
 If fn <> '' then
   FSaveFilename:=fn
 else
   FSaveFilename:='';
end;


{------------------------------------------------------------------------}
procedure TPMultiImage.SaveAsBMP(FN : TFilename);
var
  WriteRes : Integer;
begin

  If FWriteResolution = Color16 then WriteRes := 4;
  If FWriteResolution = Color256 then WriteRes := 8;
  If FWriteResolution = ColorTrue then WriteRes := 24;

  If fn <> '' then FSaveFilename:=fn;
  try
    If not putbmpfile(FSaveFilename, WriteRes, Picture.Bitmap, TPMultiImageCallBack) then
      MessageDlg('Writing bmp file failed', mtInformation, [mbOk], 0);
  except

  end;
end;

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

procedure TPMultiImage.SaveAsPNG(FN : TFilename);
var
  WriteRes : Integer;
  InterL   : Byte;
begin
  If FWriteResolution = Color16 then WriteRes := 4;
  If FWriteResolution = Color256 then WriteRes := 8;
  If FWriteResolution = ColorTrue then WriteRes := 24;
  If FInterlaced then InterL :=1 else InterL :=0;

  If fn <> '' then FSaveFilename:=fn;

  try
    If not putpngfile(FSaveFilename, WriteRes, Interl, Picture.Bitmap, TPMultiImageCallBack) then
      MessageDlg('Writing png file failed', mtInformation, [mbOk], 0);
  except

  end;
end;

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

procedure TPMultiImage.SaveAsJpg(FN : TFilename);
begin
   If fn <> '' then FSaveFilename:=fn;
  try
   If not putjpgfile(FSaveFilename, FSaveQuality, FSaveSmooth, picture.Bitmap, TPMultiImageCallBack) then
      MessageDlg('Writing jpg file failed', mtInformation, [mbOk], 0);
  except

  end;
end;
{------------------------------------------------------------------------}

procedure TPMultiImage.SaveAsGIF(FN : TFilename);
var
  WriteRes : Integer;
begin

  If FWriteResolution = Color16 then WriteRes := 4;
  If FWriteResolution = Color256 then WriteRes := 8;
  If FWriteResolution = ColorTrue then WriteRes := 24;

  If fn <> '' then FSaveFilename:=fn;
  try
    If not putgiffile(FSaveFilename, WriteRes, Picture.Bitmap, TPMultiImageCallBack) then
      MessageDlg('Writing gif file failed', mtInformation, [mbOk], 0);
  except

  end;
end;
{------------------------------------------------------------------------}

procedure TPMultiImage.SaveAsPCX(FN : TFilename);
var
  WriteRes : Integer;
begin

  If FWriteResolution = Color16 then WriteRes := 4;
  If FWriteResolution = Color256 then WriteRes := 8;
  If FWriteResolution = ColorTrue then WriteRes := 24;

  If fn <> '' then FSaveFilename:=fn;
  try
   If not putpcxfile(FSaveFilename, WriteRes, Picture.Bitmap, TPMultiImageCallBack) then
      MessageDlg('Writing pcx file failed', mtInformation, [mbOk], 0);
  except

  end;
end;
{------------------------------------------------------------------------}

function TPMultiImage.GetInfoAndType(Filename : TFilename) : Boolean;
var
  Pextension : string[4];
  f          : file of byte;
  InfoSize   : Integer;
  OldFileMode: Byte;
begin
 Pextension:=UpperCase(ExtractFileExt(Filename));

 If (Pextension =  '.RES') then begin
    BFiletype           := 'RES';
    Bwidth              := Picture.width;
    BHeight             := Picture.Height;
    Bbitspixel          := 0;
    Bplanes             := 0;
    Bnumcolors          := 0;
    Bcompression        := 'BMP';
    GetDIBSizes(Picture.BitMap.Handle, InfoSize, Bsize);
    Bsize:=Bsize+InfoSize;
    GetInfoAndType:=True;
    Exit;
  end else

 if (Pextension =  '.WMF') or
    (Pextension =  '.ICO') or
    (Pextension =  '.SCM') or
    (Pextension =  '.CMS') 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;
    OldFileMode:= FileMode;
    FileMode:=0;
    AssignFile(f, FFileName);
    Reset(f);
    Bsize := FileSize(f);
    CloseFile(f);
    FileMode:=OldFileMode;
    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);

   OldFileMode:= FileMode;
   FileMode:=0;
   AssignFile(f, FileName);
   Reset(f);
   Bsize := FileSize(f);
   CloseFile(f);
   FileMode:=OldFileMode;
 end;
{------------------------------------------------------------------------
 ClipBoard stuff
------------------------------------------------------------------------}

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

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

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

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

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

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

procedure TPMultiImage.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 TPMultiImage.KeyPress(var Key: Char);
begin
  inherited KeyPress(Key);
  case Key of
    ^X: CutToClipBoard;
    ^C: CopyToClipBoard;
    ^V: PasteFromClipBoard;
  end;
end;
{------------------------------------------------------------------------
 scrolling message stuff
------------------------------------------------------------------------}

procedure TPMultiImage.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;
  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;
  OldColor:=Color;
  Color:=MsgBkGrnd;

  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 TPMultiImage.NewMessage;
var
  Msg      : TLabel;
begin
  FreeMsg;
  If MsgText = '' then Exit;
  If MsgText[Length(MsgText)] <> ' ' then MsgText:=MsgText+' ';
  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;
  OldColor:=Color;
  Color:=MsgBkGrnd;

  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 TPMultiImage.SaveCurrentMessage(MessageName : TFilename);
begin
  WriteMessageToFile(MessageName, MsgFont, MsgSpeed, MsgBkGrnd, MsgText);
end;
{------------------------------------------------------------------------}

procedure TPMultiImage.CreateMessage(MessagePath : String; AutoLoad : Boolean);
var
 SaveDlg : TSaveDialog;
 MsName  : TFilename;
begin
 SetupMsg30:=TSetupMsg30.Create(Self);
 SetupMsg30.ShowModal;
 MsName:='';
 If SetupMsg30.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,
                       SetupMsg30.MessageFont,
                       SetupMsg30.MessageSpeed,
                       SetupMsg30.MessageColor,
                       SetupMsg30.MessageMsg);
    If (AutoLoad) and (MsName <> '')  then
      LoadMessageFromFile(MsName)
    else
      NewMessage;

   end;
   SaveDlg.free;
 end;
 SetupMsg30.destroy;
 SetupMsg30:=Nil;
end;
{------------------------------------------------------------------------}

Procedure TPMultiImage.FreeMsg;
Begin
  If MessageRunning then
   Color:=OldColor;
  If CMessageRunning then
   Color:=OldColor;
  CMessageRunning:=False;
  MessageRunning:=False;
  Picture.Assign(nil);
end;
{------------------------------------------------------------------------}

Function TPMultiImage.Delay(Ms : Integer) : boolean;
Begin
 Inc(DelayCounter);
 If DelayCounter > MS then begin
    DelayCounter:=0;
    Result:=True;
 end else
  Result:=False;
end;
{------------------------------------------------------------------------}

Procedure TPMultiImage.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;
    with Canvas do
       Draw(SMessageLeft,SMessageTop,BitMsg);
end;
{------------------------------------------------------------------------}

Procedure TPMultiImage.Trigger;
Begin
  PostMessage(Handle, WM_Trigger, 0, 0);
  PostMessage(Handle, WM_CTrigger, 0, 0);
  If visible then begin
   If SetupMsg30 <> nil then SetupMsg30.Trigger;
   If SetupCredMsg30 <> nil then SetupCredMsg30.Trigger;
  end;
End;
{------------------------------------------------------------------------
 credit message stuff
------------------------------------------------------------------------}

procedure TPMultiImage.LoadCreditMessageFromFile(MessageName : TFilename);
var
  Msg      : TLabel;
begin
  Picture.Assign(nil);
  ReadCreditFromFile(MessageName, MsgFont, MsgSpeed, MsgBkGrnd, CreditBoxList);
  Creditcounter:=0;
  If CreditBoxList.Count <1 then Exit;
  MsgText:=CreditBoxList.Strings[Creditcounter];

  If MsgText = '' then Exit;
  If MsgText[1] <> ' ' then MsgText:='  ' + MsgText;
  If MsgText[Length(MsgText)] <> ' ' then MsgText:=MsgText+' ';

  ScreenWd:=Width;
  ScreenHt:=Height;
  Refresh;
  Msg := TLabel.Create(Self);
  Refresh;
  Msg.Parent :=Self;
  Msg.Visible := False;
  Msg.Font := MsgFont;
  Msg.Caption := MsgText;
  Msg.Width:=Msg.Width+(Msg.Width div (Length(MsgText)-2));
  BitHeight:=Msg.Height;
  BitWidth:=Msg.Width;
  SMessageLeft :=(ScreenWd - Msg.Width) Div 2;
  SMessageTop := ScreenHt;
  SMessageBottom := SMessageTop + Msg.Height;

  BitMsg.Width := Msg.Width;
  BitMsg.Height := Msg.Height+5;
  OldColor:=Color;
  Color:=MsgBkGrnd;

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

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

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

procedure TPMultiImage.NewCreditMessage;
var
  Msg      : TLabel;
begin
  If CreditBoxList.Count <1 then Exit;
  If Creditcounter > CreditBoxList.Count then Creditcounter:=0;

  MsgText:=CreditBoxList.Strings[Creditcounter];
  If MsgText = '' then Exit;

  If MsgText[1] <> ' ' then MsgText:='  ' + MsgText;
  If MsgText[Length(MsgText)] <> ' ' then MsgText:=MsgText+' ';

  ScreenWd:=Width;
  ScreenHt:=Height;
  Msg := TLabel.Create(Self);
  Refresh;
  Msg.Parent :=Self;
  Msg.Visible := False;
  Msg.Font := MsgFont;
  Msg.Caption := MsgText;
  BitHeight:=Msg.Height;
  Msg.Width:=Msg.Width+(Msg.Width div (Length(MsgText)-2));
  BitWidth:=Msg.Width;
  SMessageLeft :=(ScreenWd - Msg.Width) Div 2;
  SMessageTop := ScreenHt;
  SMessageBottom := SMessageTop + Msg.Height;
  BitMsg.Width := Msg.Width;
  BitMsg.Height := Msg.Height+5;
  if not CMessageRunning then
   OldColor:=Color;
  Color:=MsgBkGrnd;

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

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

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

procedure TPMultiImage.SaveCurrentCreditMessage(MessageName : TFilename);
begin
  WriteCreditToFile(MessageName, MsgFont, MsgSpeed, MsgBkGrnd, CreditBoxList);
end;
{------------------------------------------------------------------------}

procedure TPMultiImage.CreateCreditMessage(MessagePath : String; AutoLoad : Boolean);
var
 SaveDlg : TSaveDialog;
 MsName  : TFilename;
begin
 MsName:='';
 SetupCredMsg30:=TSetupCredMsg30.Create(Self);
 SetupCredMsg30.ShowModal;
 If SetupCredMsg30.ModalResult = mrOK then begin
   SaveDlg :=TSaveDialog.Create(self);
   SaveDlg.DefaultExt:='cms';
   SaveDlg.Filter:='credit message|*.cms';
   SaveDlg.Options:=[ofOverwritePrompt];
   SaveDlg.InitialDir:=MessagePath;
   If SaveDlg.Execute then begin
    MsName:=SaveDlg.Filename;
    WriteCreditToFile(MsName,
                      SetupCredMsg30.MessageFont,
                      SetupCredMsg30.MessageSpeed,
                      SetupCredMsg30.MessageColor,
                      SetupCredMsg30.MessageStrList);

    If (AutoLoad) and (MsName <> '')  then
      LoadCreditMessageFromFile(MsName)
    else
      NewCreditMessage;

   end;
   SaveDlg.free;
 end;

 SetupCredMsg30.free;
 SetupCredMsg30:=Nil;
 Creditcounter:=0;
end;
{------------------------------------------------------------------------}

Procedure TPMultiImage.MoveCredMsg(Var WinMsg : TMessage);
Begin
  If Not CMessageRunning then Exit;
  If not Delay(MsgSpeed) then Exit;
  Dec(SMessageTop,1);
  Dec(SMessageBottom,1);
  If SMessageTop < (0-BitHeight)-5 then begin
     If CreditBoxList.Count >0 then begin
        If Creditcounter < CreditBoxList.Count-1 then
           Inc(Creditcounter)
        else Creditcounter:=0;
        NewCreditMessage;
     end else begin
         SMessageTop := ScreenHt;
         SMessageBottom := SMessageTop + BitHeight;
     end;
  end;

  with Canvas do Draw(SMessageLeft,SMessageTop,BitMsg);
end;

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

procedure TPMultiImage.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 TPMultiImage.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 TPMultiImage.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 TPMultiImage
------------------------------------------------------------------------}


begin
 TPMultiImageCallBack:=nil;
end.