home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 1997 May / Pcwk0597.iso / delphi / imagelib / tmultip.pa_ / tmultip.pa
Text File  |  1995-11-19  |  39KB  |  1,315 lines
  1. {$X+,I-,R-,F+,T-}   {<<<<  This is a switch. Don't delete it}
  2.  
  3. {Copyright 1995 by
  4.  Kevin Adams, 74742,1444
  5.  Jan Dekkers, 72130,353
  6.  
  7. With thanks to Andy Satori for his Visual Component advise. Andy can
  8. be reached on CIS [71221,2010] or http://TheClassifieds.Com
  9.  
  10. No part of this Unit may be copied in any way. However, you may derive
  11. other objects from TPMultiImage.
  12.  
  13. Part of Imagelib VCL/DLL Library. Uses ImageLib 3.0 Changed the callback
  14. to a function instead of a procedure to let the user cancel out.
  15.  
  16. Bug fixes:
  17.  
  18. Changed callback in version 2.21 to a function with cdecl using the
  19. C calling convention.
  20.  
  21. Version 2.2.2 Added property ImageLibPalette which If set to True will
  22. use the ImageLib Way to paint. If False it will paint the Delphi way.
  23. This is a fix of a Stretchdraw Delphi bug which doesn't paint correctly
  24. 256 color palettes on 256 color Video cards
  25.  
  26. Bug fix in respect to the filemode. If file was in read only mode
  27. an error occured}
  28.  
  29.  
  30. unit TMultiP; {To be used with version 3.0 of imagelib vcl}
  31.  
  32. interface
  33.  
  34. uses Setcr30, Setsr30,
  35.      SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Forms,
  36.      Controls, Extctrls, StdCtrls, DLL30, Menus, Mask, Buttons, Printers;
  37.  
  38.  
  39. type
  40.   TPMultiImage = class(TCustomControl)
  41.   private
  42.     FPicture            : TPicture;
  43.     FAutoSize           : Boolean;
  44.     FBorderStyle        : TBorderStyle;
  45.     FStretch            : Boolean;
  46.     FCenter             : Boolean;
  47.     FReserved           : Byte;
  48.     FFilename           : TFilename;
  49.     FDither             : Boolean;
  50.     FReadResolution     : TResolution;
  51.     FWriteResolution    : TResolution;
  52.     FInterlaced         : Boolean;
  53.     FSaveQuality        : Byte;
  54.     FSaveSmooth         : Byte;
  55.     FSaveFilename       : TFilename;
  56.     FImageLibPalette    : Boolean;
  57.     Temps               : TFilename;
  58.     BitMsg              : TBitmap;
  59.     SMessageLeft        : Integer;
  60.     SMessageRight       : Integer;
  61.     SMessageTop         : Integer;
  62.     ScreenWd            : Integer;
  63.     ScreenHt            : Integer;
  64.     BitWidth            : Integer;
  65.     DelayCounter        : Longint;
  66.     OldColor            : TColor;
  67.     SMessageBottom      : Integer;
  68.     BitHeight           : Integer;
  69.     Creditcounter       : Integer;
  70.     procedure PictureChanged(Sender: TObject);
  71.     procedure SetAutoSize(Value: Boolean);
  72.     procedure SetCenter(Value: Boolean);
  73.     procedure SetPicture(Value: TPicture);
  74.     procedure SetStretch(Value: Boolean);
  75.     procedure SetBorderStyle(Value: TBorderStyle);
  76.     procedure WMCut(var Message: TMessage); message WM_CUT;
  77.     procedure WMCopy(var Message: TMessage); message WM_COPY;
  78.     procedure WMPaste(var Message: TMessage); message WM_PASTE;
  79.   protected
  80.     function GetPalette: HPALETTE; override;
  81.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  82.     procedure KeyPress(var Key: Char); override;
  83.     procedure CreateParams(var Params: TCreateParams); override;
  84.     procedure PrintICOWMF(X, Y, pWidth, pHeight: Integer);
  85.     procedure PrintBitmap(X, Y, pWidth, pHeight: Integer);
  86.     Procedure MoveMsg(Var WinMsg : TMessage); message WM_Trigger;
  87.     procedure LoadMessageFromFile(MessageName : TFilename);
  88.     Function Delay(Ms : Integer) : boolean;
  89.     Procedure MoveCredMsg(Var WinMsg : TMessage); message WM_CTrigger;
  90.     procedure LoadCreditMessageFromFile(MessageName : TFilename);
  91.   public
  92.     BFiletype           :  String;
  93.     Bwidth              :  Integer;
  94.     BHeight             :  Integer;
  95.     Bbitspixel          :  Integer;
  96.     Bplanes             :  Integer;
  97.     Bnumcolors          :  Integer;
  98.     BSize               :  Longint;
  99.     Bcompression        :  String;
  100.     {Messages}
  101.     MessageRunning      :  Boolean;
  102.     MsgText             :  String;
  103.     MsgFont             :  TFont;
  104.     MsgBkGrnd           :  TColor;
  105.     MsgSpeed            :  Integer;
  106.     {credit message}
  107.     CreditBoxList       :  TStringList;
  108.     CMessageRunning     :  Boolean;
  109.     ResProgName         :  String;
  110.     constructor Create(AOwner: TComponent); override;
  111.     destructor Destroy; override;
  112.     procedure CopyToClipboard;
  113.     procedure CutToClipboard;
  114.     procedure PasteFromClipboard;
  115.     function GetMultiBitmap : String;
  116.     Procedure WriteMultiName(Name : String);
  117.     procedure Paint; override;
  118.     procedure PaintTheDelpiWay;
  119.     function GetSmooth : Byte;
  120.     procedure SetSmooth(smooth : Byte);
  121.     function GetQuality : Byte;
  122.     procedure SetQuality(Quality : Byte);
  123.     procedure SetReadRes(Res : TResolution);
  124.     procedure SetWriteRes(Res : TResolution);
  125.     function GetSaveFilename : TFilename;
  126.     procedure SetSaveFilename(fn : TFilename);
  127.     procedure SaveAsJpg(FN : TFilename);
  128.     procedure SaveAsBMP(FN : TFilename);
  129.     procedure SaveAsPNG(FN : TFilename);
  130.     procedure SaveAsGIF(FN : TFilename);
  131.     procedure SaveAsPCX(FN : TFilename);
  132.     function GetInfoAndType(Filename : TFilename) : Boolean;
  133.     {function LoadBMPFromResource(ProgName, BMPResName : String) : Boolean;}
  134.     {scrolling message}
  135.     Procedure Trigger;
  136.     procedure CreateMessage(MessagePath : String; AutoLoad : Boolean);
  137.     procedure SaveCurrentMessage(MessageName : TFilename);
  138.     procedure NewMessage;
  139.     Procedure FreeMsg;
  140.     {credit message}
  141.     procedure CreateCreditMessage(MessagePath : String; AutoLoad : Boolean);
  142.     procedure SaveCurrentCreditMessage(MessageName : TFilename);
  143.     procedure NewCreditMessage;
  144.     {printing}
  145.     procedure PrintMultiImage(X, Y, pWidth, pHeight: Integer);
  146.   published
  147.     property Align;
  148.     property AutoSize: Boolean read FAutoSize write SetAutoSize default False;
  149.     property Center: Boolean read FCenter write SetCenter default False;
  150.     property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsNone;
  151.     property Color;
  152.     property DragCursor;
  153.     property DragMode;
  154.     property DefSaveFilename : TFilename read GetSaveFilename write SetSaveFilename;
  155.     property Enabled;
  156.     property Picture: TPicture read FPicture write SetPicture;
  157.     property ImageName  : String read GetMultiBitmap write WriteMultiName;
  158.     property ImageLibPalette : Boolean read FImageLibPalette write FImageLibPalette default True;
  159.     property ImageDither : Boolean read FDither write FDither;
  160.     property ImageReadRes : TResolution read FReadResolution write SetReadRes;
  161.     property ImageWriteRes : TResolution read FWriteResolution write SetWriteRes;
  162.     property JPegSaveQuality : Byte read GetQuality write SetQuality;
  163.     property JPegSaveSmooth : Byte read GetSmooth write SetSmooth;
  164.     property OnClick;
  165.     property OnDblClick;
  166.     property OnDragDrop;
  167.     property OnDragOver;
  168.     property OnEndDrag;
  169.     property OnKeyDown;
  170.     property OnKeyPress;
  171.     property OnKeyUp;
  172.     property OnMouseDown;
  173.     property OnMouseMove;
  174.     property OnMouseUp;
  175.     property ParentColor default False;
  176.     property ParentFont;
  177.     property ParentShowHint;
  178.     property PopupMenu;
  179.     property PNGInterLaced : Boolean read FInterlaced write FInterlaced default False;
  180.     property ShowHint;
  181.     property Stretch: Boolean read FStretch write SetStretch default False;
  182.     property TabOrder;
  183.     property TabStop default True;
  184.     property Visible;
  185.   end;
  186.  
  187.  
  188. var
  189.  TPMultiImageCallBack   : TCallBackFunction;
  190.  
  191.  {------------------------------------------------------------------------}
  192.  
  193. implementation
  194.  
  195.   uses   Consts, Clipbrd, Dialogs;
  196.  
  197. {------------------------------------------------------------------------
  198.  TPMultiImage.
  199. ------------------------------------------------------------------------}
  200.  
  201. constructor TPMultiImage.Create(AOwner: TComponent);
  202. begin
  203.   inherited Create(AOwner);
  204.   FPicture := TPicture.Create;
  205.   FPicture.OnChange := PictureChanged;
  206.   FFilename:='';
  207.   FDither:=True;
  208.   FReadResolution := Color256;
  209.   FWriteResolution := Color256;
  210.   FSaveQuality:=25;
  211.   FSaveSmooth:=0;
  212.   FBorderStyle := bsNone;
  213.   FImageLibPalette:=True;
  214.   FInterlaced:=False;
  215.   Picture.Graphic := nil;
  216.   Height := 105;
  217.   Width := 105;
  218.   MsgFont:=TFont.Create;
  219.   BitMsg := TBitmap.Create;
  220.   MessageRunning:=False;
  221.   CMessageRunning:=False;
  222.   SetupMsg30:=Nil;
  223.   SetupCredMsg30:=Nil;
  224.   DelayCounter:=0;
  225.   Color:=clBtnFace;
  226.   CreditBoxList:=TStringList.Create;
  227.   Creditcounter:=0;
  228.   ResProgName:='';
  229.  end;
  230. {------------------------------------------------------------------------}
  231.  
  232. destructor TPMultiImage.Destroy;
  233. begin
  234.   FPicture.Free;
  235.   MsgFont.Free;
  236.   BitMsg.Free;
  237.   CreditBoxList.Free;
  238.   inherited Destroy;
  239. end;
  240. {------------------------------------------------------------------------}
  241.  
  242. function TPMultiImage.GetPalette: HPALETTE;
  243. begin
  244.   Result := 0;
  245.   If ImageLibPalette then Exit;
  246.   If FPicture.Graphic is TBitmap then
  247.     Result := TBitmap(FPicture.Graphic).Palette;
  248. end;
  249. {------------------------------------------------------------------------}
  250.  
  251. procedure TPMultiImage.SetBorderStyle(Value: TBorderStyle);
  252. begin
  253.   If FBorderStyle <> Value then
  254.   begin
  255.     FBorderStyle := Value;
  256.     RecreateWnd;
  257.   end;
  258. end;
  259. {------------------------------------------------------------------------}
  260.  
  261. procedure TPMultiImage.CreateParams(var Params: TCreateParams);
  262. begin
  263.   inherited CreateParams(Params);
  264.   If FBorderStyle = bsSingle then
  265.     Params.Style := Params.Style or WS_BORDER;
  266. end;
  267. {------------------------------------------------------------------------}
  268.  
  269. procedure TPMultiImage.Paint;
  270. var
  271.   W, H: Integer;
  272.   R: TRect;
  273.   S: String[63];
  274.   OldBitmap : HBitmap;
  275.   MemDC : HDC;
  276.   hOldPal : HPalette;
  277. begin
  278.  
  279.   If csDesigning in ComponentState then
  280.     with Canvas do
  281.     begin
  282.       Pen.Style := psDash;
  283.       Brush.Style := bsClear;
  284.       Rectangle(0, 0, Width, Height);
  285.     end;
  286.  
  287.   If (BFileType = 'ICO') or (BFileType = 'WMF') or (not ImageLibPalette) then begin
  288.       PaintTheDelpiWay;
  289.       Exit;
  290.   end;
  291.  
  292.   with Canvas do begin
  293.     Brush.Style := bsSolid;
  294.     Brush.Color := Color;
  295.  
  296.     If Picture.Graphic <> nil then
  297.     If Stretch then begin
  298.  
  299.       hOldPal := SelectPalette(Canvas.handle,Picture.Bitmap.Palette,False);
  300.       RealizePalette(Canvas.handle);
  301.       MemDC := CreateCompatibleDC(Canvas.handle);
  302.       OldBitmap := SelectObject(MemDC,Picture.Bitmap.Handle);
  303.       SetStretchBltMode(canvas.handle,STRETCH_DELETESCANS);
  304.       StretchBlt(Canvas.handle,
  305.                  ClientRect.Left,
  306.                  ClientRect.Top,
  307.                  ClientRect.Right,
  308.                  ClientRect.Bottom,
  309.                  MemDC,
  310.                  ClientRect.Left,
  311.                  ClientRect.Top,
  312.                  Picture.Bitmap.Width,
  313.                  Picture.Bitmap.Height,
  314.                  SrcCopy);
  315.  
  316.       SelectObject(MemDC,OldBitmap);
  317.       DeleteDC(MemDC);
  318.       SelectPalette(Canvas.handle,hOldPal,False);
  319.  
  320.      end else begin
  321.  
  322.       SetRect(R, 0, 0, Picture.Width, Picture.Height);
  323.       If Center then OffsetRect(R, (ClientWidth - Picture.Width) div 2,
  324.           (ClientHeight - Picture.Height) div 2);
  325.  
  326.       hOldPal := SelectPalette(Canvas.handle,Picture.Bitmap.Palette,False);
  327.       RealizePalette(Canvas.handle);
  328.       MemDC := CreateCompatibleDC(Canvas.handle);
  329.       OldBitmap := SelectObject(MemDC,Picture.Bitmap.Handle);
  330.  
  331.       BitBlt(Canvas.handle,
  332.              R.Left,
  333.              R.Top,
  334.              Picture.Bitmap.Width,
  335.              Picture.Bitmap.Height,
  336.              MemDC,
  337.              0,
  338.              0,
  339.              srcCopy);
  340.  
  341.       SelectObject(MemDC,OldBitmap);
  342.       DeleteDC(MemDC);
  343.       SelectPalette(Canvas.handle,hOldPal,False);
  344.     end;
  345.  
  346.     If (GetParentForm(Self).ActiveControl = Self) and
  347.       not (csDesigning in ComponentState) then
  348.     begin
  349.       Brush.Color := clWindowFrame;
  350.       FrameRect(ClientRect);
  351.     end;
  352.  
  353.   end;
  354.   If (MessageRunning) and (Picture = nil) then FreeMsg;
  355.   If (CMessageRunning) and (Picture = nil) then FreeMsg;
  356. end;
  357. {------------------------------------------------------------------------}
  358.  
  359. procedure TPMultiImage.PaintTheDelpiWay;
  360. var
  361.   Dest : TRect;
  362. begin
  363.   If Stretch then
  364.     Dest := ClientRect
  365.   else If Center then
  366.     Dest := Bounds((Width - Picture.Width) div 2, (Height - Picture.Height) div 2,
  367.       Picture.Width, Picture.Height)
  368.   else
  369.     Dest := Rect(0, 0, Picture.Width, Picture.Height);
  370.     Canvas.StretchDraw(Dest, Picture.Graphic);
  371. end;
  372. {------------------------------------------------------------------------}
  373.  
  374.  
  375. procedure TPMultiImage.SetAutoSize(Value: Boolean);
  376. begin
  377.   FAutoSize := Value;
  378.   PictureChanged(Self);
  379. end;
  380. {------------------------------------------------------------------------}
  381.  
  382. procedure TPMultiImage.SetCenter(Value: Boolean);
  383. begin
  384.   If FCenter <> Value then
  385.   begin
  386.     FCenter := Value;
  387.     Invalidate;
  388.   end;
  389. end;
  390. {------------------------------------------------------------------------}
  391.  
  392. procedure TPMultiImage.SetPicture(Value: TPicture);
  393. begin
  394.   FPicture.Assign(Value);
  395. end;
  396. {------------------------------------------------------------------------}
  397.  
  398. procedure TPMultiImage.SetStretch(Value: Boolean);
  399. begin
  400.   If FStretch <> Value then
  401.   begin
  402.     FStretch := Value;
  403.     Invalidate;
  404.   end;
  405. end;
  406. {------------------------------------------------------------------------}
  407.  
  408. procedure TPMultiImage.PictureChanged(Sender: TObject);
  409. begin
  410.   If AutoSize and (Picture.Width > 0) and (Picture.Height > 0) then
  411.     SetBounds(Left, Top, Picture.Width, Picture.Height);
  412.   If (Picture.Graphic is TBitmap) and (Picture.Width = Width) and
  413.     (Picture.Height = Height) then
  414.     ControlStyle := ControlStyle + [csOpaque] else
  415.     ControlStyle := ControlStyle - [csOpaque];
  416.   Invalidate;
  417. end;
  418. {------------------------------------------------------------------------}
  419.  
  420. procedure TPMultiImage.SetReadRes(Res : TResolution);
  421. begin
  422.   FReadResolution := Res;
  423. end;
  424. {------------------------------------------------------------------------}
  425.  
  426. procedure TPMultiImage.SetWriteRes(Res : TResolution);
  427. begin
  428.   FWriteResolution := Res;
  429. end;
  430. {------------------------------------------------------------------------}
  431.  
  432. Procedure TPMultiImage.WriteMultiName(Name : String);
  433. begin
  434.   FFilename:=Name;
  435.   GetMultiBitmap;
  436. end;
  437. {------------------------------------------------------------------------}
  438.  
  439.  
  440. function TPMultiImage.GetMultiBitmap :  String;
  441. var    Bitmap     : TBitmap;
  442.        Pextension : String[4];
  443.        OnExcept   : Boolean;
  444.        F          : file of Byte;
  445.        Dith       : Integer;
  446.        ReadRes    : Integer;
  447.  
  448. label  BreakIt;
  449.  
  450. begin
  451.   OnExcept:=False;
  452.  
  453.   Pextension:=UpperCase(ExtractFileExt(FFilename));
  454.  
  455.   If Pextension <>  '.RES' then
  456.   If not FileExists(FFilename) then begin
  457.      Picture.Graphic := nil;
  458.      Temps:='file not found';
  459.      GetMultiBitmap:=Temps;
  460.      Exit;
  461.   end;
  462.  
  463.   If FReadResolution = Color16 then ReadRes := 4;
  464.   If FReadResolution = Color256 then ReadRes := 8;
  465.   If FReadResolution = ColorTrue then ReadRes := 24;
  466.  
  467.   If FDither then
  468.     Dith:=1
  469.   else
  470.     Dith:=0;
  471.  
  472.  If (Pextension =  '.WMF') or (Pextension =  '.ICO') then begin
  473.     FreeMsg;
  474.     Picture.LoadFromFile(FFilename);
  475.     Temps:='Non JPeg, BMP, GIF, PNG or PCX Image';
  476.     GetMultiBitmap:=Temps;
  477.     GetInfoAndType(FFilename);
  478.     Exit;
  479.   end;
  480.  
  481.  If Pextension = '.SCM' then begin
  482.     try
  483.      FreeMsg;
  484.      LoadMessageFromFile(FFilename);
  485.     except
  486.      Picture.Graphic := nil;
  487.      OnExcept:=True;
  488.     end;
  489.     If OnExcept then Goto BreakIt;
  490.     GetInfoAndType(FFilename);
  491.  end;
  492.  
  493.  If Pextension = '.CMS' then begin
  494.     try
  495.      FreeMsg;
  496.      LoadCreditMessageFromFile(FFilename);
  497.     except
  498.      Picture.Graphic := nil;
  499.      OnExcept:=True;
  500.     end;
  501.     If OnExcept then Goto BreakIt;
  502.     GetInfoAndType(FFilename);
  503.  end;
  504.  
  505.  If csDesigning in ComponentState then
  506.   If (UpperCase(FFilename) = Temps) and (Picture.Bitmap <> nil) then Goto BreakIt;
  507.  
  508.  If Pextension = '.BMP' then begin
  509.    try
  510.      FreeMsg;
  511.      Bitmap := TBitmap.Create;
  512.      If not bmpfile(FFilename, ReadRes, Dith, Bitmap, TPMultiImageCallBack) then
  513.        MessageDlg('Reading bmp file failed', mtInformation, [mbOk], 0);
  514.     except
  515.      Picture.Graphic := nil;
  516.      Bitmap.Free;
  517.      OnExcept:=True;
  518.     end;
  519.      If OnExcept then Goto BreakIt;
  520.      Picture.Graphic:=Bitmap;
  521.      Bitmap.Free;
  522.      GetInfoAndType(FFilename);
  523.  end;
  524.  
  525.  If Pextension = '.RES' then begin
  526.    try
  527.      FreeMsg;
  528.      Bitmap := TBitmap.Create;
  529.      If not resfile(ResProgName, JustName(FFilename), Handle, Bitmap) then
  530.        MessageDlg('Reading resource file failed', mtInformation, [mbOk], 0);
  531.     except
  532.      Picture.Graphic := nil;
  533.      Bitmap.Free;
  534.      OnExcept:=True;
  535.     end;
  536.      If OnExcept then Goto BreakIt;
  537.      Picture.Graphic:=Bitmap;
  538.      Bitmap.Free;
  539.      GetInfoAndType(FFilename);
  540.  end;
  541.  
  542.  If Pextension = '.PNG' then begin
  543.     try
  544.      FreeMsg;
  545.      Bitmap := TBitmap.Create;
  546.      If not pngfile(FFilename, ReadRes, Dith, Bitmap, TPMultiImageCallBack) then
  547.        MessageDlg('Reading png file failed', mtInformation, [mbOk], 0);
  548.     except
  549.      Picture.Graphic := nil;
  550.      Bitmap.Free;
  551.      OnExcept:=True;
  552.     end;
  553.      If OnExcept then Goto BreakIt;
  554.      Picture.Graphic:=Bitmap;
  555.      Bitmap.Free;
  556.      GetInfoAndType(FFilename);
  557.  end;
  558.  
  559.  If Pextension = '.GIF' then begin
  560.     try
  561.      FreeMsg;
  562.      Bitmap := TBitmap.Create;
  563.      If not Giffile(FFilename, ReadRes, Dith, Bitmap, TPMultiImageCallBack) then
  564.        MessageDlg('Reading gif file failed', mtInformation, [mbOk], 0);
  565.     except
  566.      Picture.Graphic := nil;
  567.      Bitmap.Free;
  568.      OnExcept:=True;
  569.     end;
  570.      If OnExcept then Goto BreakIt;
  571.      Picture.Graphic:=Bitmap;
  572.      Bitmap.Free;
  573.      GetInfoAndType(FFilename);
  574.  end;
  575.  
  576.  If Pextension = '.PCX' then begin
  577.     try
  578.      FreeMsg;
  579.      Bitmap := TBitmap.Create;
  580.      If not PCXfile(FFilename, ReadRes, Dith, Bitmap, TPMultiImageCallBack) then
  581.        MessageDlg('Reading pcx file failed', mtInformation, [mbOk], 0);
  582.     except
  583.      Picture.Graphic := nil;
  584.      Bitmap.Free;
  585.      OnExcept:=True;
  586.     end;
  587.      If OnExcept then Goto BreakIt;
  588.      Picture.Graphic:=Bitmap;
  589.      Bitmap.Free;
  590.      GetInfoAndType(FFilename);
  591.  end;
  592.  
  593.  If Pextension = '.JPG' then begin
  594.     try
  595.      FreeMsg;
  596.      Bitmap := TBitmap.Create;
  597.      If not jpgfile(FFilename, ReadRes, Dith, Bitmap, TPMultiImageCallBack) then
  598.        MessageDlg('Reading jpg file failed', mtInformation, [mbOk], 0);
  599.     except
  600.      Picture.Graphic := nil;
  601.      Bitmap.Free;
  602.      OnExcept:=True;
  603.     end;
  604.      If OnExcept then Goto BreakIt;
  605.      Picture.Graphic:=Bitmap;
  606.      Bitmap.Free;
  607.      GetInfoAndType(FFilename);
  608.  end;
  609.  
  610.  BreakIt:
  611.  Temps:=UpperCase(FFilename);
  612.  GetMultiBitmap:=Temps;
  613. end;
  614. {------------------------------------------------------------------------}
  615.  
  616. function TPMultiImage.GetSmooth : Byte;
  617. begin
  618.   GetSmooth:=FSaveSmooth;
  619. end;
  620. {------------------------------------------------------------------------}
  621.  
  622. procedure TPMultiImage.SetSmooth(Smooth : Byte);
  623. begin
  624.   If (Smooth > 100) or (Smooth < 0) then FSaveSmooth:=5 else
  625.    FSaveSmooth:=Smooth;
  626. end;
  627. {------------------------------------------------------------------------}
  628.  
  629. function TPMultiImage.GetQuality : Byte;
  630. begin
  631.   GetQuality:=FSaveQuality;
  632. end;
  633. {------------------------------------------------------------------------}
  634.  
  635. procedure TPMultiImage.SetQuality(Quality : Byte);
  636. begin
  637.   If (Quality > 100) OR (Quality < 1) then FSaveQuality:=25 else
  638.    FSaveQuality:=Quality;
  639. end;
  640. {------------------------------------------------------------------------}
  641.  
  642. function TPMultiImage.GetSaveFilename : TFilename;
  643. begin
  644.   GetSaveFilename:=FSaveFilename;
  645. end;
  646. {------------------------------------------------------------------------}
  647.  
  648. procedure TPMultiImage.SetSaveFilename(fn : TFilename);
  649. begin
  650.  If fn <> '' then
  651.    FSaveFilename:=fn
  652.  else
  653.    FSaveFilename:='';
  654. end;
  655.  
  656.  
  657. {------------------------------------------------------------------------}
  658. procedure TPMultiImage.SaveAsBMP(FN : TFilename);
  659. var
  660.   WriteRes : Integer;
  661. begin
  662.  
  663.   If FWriteResolution = Color16 then WriteRes := 4;
  664.   If FWriteResolution = Color256 then WriteRes := 8;
  665.   If FWriteResolution = ColorTrue then WriteRes := 24;
  666.  
  667.   If fn <> '' then FSaveFilename:=fn;
  668.   try
  669.     If not putbmpfile(FSaveFilename, WriteRes, Picture.Bitmap, TPMultiImageCallBack) then
  670.       MessageDlg('Writing bmp file failed', mtInformation, [mbOk], 0);
  671.   except
  672.  
  673.   end;
  674. end;
  675.  
  676. {------------------------------------------------------------------------}
  677.  
  678. procedure TPMultiImage.SaveAsPNG(FN : TFilename);
  679. var
  680.   WriteRes : Integer;
  681.   InterL   : Byte;
  682. begin
  683.   If FWriteResolution = Color16 then WriteRes := 4;
  684.   If FWriteResolution = Color256 then WriteRes := 8;
  685.   If FWriteResolution = ColorTrue then WriteRes := 24;
  686.   If FInterlaced then InterL :=1 else InterL :=0;
  687.  
  688.   If fn <> '' then FSaveFilename:=fn;
  689.  
  690.   try
  691.     If not putpngfile(FSaveFilename, WriteRes, Interl, Picture.Bitmap, TPMultiImageCallBack) then
  692.       MessageDlg('Writing png file failed', mtInformation, [mbOk], 0);
  693.   except
  694.  
  695.   end;
  696. end;
  697.  
  698. {------------------------------------------------------------------------}
  699.  
  700. procedure TPMultiImage.SaveAsJpg(FN : TFilename);
  701. begin
  702.    If fn <> '' then FSaveFilename:=fn;
  703.   try
  704.    If not putjpgfile(FSaveFilename, FSaveQuality, FSaveSmooth, picture.Bitmap, TPMultiImageCallBack) then
  705.       MessageDlg('Writing jpg file failed', mtInformation, [mbOk], 0);
  706.   except
  707.  
  708.   end;
  709. end;
  710. {------------------------------------------------------------------------}
  711.  
  712. procedure TPMultiImage.SaveAsGIF(FN : TFilename);
  713. var
  714.   WriteRes : Integer;
  715. begin
  716.  
  717.   If FWriteResolution = Color16 then WriteRes := 4;
  718.   If FWriteResolution = Color256 then WriteRes := 8;
  719.   If FWriteResolution = ColorTrue then WriteRes := 24;
  720.  
  721.   If fn <> '' then FSaveFilename:=fn;
  722.   try
  723.     If not putgiffile(FSaveFilename, WriteRes, Picture.Bitmap, TPMultiImageCallBack) then
  724.       MessageDlg('Writing gif file failed', mtInformation, [mbOk], 0);
  725.   except
  726.  
  727.   end;
  728. end;
  729. {------------------------------------------------------------------------}
  730.  
  731. procedure TPMultiImage.SaveAsPCX(FN : TFilename);
  732. var
  733.   WriteRes : Integer;
  734. begin
  735.  
  736.   If FWriteResolution = Color16 then WriteRes := 4;
  737.   If FWriteResolution = Color256 then WriteRes := 8;
  738.   If FWriteResolution = ColorTrue then WriteRes := 24;
  739.  
  740.   If fn <> '' then FSaveFilename:=fn;
  741.   try
  742.    If not putpcxfile(FSaveFilename, WriteRes, Picture.Bitmap, TPMultiImageCallBack) then
  743.       MessageDlg('Writing pcx file failed', mtInformation, [mbOk], 0);
  744.   except
  745.  
  746.   end;
  747. end;
  748. {------------------------------------------------------------------------}
  749.  
  750. function TPMultiImage.GetInfoAndType(Filename : TFilename) : Boolean;
  751. var
  752.   Pextension : string[4];
  753.   f          : file of byte;
  754.   InfoSize   : Integer;
  755.   OldFileMode: Byte;
  756. begin
  757.  Pextension:=UpperCase(ExtractFileExt(Filename));
  758.  
  759.  If (Pextension =  '.RES') then begin
  760.     BFiletype           := 'RES';
  761.     Bwidth              := Picture.width;
  762.     BHeight             := Picture.Height;
  763.     Bbitspixel          := 0;
  764.     Bplanes             := 0;
  765.     Bnumcolors          := 0;
  766.     Bcompression        := 'BMP';
  767.     GetDIBSizes(Picture.BitMap.Handle, InfoSize, Bsize);
  768.     Bsize:=Bsize+InfoSize;
  769.     GetInfoAndType:=True;
  770.     Exit;
  771.   end else
  772.  
  773.  if (Pextension =  '.WMF') or
  774.     (Pextension =  '.ICO') or
  775.     (Pextension =  '.SCM') or
  776.     (Pextension =  '.CMS') then begin
  777.  
  778.    if fileexists(Filename) then begin
  779.     Delete(Pextension,1,1);
  780.     BFiletype           := Pextension;
  781.     Bwidth              := Picture.width;
  782.     BHeight             := Picture.Height;
  783.     Bbitspixel          := 0;
  784.     Bplanes             := 0;
  785.     Bnumcolors          := 0;
  786.     Bcompression        := Pextension;
  787.     OldFileMode:= FileMode;
  788.     FileMode:=0;
  789.     AssignFile(f, FFileName);
  790.     Reset(f);
  791.     Bsize := FileSize(f);
  792.     CloseFile(f);
  793.     FileMode:=OldFileMode;
  794.     GetInfoAndType:=true;
  795.     exit;
  796.    end else
  797.  
  798.    begin
  799.     BFiletype           := 'ERR';
  800.     Bwidth              := -1;
  801.     BHeight             := -1;
  802.     Bbitspixel          := -1;
  803.     Bplanes             := -1;
  804.     Bnumcolors          := -1;
  805.     Bcompression        := 'ERR';
  806.     Bsize               := -1;
  807.     GetInfoAndType      := false;
  808.     exit;
  809.    end;
  810.   end;
  811.  
  812.   GetInfoAndType:=GetFileInfo(filename,
  813.                               BFileType,
  814.                               Bwidth,
  815.                               BHeight,
  816.                               Bbitspixel,
  817.                               Bplanes,
  818.                               Bnumcolors,
  819.                               Bcompression);
  820.  
  821.    OldFileMode:= FileMode;
  822.    FileMode:=0;
  823.    AssignFile(f, FileName);
  824.    Reset(f);
  825.    Bsize := FileSize(f);
  826.    CloseFile(f);
  827.    FileMode:=OldFileMode;
  828.  end;
  829. {------------------------------------------------------------------------
  830.  ClipBoard stuff
  831. ------------------------------------------------------------------------}
  832.  
  833. procedure TPMultiImage.WMCut(var Message: TMessage);
  834. begin
  835.   CutToClipboard;
  836. end;
  837. {------------------------------------------------------------------------}
  838.  
  839. procedure TPMultiImage.WMCopy(var Message: TMessage);
  840. begin
  841.   CopyToClipboard;
  842. end;
  843. {------------------------------------------------------------------------}
  844.  
  845. procedure TPMultiImage.WMPaste(var Message: TMessage);
  846. begin
  847.   PasteFromClipboard;
  848. end;
  849. {------------------------------------------------------------------------}
  850.  
  851. procedure TPMultiImage.CopyToClipboard;
  852. begin
  853.   If Picture.Graphic <> nil then Clipboard.Assign(Picture);
  854. end;
  855. {------------------------------------------------------------------------}
  856.  
  857. procedure TPMultiImage.CutToClipboard;
  858. begin
  859.   If Picture.Graphic <> nil then
  860.   begin
  861.     CopyToClipboard;
  862.     Picture.Graphic := nil;
  863.   end;
  864. end;
  865. {------------------------------------------------------------------------}
  866.  
  867. procedure TPMultiImage.PasteFromClipboard;
  868. begin
  869.   If Clipboard.HasFormat(CF_PICTURE) then begin
  870.     MessageRunning:=False;
  871.     CMessageRunning:=False;
  872.     Picture.Assign(Clipboard);
  873.   end;
  874. end;
  875. {------------------------------------------------------------------------}
  876.  
  877. procedure TPMultiImage.KeyDown(var Key: Word; Shift: TShiftState);
  878. begin
  879.   inherited KeyDown(Key, Shift);
  880.   case Key of
  881.     VK_INSERT:
  882.       If ssShift in Shift then PasteFromClipBoard else
  883.         If ssCtrl in Shift then CopyToClipBoard;
  884.     VK_DELETE:
  885.       If ssShift in Shift then CutToClipBoard;
  886.   end;
  887. end;
  888. {------------------------------------------------------------------------}
  889.  
  890. procedure TPMultiImage.KeyPress(var Key: Char);
  891. begin
  892.   inherited KeyPress(Key);
  893.   case Key of
  894.     ^X: CutToClipBoard;
  895.     ^C: CopyToClipBoard;
  896.     ^V: PasteFromClipBoard;
  897.   end;
  898. end;
  899. {------------------------------------------------------------------------
  900.  scrolling message stuff
  901. ------------------------------------------------------------------------}
  902.  
  903. procedure TPMultiImage.LoadMessageFromFile(MessageName : TFilename);
  904. var
  905.   Msg      : TLabel;
  906. begin
  907.   Picture.Assign(nil);
  908.   ScreenWd:=Width;
  909.   ScreenHt:=Height;
  910.   Msg := TLabel.Create(Self);
  911.   readmessagefromfile(MessageName, MsgFont, MsgSpeed, MsgBkGrnd, MsgText);
  912.   Refresh;
  913.   Msg.Parent :=Self;
  914.   Msg.Visible := False;
  915.   Msg.Font := MsgFont;
  916.   Msg.Caption := MsgText;
  917.   BitWidth:=Msg.Width;
  918.   SMessageLeft := ScreenWd;
  919.   SMessageRight := ScreenWd + Msg.Width;
  920.   SMessageTop := (ScreenHt - Msg.Height) Div 2;
  921.   BitMsg.Width := Msg.Width;
  922.   BitMsg.Height := Msg.Height;
  923.   OldColor:=Color;
  924.   Color:=MsgBkGrnd;
  925.  
  926.   with BitMsg.Canvas do begin
  927.     Brush.Color := MsgBkGrnd;
  928.     Font := Msg.Font;
  929.     TextOut(0,0,Msg.Caption);
  930.   end;
  931.  
  932.    Msg.Free;
  933.    Msg := nil;
  934.    MessageRunning:=True;
  935. end;
  936. {------------------------------------------------------------------------}
  937.  
  938.  
  939. procedure TPMultiImage.NewMessage;
  940. var
  941.   Msg      : TLabel;
  942. begin
  943.   FreeMsg;
  944.   If MsgText = '' then Exit;
  945.   If MsgText[Length(MsgText)] <> ' ' then MsgText:=MsgText+' ';
  946.   ScreenWd:=Width;
  947.   ScreenHt:=Height;
  948.   Msg := TLabel.Create(Self);
  949.   Refresh;
  950.   Msg.Parent :=Self;
  951.   Msg.Visible := False;
  952.   Msg.Font := MsgFont;
  953.   Msg.Caption := MsgText;
  954.   BitWidth:=Msg.Width;
  955.   SMessageLeft := ScreenWd;
  956.   SMessageRight := ScreenWd + Msg.Width;
  957.   SMessageTop := (ScreenHt - Msg.Height) Div 2;
  958.   BitMsg.Width := Msg.Width;
  959.   BitMsg.Height := Msg.Height;
  960.   OldColor:=Color;
  961.   Color:=MsgBkGrnd;
  962.  
  963.   with Canvas do begin
  964.     Brush.Style := bsSolid;
  965.     Brush.Color:=MsgBkGrnd;
  966.     Rectangle(0, 0, Width, Height);
  967.   end;
  968.  
  969.   with BitMsg.Canvas do begin
  970.     Brush.Color := MsgBkGrnd;
  971.     Font := Msg.Font;
  972.     TextOut(0,0,Msg.Caption);
  973.   end;
  974.  
  975.    Msg.Free;
  976.    Msg := nil;
  977.    MessageRunning:=True;
  978. end;
  979. {------------------------------------------------------------------------}
  980.  
  981. procedure TPMultiImage.SaveCurrentMessage(MessageName : TFilename);
  982. begin
  983.   WriteMessageToFile(MessageName, MsgFont, MsgSpeed, MsgBkGrnd, MsgText);
  984. end;
  985. {------------------------------------------------------------------------}
  986.  
  987. procedure TPMultiImage.CreateMessage(MessagePath : String; AutoLoad : Boolean);
  988. var
  989.  SaveDlg : TSaveDialog;
  990.  MsName  : TFilename;
  991. begin
  992.  SetupMsg30:=TSetupMsg30.Create(Self);
  993.  SetupMsg30.ShowModal;
  994.  MsName:='';
  995.  If SetupMsg30.ModalResult = mrOK then begin
  996.    SaveDlg :=TSaveDialog.Create(self);
  997.    SaveDlg.DefaultExt:='scm';
  998.    SaveDlg.Filter:='scrollmessage|*.scm';
  999.    SaveDlg.Options:=[ofOverwritePrompt];
  1000.    SaveDlg.InitialDir:=MessagePath;
  1001.    If SaveDlg.Execute then begin
  1002.     MsName:=SaveDlg.Filename;
  1003.     WriteMessageToFile(MsName,
  1004.                        SetupMsg30.MessageFont,
  1005.                        SetupMsg30.MessageSpeed,
  1006.                        SetupMsg30.MessageColor,
  1007.                        SetupMsg30.MessageMsg);
  1008.     If (AutoLoad) and (MsName <> '')  then
  1009.       LoadMessageFromFile(MsName)
  1010.     else
  1011.       NewMessage;
  1012.  
  1013.    end;
  1014.    SaveDlg.free;
  1015.  end;
  1016.  SetupMsg30.destroy;
  1017.  SetupMsg30:=Nil;
  1018. end;
  1019. {------------------------------------------------------------------------}
  1020.  
  1021. Procedure TPMultiImage.FreeMsg;
  1022. Begin
  1023.   If MessageRunning then
  1024.    Color:=OldColor;
  1025.   If CMessageRunning then
  1026.    Color:=OldColor;
  1027.   CMessageRunning:=False;
  1028.   MessageRunning:=False;
  1029.   Picture.Assign(nil);
  1030. end;
  1031. {------------------------------------------------------------------------}
  1032.  
  1033. Function TPMultiImage.Delay(Ms : Integer) : boolean;
  1034. Begin
  1035.  Inc(DelayCounter);
  1036.  If DelayCounter > MS then begin
  1037.     DelayCounter:=0;
  1038.     Result:=True;
  1039.  end else
  1040.   Result:=False;
  1041. end;
  1042. {------------------------------------------------------------------------}
  1043.  
  1044. Procedure TPMultiImage.MoveMsg(Var WinMsg : TMessage);
  1045. Begin
  1046.   If Not MessageRunning then Exit;
  1047.   If not Delay(MsgSpeed) then Exit;
  1048.   Dec(SMessageLeft,1);
  1049.   Dec(SMessageRight,1);
  1050.   If SMessageRight < 0 then begin
  1051.     SMessageLeft := ScreenWd;
  1052.     SMessageRight := SMessageLeft + BitWidth;
  1053.   end;
  1054.     with Canvas do
  1055.        Draw(SMessageLeft,SMessageTop,BitMsg);
  1056. end;
  1057. {------------------------------------------------------------------------}
  1058.  
  1059. Procedure TPMultiImage.Trigger;
  1060. Begin
  1061.   PostMessage(Handle, WM_Trigger, 0, 0);
  1062.   PostMessage(Handle, WM_CTrigger, 0, 0);
  1063.   If visible then begin
  1064.    If SetupMsg30 <> nil then SetupMsg30.Trigger;
  1065.    If SetupCredMsg30 <> nil then SetupCredMsg30.Trigger;
  1066.   end;
  1067. End;
  1068. {------------------------------------------------------------------------
  1069.  credit message stuff
  1070. ------------------------------------------------------------------------}
  1071.  
  1072. procedure TPMultiImage.LoadCreditMessageFromFile(MessageName : TFilename);
  1073. var
  1074.   Msg      : TLabel;
  1075. begin
  1076.   Picture.Assign(nil);
  1077.   ReadCreditFromFile(MessageName, MsgFont, MsgSpeed, MsgBkGrnd, CreditBoxList);
  1078.   Creditcounter:=0;
  1079.   If CreditBoxList.Count <1 then Exit;
  1080.   MsgText:=CreditBoxList.Strings[Creditcounter];
  1081.  
  1082.   If MsgText = '' then Exit;
  1083.   If MsgText[1] <> ' ' then MsgText:='  ' + MsgText;
  1084.   If MsgText[Length(MsgText)] <> ' ' then MsgText:=MsgText+' ';
  1085.  
  1086.   ScreenWd:=Width;
  1087.   ScreenHt:=Height;
  1088.   Refresh;
  1089.   Msg := TLabel.Create(Self);
  1090.   Refresh;
  1091.   Msg.Parent :=Self;
  1092.   Msg.Visible := False;
  1093.   Msg.Font := MsgFont;
  1094.   Msg.Caption := MsgText;
  1095.   Msg.Width:=Msg.Width+(Msg.Width div (Length(MsgText)-2));
  1096.   BitHeight:=Msg.Height;
  1097.   BitWidth:=Msg.Width;
  1098.   SMessageLeft :=(ScreenWd - Msg.Width) Div 2;
  1099.   SMessageTop := ScreenHt;
  1100.   SMessageBottom := SMessageTop + Msg.Height;
  1101.  
  1102.   BitMsg.Width := Msg.Width;
  1103.   BitMsg.Height := Msg.Height+5;
  1104.   OldColor:=Color;
  1105.   Color:=MsgBkGrnd;
  1106.  
  1107.   with Canvas do begin
  1108.     Brush.Style := bsSolid;
  1109.     Brush.Color:=MsgBkGrnd;
  1110.     Rectangle(0, 0, Width, Height);
  1111.   end;
  1112.  
  1113.   with BitMsg.Canvas do begin
  1114.     Brush.Color := MsgBkGrnd;
  1115.     Pen.Color:=MsgBkGrnd;
  1116.     Rectangle(0, 0, BitMsg.Width, BitMsg.Height);
  1117.     Font := Msg.Font;
  1118.     TextOut(0,0,Msg.Caption);
  1119.   end;
  1120.  
  1121.    Msg.Free;
  1122.    Msg := nil;
  1123.    CMessageRunning:=True;
  1124. end;
  1125. {------------------------------------------------------------------------}
  1126.  
  1127. procedure TPMultiImage.NewCreditMessage;
  1128. var
  1129.   Msg      : TLabel;
  1130. begin
  1131.   If CreditBoxList.Count <1 then Exit;
  1132.   If Creditcounter > CreditBoxList.Count then Creditcounter:=0;
  1133.  
  1134.   MsgText:=CreditBoxList.Strings[Creditcounter];
  1135.   If MsgText = '' then Exit;
  1136.  
  1137.   If MsgText[1] <> ' ' then MsgText:='  ' + MsgText;
  1138.   If MsgText[Length(MsgText)] <> ' ' then MsgText:=MsgText+' ';
  1139.  
  1140.   ScreenWd:=Width;
  1141.   ScreenHt:=Height;
  1142.   Msg := TLabel.Create(Self);
  1143.   Refresh;
  1144.   Msg.Parent :=Self;
  1145.   Msg.Visible := False;
  1146.   Msg.Font := MsgFont;
  1147.   Msg.Caption := MsgText;
  1148.   BitHeight:=Msg.Height;
  1149.   Msg.Width:=Msg.Width+(Msg.Width div (Length(MsgText)-2));
  1150.   BitWidth:=Msg.Width;
  1151.   SMessageLeft :=(ScreenWd - Msg.Width) Div 2;
  1152.   SMessageTop := ScreenHt;
  1153.   SMessageBottom := SMessageTop + Msg.Height;
  1154.   BitMsg.Width := Msg.Width;
  1155.   BitMsg.Height := Msg.Height+5;
  1156.   if not CMessageRunning then
  1157.    OldColor:=Color;
  1158.   Color:=MsgBkGrnd;
  1159.  
  1160.   with Canvas do begin
  1161.     Brush.Style := bsSolid;
  1162.     Brush.Color:=MsgBkGrnd;
  1163.     Rectangle(0, 0, Width, Height);
  1164.   end;
  1165.  
  1166.   with BitMsg.Canvas do begin
  1167.     Brush.Color := MsgBkGrnd;
  1168.     Pen.Color:=MsgBkGrnd;
  1169.     Rectangle(0, 0, BitMsg.Width, BitMsg.Height);
  1170.     Font := Msg.Font;
  1171.     TextOut(0,0,Msg.Caption);
  1172.   end;
  1173.  
  1174.    Msg.Free;
  1175.    Msg := nil;
  1176.    CMessageRunning:=True;
  1177. end;
  1178. {------------------------------------------------------------------------}
  1179.  
  1180. procedure TPMultiImage.SaveCurrentCreditMessage(MessageName : TFilename);
  1181. begin
  1182.   WriteCreditToFile(MessageName, MsgFont, MsgSpeed, MsgBkGrnd, CreditBoxList);
  1183. end;
  1184. {------------------------------------------------------------------------}
  1185.  
  1186. procedure TPMultiImage.CreateCreditMessage(MessagePath : String; AutoLoad : Boolean);
  1187. var
  1188.  SaveDlg : TSaveDialog;
  1189.  MsName  : TFilename;
  1190. begin
  1191.  MsName:='';
  1192.  SetupCredMsg30:=TSetupCredMsg30.Create(Self);
  1193.  SetupCredMsg30.ShowModal;
  1194.  If SetupCredMsg30.ModalResult = mrOK then begin
  1195.    SaveDlg :=TSaveDialog.Create(self);
  1196.    SaveDlg.DefaultExt:='cms';
  1197.    SaveDlg.Filter:='credit message|*.cms';
  1198.    SaveDlg.Options:=[ofOverwritePrompt];
  1199.    SaveDlg.InitialDir:=MessagePath;
  1200.    If SaveDlg.Execute then begin
  1201.     MsName:=SaveDlg.Filename;
  1202.     WriteCreditToFile(MsName,
  1203.                       SetupCredMsg30.MessageFont,
  1204.                       SetupCredMsg30.MessageSpeed,
  1205.                       SetupCredMsg30.MessageColor,
  1206.                       SetupCredMsg30.MessageStrList);
  1207.  
  1208.     If (AutoLoad) and (MsName <> '')  then
  1209.       LoadCreditMessageFromFile(MsName)
  1210.     else
  1211.       NewCreditMessage;
  1212.  
  1213.    end;
  1214.    SaveDlg.free;
  1215.  end;
  1216.  
  1217.  SetupCredMsg30.free;
  1218.  SetupCredMsg30:=Nil;
  1219.  Creditcounter:=0;
  1220. end;
  1221. {------------------------------------------------------------------------}
  1222.  
  1223. Procedure TPMultiImage.MoveCredMsg(Var WinMsg : TMessage);
  1224. Begin
  1225.   If Not CMessageRunning then Exit;
  1226.   If not Delay(MsgSpeed) then Exit;
  1227.   Dec(SMessageTop,1);
  1228.   Dec(SMessageBottom,1);
  1229.   If SMessageTop < (0-BitHeight)-5 then begin
  1230.      If CreditBoxList.Count >0 then begin
  1231.         If Creditcounter < CreditBoxList.Count-1 then
  1232.            Inc(Creditcounter)
  1233.         else Creditcounter:=0;
  1234.         NewCreditMessage;
  1235.      end else begin
  1236.          SMessageTop := ScreenHt;
  1237.          SMessageBottom := SMessageTop + BitHeight;
  1238.      end;
  1239.   end;
  1240.  
  1241.   with Canvas do Draw(SMessageLeft,SMessageTop,BitMsg);
  1242. end;
  1243.  
  1244. {------------------------------------------------------------------------
  1245. Printing Stuff
  1246. ------------------------------------------------------------------------}
  1247.  
  1248. procedure TPMultiImage.PrintMultiImage(X, Y, pWidth, pHeight: Integer);
  1249. begin
  1250.  If Picture.Graphic.Empty then Exit;
  1251.  
  1252.  If (BFiletype = 'ICO') or (BFiletype = 'WMF') then
  1253.    PrintICOWMF(X, Y, pWidth, pHeight)
  1254.  else
  1255.    PrintBitmap(X, Y, pWidth, pHeight)
  1256. end;
  1257. {---------------------------------------------------------------------}
  1258.  
  1259. procedure TPMultiImage.PrintBitmap(X, Y, pWidth, pHeight: Integer);
  1260. var
  1261.   Info     : PBitmapInfo;
  1262.   InfoSize : Integer;
  1263.   Image    : Pointer;
  1264.   ImageSize: Longint;
  1265. begin
  1266.    If (pWidth < 1) or (pHeight < 1) then begin
  1267.       pWidth:=Picture.Bitmap.Width;
  1268.       pHeight:=Picture.Bitmap.Height;
  1269.    end;
  1270.  
  1271.    Printer.Begindoc;
  1272.  
  1273.     with Picture.Bitmap do begin
  1274.       GetDIBSizes(Handle, InfoSize, ImageSize);
  1275.       Info := MemAlloc(InfoSize);
  1276.       try
  1277.         Image := MemAlloc(ImageSize);
  1278.         try
  1279.           GetDIB(Handle, Palette, Info^, Image^);
  1280.           with Info^.bmiHeader do
  1281.            StretchDIBits(Printer.Canvas.Handle, X, Y, pWidth,
  1282.             pHeight, 0, 0, biWidth, biHeight, Image, Info^,
  1283.             DIB_RGB_COLORS, SRCCOPY)
  1284.          finally
  1285.           FreeMem(Image, ImageSize);
  1286.          end;
  1287.       finally
  1288.        FreeMem(Info, InfoSize);
  1289.       end;
  1290.     end;
  1291.     Printer.Enddoc;
  1292.   end;
  1293. {---------------------------------------------------------------------}
  1294.  
  1295. procedure TPMultiImage.PrintICOWMF(X, Y, pWidth, pHeight: Integer);
  1296. begin
  1297.  If (pWidth < 1) or (pHeight < 1) then begin
  1298.     pWidth:=Picture.Graphic.Width;
  1299.     pHeight:=Picture.Graphic.Height;
  1300.  end;
  1301.  Printer.Begindoc;
  1302.  Printer.Canvas.StretchDraw(Rect(X, Y, pWidth, pHeight), Picture.Graphic);
  1303.  Printer.Enddoc;
  1304. end;
  1305. {------------------------------------------------------------------------
  1306. end TPMultiImage
  1307. ------------------------------------------------------------------------}
  1308.  
  1309.  
  1310. begin
  1311.  TPMultiImageCallBack:=nil;
  1312. end.
  1313.  
  1314.  
  1315.