home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 1997 May / Pcwk0597.iso / delphi / imagelib / tdmultip.pa_ / tdmultip.pa
Text File  |  1995-09-29  |  125KB  |  4,039 lines
  1. {$X+,I+,R-}   {<<<<  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. Professional Edition
  8.  
  9. With thanks to Andy Satori for his Visual Component advise. Andy can
  10. be reached on CIS [71221,2010] or http://TheClassifieds.Com
  11.  
  12. No part of this Unit may be copied in any way. However, you may derive
  13. other objects from TDBMultiImage, TDBMultiMedia
  14.  
  15. Part of Imagelib VCL/DLL Library.Uses ImageLib 2.2.1 Changed the callback to a
  16. function instead of a procedure to let the user cancel out.
  17.  
  18. Bug fixes:
  19.  
  20. Changed callback in version 2.21 to a function with cdecl.
  21. using the C calling convention.
  22.  
  23. Version 2.2.2 Added property ImageLibPalette which If set to True will
  24. use the ImageLib Way to paint. If False it will paint the Delphi way.
  25. This is a fix of a Stretchdraw Delphi bug which doesn't paint correctly
  26. 256 color palettes on 256 color Video cards
  27.  
  28. property TempMov
  29. property TempAVI
  30. property TempWAV
  31. property TempMID
  32. property TempRMI
  33.  
  34. MultiMedia blobs (AVI, MOV, WAV, MID, RMI are written to a file first
  35. and than that file is being played. This can cause a problem when you
  36. have two TDBMultiMedia objects on your forum both using the same Temp file
  37. (A seldom something). Incase that could happen in your app you need to
  38. assign to both TDBMultiMedia ojects different Temp Filenames. DON'T change
  39. the extension since the delphi multimedia player is extension sensitive}
  40.  
  41.  
  42. unit TDMultiP;      {To be used with version 3.0 of imagelib vcl}
  43.  
  44. interface
  45.  
  46. uses Setcr30, Setsr30, SysUtils, WinTypes, WinProcs, Messages,
  47.      Classes, Graphics, Forms, Controls, Extctrls, StdCtrls, DLL30,
  48.      Menus, DB, DBTables, Mask, Buttons, MPlayer, Printers;
  49.  
  50.  
  51. {TPDBMultiImage}
  52. Type
  53.   TPDBMultiImage = class(TCustomControl)
  54.   private
  55.     FDataLink           :  TFieldDataLink;
  56.     FPicture            :  TPicture;
  57.     FBorderStyle        :  TBorderStyle;
  58.     FAutoDisplay        :  Boolean;
  59.     FStretch            :  Boolean;
  60.     FCenter             :  Boolean;
  61.     FPictureLoaded      :  Boolean;
  62.     FUpdateAsJPG        :  Boolean;
  63.     FUpdateAsBMP        :  Boolean;
  64.     FUpdateAsGIF        :  Boolean;
  65.     FUpdateAsPCX        :  Boolean;
  66.     FUpdateAsPNG        :  Boolean;
  67.     FReserved           :  Byte;
  68.     FDither             :  Boolean;
  69.     FReadResolution     :  TResolution;
  70.     FWriteResolution    :  TResolution;
  71.     FInterlaced         :  Boolean;
  72.     FSaveQuality        :  Byte;
  73.     FSaveSmooth         :  Byte;
  74.     FColor              :  TColor;
  75.     FImageLibPalette    :  Boolean;
  76.     {scrolling message stuff}
  77.     BitMsg              :  TBitmap;
  78.     SMessageLeft        :  Integer;
  79.     SMessageRight       :  Integer;
  80.     SMessageTop         :  Integer;
  81.     ScreenWd            :  Integer;
  82.     ScreenHt            :  Integer;
  83.     BitWidth            :  Integer;
  84.     MessageRunning      :  Boolean;
  85.     CMessageRunning     :  Boolean;
  86.     DelayCounter        :  Longint;
  87.     OldColor            :  TColor;
  88.     MmsgCount           :  Integer;
  89.     {Credit message stuff}
  90.     SMessageBottom      : Integer;
  91.     BitHeight           : Integer;
  92.     Creditcounter       : Integer;
  93.     procedure DataChange(Sender: TObject);
  94.     function GetDataField: String;
  95.     function GetDataSource: TDataSource;
  96.     function GetField: TField;
  97.     function GetReadOnly: Boolean;
  98.     procedure PictureChanged(Sender: TObject);
  99.     procedure SetAutoDisplay(Value: Boolean);
  100.     procedure SetBorderStyle(Value: TBorderStyle);
  101.     procedure SetCenter(Value: Boolean);
  102.     procedure SetDataField(const Value: String);
  103.     procedure SetDataSource(Value: TDataSource);
  104.     procedure SetPicture(Value: TPicture);
  105.     procedure SetReadOnly(Value: Boolean);
  106.     procedure SetStretch(Value: Boolean);
  107.     procedure UpdateData(Sender: TObject);
  108.     procedure SetUpdateAsJPG(Value: Boolean);
  109.     procedure SetUpdateAsBMP(Value: Boolean);
  110.     procedure SetUpdateAsGIF(Value: Boolean);
  111.     procedure SetUpdateAsPCX(Value: Boolean);
  112.     procedure SetUpdateAsPNG(Value: Boolean);
  113.     procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
  114.     procedure CMExit(var Message: TCMExit); message CM_Exit;
  115.     procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
  116.     procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
  117.     procedure WMCut(var Message: TMessage); message WM_CUT;
  118.     procedure WMCopy(var Message: TMessage); message WM_COPY;
  119.     procedure WMPaste(var Message: TMessage); message WM_PASTE;
  120.     procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
  121.   protected
  122.     procedure CreateParams(var Params: TCreateParams); override;
  123.     function GetPalette: HPALETTE; override;
  124.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  125.     procedure KeyPress(var Key: Char); override;
  126.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  127.     procedure Paint; override;
  128.     procedure PaintTheDelpiWay;
  129.     function GetSmooth : Byte;
  130.     procedure SetSmooth(smooth : Byte);
  131.     function GetQuality : Byte;
  132.     procedure SetQuality(Quality : Byte);
  133.     procedure SetReadRes(Res : TResolution);
  134.     procedure SetWriteRes(Res : TResolution);
  135.     procedure PrintICOWMF(X, Y, pWidth, pHeight: Integer);
  136.     procedure PrintBitmap(X, Y, pWidth, pHeight: Integer);
  137.     procedure LoadMessageFromStream(MessageStream : TStream);
  138.     Procedure MoveMsg(Var WinMsg : TMessage); message WM_Trigger;
  139.     Function Delay(Ms : Integer) : boolean;
  140.     Function SaveMessageToStream(MFont  : Tfont;
  141.                                   Mspeed : Integer;
  142.                                   MColor : Tcolor;
  143.                                   MMsg   : String) : Boolean;
  144.     Procedure MoveCredMsg(Var WinMsg : TMessage); message WM_CTrigger;
  145.     procedure LoadCreditMessageFromStream(MessageStream : TStream);
  146.     Function SaveCreditMessageToStream(MFont  : Tfont;
  147.                                        Mspeed : integer;
  148.                                        MColor : Tcolor;
  149.                                        MMsg   : TStringList) : Boolean;
  150.   public
  151.     BFiletype           :  String;
  152.     Bwidth              :  Integer;
  153.     BHeight             :  Integer;
  154.     Bbitspixel          :  Integer;
  155.     Bplanes             :  Integer;
  156.     Bnumcolors          :  Integer;
  157.     BSize               :  Longint;
  158.     Bcompression        :  String;
  159.     {scrolling message stuff}
  160.     MsgText             :  String;
  161.     MsgFont             :  TFont;
  162.     MsgBkGrnd           :  TColor;
  163.     MsgSpeed            :  Integer;
  164.     {credit message}
  165.     CreditBoxList       :  TStringList;
  166.     constructor Create(AOwner: TComponent); override;
  167.     destructor Destroy; override;
  168.     procedure CopyToClipboard;
  169.     procedure CutToClipboard;
  170.     procedure LoadPicture;
  171.     procedure PasteFromClipboard;
  172.     procedure LoadFromFile(Filename : TFilename);
  173.     procedure SaveToFile(Filename : TFilename);
  174.     procedure SaveToFileAsGIF(Filename : TFilename);
  175.     procedure SaveToFileAsPCX(Filename : TFilename);
  176.     procedure SaveToFileAsPNG(Filename : TFilename);
  177.     procedure SaveToFileAsBMP(Filename : TFilename);
  178.     procedure SaveToFileAsJPG(Filename : TFilename);
  179.     function GetInfoAndType : String;
  180.     property Field: TField read GetField;
  181.     property Picture: TPicture read FPicture write SetPicture;
  182.     Procedure Trigger;
  183.     Function CreateMessage : Boolean;
  184.     procedure NewMessage;
  185.     Procedure FreeMsg;
  186.     {credit message}
  187.     Function CreateCreditMessage : Boolean;
  188.     procedure NewCreditMessage;
  189.     procedure PrintMultiImage(X, Y, pWidth, pHeight: Integer);
  190.   published
  191.     property ImageReadRes : TResolution read FReadResolution write SetReadRes;
  192.     property ImageWriteRes : TResolution read FWriteResolution write SetWriteRes;
  193.     property JPegSaveQuality : Byte read GetQuality write SetQuality;
  194.     property JPegSaveSmooth : Byte read GetSmooth write SetSmooth;
  195.     property PNGInterLaced : Boolean read FInterlaced write FInterlaced default False;
  196.     property ImageDither : Boolean read FDither write FDither;
  197.     property UpdateAsJPG : Boolean read FUpdateAsJPG write SetUpdateAsJPG;
  198.     property UpdateAsBMP : Boolean read FUpdateAsBMP write SetUpdateAsBMP;
  199.     property UpdateAsGIF : Boolean read FUpdateAsGIF write SetUpdateAsGIF;
  200.     property UpdateAsPCX : Boolean read FUpdateAsPCX write SetUpdateAsPCX;
  201.     property UpdateAsPNG : Boolean read FUpdateAsPNG write SetUpdateAsPNG;
  202.     property AutoDisplay: Boolean read FAutoDisplay write SetAutoDisplay default True;
  203.     property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
  204.     property Center: Boolean read FCenter write SetCenter default True;
  205.     property Color;
  206.     property Align;
  207.     property Ctl3D;
  208.     property DataField: String read GetDataField write SetDataField;
  209.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  210.     property DragCursor;
  211.     property DragMode;
  212.     property Enabled;
  213.     property Font;
  214.     property ImageLibPalette : Boolean read FImageLibPalette write FImageLibPalette default True;
  215.     property ParentColor default False;
  216.     property ParentCtl3D;
  217.     property ParentFont;
  218.     property ParentShowHint;
  219.     property PopupMenu;
  220.     property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
  221.     property ShowHint;
  222.     property Stretch: Boolean read FStretch write SetStretch default False;
  223.     property TabOrder;
  224.     property TabStop default True;
  225.     property Visible;
  226.     property OnClick;
  227.     property OnDblClick;
  228.     property OnDragDrop;
  229.     property OnDragOver;
  230.     property OnEndDrag;
  231.     property OnEnter;
  232.     property OnExit;
  233.     property OnKeyDown;
  234.     property OnKeyPress;
  235.     property OnKeyUp;
  236.     property OnMouseDown;
  237.     property OnMouseMove;
  238.     property OnMouseUp;
  239.   end;
  240.  
  241. {TDBMediaPlayer}
  242. Type
  243.   TPDBMediaPlayer = class(TMediaPlayer)
  244.   {Just incase you/we want to add some stuff in the
  245.    future we derived a seperate object.}
  246. end;
  247.  
  248.  
  249. {TPDBMultiMedia }
  250. Type
  251.   TPDBMultiMedia = class(TCustomControl)
  252.   private
  253.     FDataLink           :  TFieldDataLink;
  254.     FPicture            :  TPicture;
  255.     FBorderStyle        :  TBorderStyle;
  256.     FAutoDisplay        :  Boolean;
  257.     FStretch            :  Boolean;
  258.     FCenter             :  Boolean;
  259.     FPictureLoaded      :  Boolean;
  260.     FUpdateAsJPG        :  Boolean;
  261.     FUpdateAsBMP        :  Boolean;
  262.     FUpdateAsGIF        :  Boolean;
  263.     FUpdateAsPCX        :  Boolean;
  264.     FUpdateAsPNG        :  Boolean;
  265.     FAutoPlayMM         :  Boolean;
  266.     FAutoMMHide         :  Boolean;
  267.     FAutoRePlayMM       :  Boolean;
  268.     FReserved           :  Byte;
  269.     FDither             :  Boolean;
  270.     FReadResolution     :  TResolution;
  271.     FWriteResolution    :  TResolution;
  272.     FInterlaced         :  Boolean;
  273.     FSaveQuality        :  Byte;
  274.     FSaveSmooth         :  Byte;
  275.     FMediaPlayer        :  TPDBMediaPlayer;
  276.     FMOVTempFile        :  String;
  277.     FMPGTempFile        :  String;
  278.     FAVITempFile        :  String;
  279.     FWAVTempFile        :  String;
  280.     FMIDTempFile        :  String;
  281.     FRMITempFile        :  String;
  282.     FTempFilePath       :  String;
  283.     FImageLibPalette    :  Boolean;
  284.     {scrolling message stuff}
  285.     BitMsg              :  TBitmap;
  286.     SMessageLeft        :  Integer;
  287.     SMessageRight       :  Integer;
  288.     SMessageTop         :  Integer;
  289.     ScreenWd            :  Integer;
  290.     ScreenHt            :  Integer;
  291.     BitWidth            :  Integer;
  292.     MessageRunning      :  Boolean;
  293.     CMessageRunning     :  Boolean;
  294.     DelayCounter        :  Longint;
  295.     OldColor            :  TColor;
  296.     MmsgCount           :  Integer;
  297.     {Credit message stuff}
  298.     SMessageBottom      : Integer;
  299.     BitHeight           : Integer;
  300.     Creditcounter       : Integer;
  301.     procedure DataChange(Sender: TObject);
  302.     function GetDataField: String;
  303.     function GetDataSource: TDataSource;
  304.     function GetMediaPlayer: TPDBMediaPlayer;
  305.     function GetField: TField;
  306.     function GetReadOnly: Boolean;
  307.     procedure PictureChanged(Sender: TObject);
  308.     procedure SetAutoDisplay(Value: Boolean);
  309.     procedure SetBorderStyle(Value: TBorderStyle);
  310.     procedure SetCenter(Value: Boolean);
  311.     procedure SetDataField(const Value: String);
  312.     procedure SetDataSource(Value: TDataSource);
  313.     procedure SetMediaPlayer(Value: TPDBMediaPlayer);
  314.     procedure SetPicture(Value: TPicture);
  315.     procedure SetReadOnly(Value: Boolean);
  316.     procedure SetStretch(Value: Boolean);
  317.     procedure UpdateData(Sender: TObject);
  318.     procedure SetUpdateAsJPG(Value: Boolean);
  319.     procedure SetUpdateAsBMP(Value: Boolean);
  320.     procedure SetUpdateAsGIF(Value: Boolean);
  321.     procedure SetUpdateAsPCX(Value: Boolean);
  322.     procedure SetUpdateAsPNG(Value: Boolean);
  323.     procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
  324.     procedure CMExit(var Message: TCMExit); message CM_Exit;
  325.     procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
  326.     procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
  327.     procedure WMCut(var Message: TMessage); message WM_CUT;
  328.     procedure WMCopy(var Message: TMessage); message WM_COPY;
  329.     procedure WMPaste(var Message: TMessage); message WM_PASTE;
  330.     procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
  331.   protected
  332.     procedure CreateParams(var Params: TCreateParams); override;
  333.     function GetPalette: HPALETTE; override;
  334.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  335.     procedure KeyPress(var Key: Char); override;
  336.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  337.     procedure Paint; override;
  338.     procedure PaintTheDelpiWay;
  339.     function GetSmooth : Byte;
  340.     procedure SetSmooth(smooth : Byte);
  341.     function GetQuality : Byte;
  342.     procedure SetQuality(Quality : Byte);
  343.     procedure SetReadRes(Res : TResolution);
  344.     procedure SetWriteRes(Res : TResolution);
  345.     function GetTempPath : String;
  346.     procedure SetTempPath(Temppath : String);
  347.     function AddBackSlash(DirName : String) : String;
  348.     Procedure CleanUpMultiMedia;
  349.     function IsValidMultiMedia(Name : PChar) : boolean;
  350.     procedure TimerNotify(var Message: TMessage); message WM_TIMER;
  351.     procedure PrintICOWMF(X, Y, pWidth, pHeight: Integer);
  352.     procedure PrintBitmap(X, Y, pWidth, pHeight: Integer);
  353.     procedure LoadMessageFromStream(MessageStream : TStream);
  354.     Procedure MoveMsg(Var WinMsg : TMessage); message WM_Trigger;
  355.     Function Delay(Ms : Integer) : boolean;
  356.     Function SaveMessageToStream(MFont  : Tfont;
  357.                                  Mspeed : Integer;
  358.                                  MColor : Tcolor;
  359.                                  MMsg   : String) : Boolean;
  360.     Procedure MoveCredMsg(Var WinMsg : TMessage); message WM_CTrigger;
  361.     procedure LoadCreditMessageFromStream(MessageStream : TStream);
  362.     Function SaveCreditMessageToStream(MFont  : Tfont;
  363.                                        Mspeed : integer;
  364.                                        MColor : Tcolor;
  365.                                        MMsg   : TStringList) : Boolean;
  366.    public
  367.     BFiletype           :  String;
  368.     Bwidth              :  Integer;
  369.     BHeight             :  Integer;
  370.     Bbitspixel          :  Integer;
  371.     Bplanes             :  Integer;
  372.     Bnumcolors          :  Integer;
  373.     BSize               :  Longint;
  374.     Bcompression        :  String;
  375.     {scrolling message stuff}
  376.     MsgText             :  String;
  377.     MsgFont             :  TFont;
  378.     MsgBkGrnd           :  TColor;
  379.     MsgSpeed            :  Integer;
  380.     {credit message}
  381.     CreditBoxList       :  TStringList;
  382.     constructor Create(AOwner: TComponent); override;
  383.     destructor Destroy; override;
  384.     procedure CopyToClipboard;
  385.     procedure CutToClipboard;
  386.     procedure LoadMedia;
  387.     procedure PasteFromClipboard;
  388.     procedure LoadFromFile(Filename : TFilename);
  389.     procedure SaveToFile(Filename : TFilename);
  390.     procedure SaveToFileAsGIF(Filename : TFilename);
  391.     procedure SaveToFileAsPCX(Filename : TFilename);
  392.     procedure SaveToFileAsPNG(Filename : TFilename);
  393.     procedure SaveToFileAsBMP(Filename : TFilename);
  394.     procedure SaveToFileAsJPG(Filename : TFilename);
  395.     function GetInfoAndType : String;
  396.     function GetMultiMediaExtensions : String;
  397.     property Field: TField read GetField;
  398.     property Picture: TPicture read FPicture write SetPicture;
  399.     Procedure Trigger;
  400.     Function CreateMessage : Boolean;
  401.     procedure NewMessage;
  402.     Procedure FreeMsg;
  403.     Procedure ScrollErrorMessage(ErString : String);
  404.     {credit message}
  405.     Function CreateCreditMessage : Boolean;
  406.     procedure NewCreditMessage;
  407.     procedure PrintMultiImage(X, Y, pWidth, pHeight: Integer);
  408.   published
  409.     property ImageReadRes : TResolution read FReadResolution write SetReadRes;
  410.     property ImageWriteRes : TResolution read FWriteResolution write SetWriteRes;
  411.     property ImageDither : Boolean read FDither write FDither;
  412.     property PNGInterLaced : Boolean read FInterlaced write FInterlaced default False;
  413.     property JPegSaveQuality : Byte read GetQuality write SetQuality;
  414.     property JPegSaveSmooth : Byte read GetSmooth write SetSmooth;
  415.     property UpdateAsJPG : Boolean read FUpdateAsJPG write SetUpdateAsJPG;
  416.     property UpdateAsBMP : Boolean read FUpdateAsBMP write SetUpdateAsBMP;
  417.     property UpdateAsGIF : Boolean read FUpdateAsGIF write SetUpdateAsGIF;
  418.     property UpdateAsPCX : Boolean read FUpdateAsPCX write SetUpdateAsPCX;
  419.     property UpdateAsPNG : Boolean read FUpdateAsPNG write SetUpdateAsPNG;
  420.     property AutoPlayMultiMedia : Boolean read FAutoPlayMM write FAutoPlayMM;
  421.     property AutoRePlayMultiMedia : Boolean read FAutoRePlayMM write FAutoRePlayMM;
  422.     property AutoHideMediaPlayer : Boolean read FAutoMMHide write FAutoMMHide;
  423.     property PathForTempFile : String read GetTempPath write SetTempPath;
  424.     property Align;
  425.     property AutoDisplay: Boolean read FAutoDisplay write SetAutoDisplay default True;
  426.     property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
  427.     property Center: Boolean read FCenter write SetCenter default True;
  428.     property Color;
  429.     property Ctl3D;
  430.     property DataField: String read GetDataField write SetDataField;
  431.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  432.     property MediaPlayer: TPDBMediaPlayer read GetMediaPlayer write SetmediaPlayer;
  433.     property DragCursor;
  434.     property DragMode;
  435.     property Enabled;
  436.     property Font;
  437.     property ImageLibPalette : Boolean read FImageLibPalette write FImageLibPalette default True;
  438.     property ParentColor default False;
  439.     property ParentCtl3D;
  440.     property ParentFont;
  441.     property ParentShowHint;
  442.     property PopupMenu;
  443.     property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
  444.     property ShowHint;
  445.     property Stretch: Boolean read FStretch write SetStretch default False;
  446.     property TabOrder;
  447.     property TabStop default True;
  448.     property TempMov : String Read FMOVTempFile write FMOVTempFile;
  449.     property TempAVI : String Read FAVITempFile write FAVITempFile;
  450.     property TempWAV : String Read FWAVTempFile write FWAVTempFile;
  451.     property TempMID : String Read FMIDTempFile write FMIDTempFile;
  452.     property TempRMI : String Read FRMITempFile write FRMITempFile;
  453.     property Visible;
  454.     property OnClick;
  455.     property OnDblClick;
  456.     property OnDragDrop;
  457.     property OnDragOver;
  458.     property OnEndDrag;
  459.     property OnEnter;
  460.     property OnExit;
  461.     property OnKeyDown;
  462.     property OnKeyPress;
  463.     property OnKeyUp;
  464.     property OnMouseDown;
  465.     property OnMouseMove;
  466.     property OnMouseUp;
  467.   end;
  468.  
  469.  
  470. var
  471.  TPDBMultiImageCallBack : TCallBackFunction;
  472.  TPDBMultiMediaCallBack : TCallBackFunction;
  473.  
  474. {------------------------------------------------------------------------}
  475. implementation
  476. uses Consts, DBIErrs, DBITypes, Clipbrd, DBConsts, Dialogs;
  477.  
  478. {------------------------------------------------------------------------}
  479.  
  480. {TPDBMultiImage}
  481. constructor TPDBMultiImage.Create(AOwner: TComponent);
  482. begin
  483.   inherited Create(AOwner);
  484.   ControlStyle := ControlStyle + [csFramed, csOpaque];
  485.   Width := 105;
  486.   Height := 105;
  487.   TabStop := True;
  488.   ParentColor := False;
  489.   FPicture := TPicture.Create;
  490.   FPicture.OnChange := PictureChanged;
  491.   FBorderStyle := bsSingle;
  492.   FAutoDisplay := True;
  493.   FImageLibPalette:=True;
  494.   FCenter := True;
  495.   FUpdateAsJPG := True;
  496.   FDither:=True;
  497.   FReadResolution := Color256;
  498.   FWriteResolution := Color256;
  499.   FSaveQuality:=25;
  500.   FSaveSmooth:=0;
  501.   FDataLink := TFieldDataLink.Create;
  502.   FDataLink.Control := Self;
  503.   FDataLink.OnDataChange := DataChange;
  504.   FDataLink.OnUpdateData := UpdateData;
  505.   MsgFont:=TFont.Create;
  506.   BitMsg := TBitmap.Create;
  507.   MessageRunning:=False;
  508.   CMessageRunning:=False;
  509.   SetupMsg30:=Nil;
  510.   SetupCredMsg30:=Nil;
  511.   CreditBoxList:=TStringList.Create;
  512.   Creditcounter:=0;
  513.   DelayCounter:=0;
  514.   Color:=clWindow;
  515. end;
  516. {------------------------------------------------------------------------}
  517.  
  518. destructor TPDBMultiImage.Destroy;
  519. begin
  520.   FPicture.Free;
  521.   FDataLink.Free;
  522.   MsgFont.Free;
  523.   BitMsg.Free;
  524.   FDataLink := nil;
  525.   CreditBoxList.Free;
  526.   inherited Destroy;
  527. end;
  528. {------------------------------------------------------------------------}
  529.  
  530. function TPDBMultiImage.GetDataSource: TDataSource;
  531. begin
  532.   Result := FDataLink.DataSource;
  533. end;
  534. {------------------------------------------------------------------------}
  535.  
  536. procedure TPDBMultiImage.SetDataSource(Value: TDataSource);
  537. begin
  538.   FDataLink.DataSource := Value;
  539. end;
  540. {------------------------------------------------------------------------}
  541.  
  542. function TPDBMultiImage.GetDataField: String;
  543. begin
  544.   Result := FDataLink.FieldName;
  545. end;
  546. {------------------------------------------------------------------------}
  547.  
  548. procedure TPDBMultiImage.SetDataField(const Value: String);
  549. begin
  550.   FDataLink.FieldName := Value;
  551. end;
  552. {------------------------------------------------------------------------}
  553.  
  554. function TPDBMultiImage.GetReadOnly: Boolean;
  555. begin
  556.   Result := FDataLink.ReadOnly;
  557. end;
  558. {------------------------------------------------------------------------}
  559.  
  560. procedure TPDBMultiImage.SetReadOnly(Value: Boolean);
  561. begin
  562.   FDataLink.ReadOnly := Value;
  563. end;
  564. {------------------------------------------------------------------------}
  565.  
  566. function TPDBMultiImage.GetField: TField;
  567. begin
  568.   Result := FDataLink.Field;
  569. end;
  570. {------------------------------------------------------------------------}
  571.  
  572. function TPDBMultiImage.GetPalette: HPALETTE;
  573. begin
  574.   Result := 0;
  575.   If ImageLibPalette then Exit;
  576.   If FPicture.Graphic is TBitmap then
  577.     Result := TBitmap(FPicture.Graphic).Palette;
  578. end;
  579. {------------------------------------------------------------------------}
  580.  
  581. procedure TPDBMultiImage.SetAutoDisplay(Value: Boolean);
  582. begin
  583.   If FAutoDisplay <> Value then
  584.   begin
  585.     FAutoDisplay := Value;
  586.     If Value then LoadPicture;
  587.   end;
  588. end;
  589. {------------------------------------------------------------------------}
  590.  
  591. procedure TPDBMultiImage.SetBorderStyle(Value: TBorderStyle);
  592. begin
  593.   If FBorderStyle <> Value then
  594.   begin
  595.     FBorderStyle := Value;
  596.     RecreateWnd;
  597.   end;
  598. end;
  599. {------------------------------------------------------------------------}
  600.  
  601. procedure TPDBMultiImage.SetCenter(Value: Boolean);
  602. begin
  603.   If FCenter <> Value then
  604.   begin
  605.     FCenter := Value;
  606.     Invalidate;
  607.   end;
  608. end;
  609. {------------------------------------------------------------------------}
  610.  
  611. procedure TPDBMultiImage.SetPicture(Value: TPicture);
  612. begin
  613.   FPicture.Assign(Value);
  614. end;
  615. {------------------------------------------------------------------------}
  616.  
  617. procedure TPDBMultiImage.SetStretch(Value: Boolean);
  618. begin
  619.   If FStretch <> Value then
  620.   begin
  621.     FStretch := Value;
  622.     Invalidate;
  623.   end;
  624. end;
  625. {------------------------------------------------------------------------}
  626.  
  627. procedure TPDBMultiImage.Paint;
  628. var
  629.   W, H        : Integer;
  630.   R           : TRect;
  631.   S           : String[63];
  632.   OldBitmap   : HBitmap;
  633.   MemDC       : HDC;
  634.   hOldPal     : HPalette;
  635. begin
  636.  
  637.   If (BFileType = 'ICO') or (BFileType = 'WMF') or (not ImageLibPalette) then begin
  638.       PaintTheDelpiWay;
  639.       Exit;
  640.   end;
  641.  
  642.   with Canvas do begin
  643.     Brush.Style := bsSolid;
  644.     Brush.Color := Color;
  645.  
  646.     If FPictureLoaded then begin
  647.       If (Stretch) and (Picture.Graphic <> nil) then
  648.  
  649.         If Picture.Graphic.Empty then
  650.           FillRect(ClientRect) else
  651.          begin
  652.  
  653.             hOldPal := SelectPalette(Canvas.handle,Picture.Bitmap.Palette,False);
  654.             RealizePalette(Canvas.handle);
  655.  
  656.             MemDC := CreateCompatibleDC(Canvas.handle);
  657.             OldBitmap := SelectObject(MemDC,Picture.Bitmap.Handle);
  658.  
  659.             SetStretchBltMode(Canvas.handle,STRETCH_DELETESCANS);
  660.  
  661.             StretchBlt(Canvas.handle,
  662.                        ClientRect.Left,
  663.                        ClientRect.Top,
  664.                        ClientRect.Right,
  665.                        ClientRect.Bottom,
  666.                        MemDC,
  667.                        ClientRect.Left,
  668.                        ClientRect.Top,
  669.                        Picture.Bitmap.Width,
  670.                        Picture.Bitmap.Height,
  671.                        srcCopy);
  672.  
  673.              SelectObject(MemDC,OldBitmap);
  674.              DeleteDC(MemDC);
  675.              SelectPalette(Canvas.handle,hOldPal,False);
  676.       end else begin
  677.  
  678.         SetRect(R, 0, 0, Picture.Width, Picture.Height);
  679.         If Center then OffsetRect(R, (ClientWidth - Picture.Width) div 2,
  680.           (ClientHeight - Picture.Height) div 2);
  681.  
  682.            hOldPal := SelectPalette(Canvas.handle,Picture.Bitmap.Palette,False);
  683.            RealizePalette(Canvas.handle);
  684.  
  685.            MemDC := CreateCompatibleDC(Canvas.handle);
  686.            OldBitmap := SelectObject(MemDC,Picture.Bitmap.Handle);
  687.  
  688.             BitBlt(Canvas.handle,
  689.                        R.Left,
  690.                        R.Top,
  691.                        Picture.Bitmap.Width,
  692.                        Picture.Bitmap.Height,
  693.                        MemDC,
  694.                        0,
  695.                        0,
  696.                        srcCopy);
  697.  
  698.              SelectObject(MemDC,OldBitmap);
  699.              DeleteDC(MemDC);
  700.              SelectPalette(Canvas.handle,hOldPal,False);
  701.  
  702.              ExcludeClipRect(Handle, R.Left, R.Top, R.Right, R.Bottom);
  703.              FillRect(ClientRect);
  704.              SelectClipRgn(Handle, 0);
  705.           end;
  706.     end else begin
  707.      Font := Self.Font;
  708.      If FDataLink.Field <> nil then
  709.         S := FDataLink.Field.DisplayLabel
  710.      else
  711.         S := Name;
  712.       S := '(' + S + ')';
  713.       W := TextWidth(S);
  714.       H := TextHeight(S);
  715.       R := ClientRect;
  716.       TextRect(R, (R.Right - W) div 2, (R.Bottom - H) div 2, S);
  717.     end;
  718.  
  719.     If (GetParentForm(Self).ActiveControl = Self) and
  720.       not (csDesigning in ComponentState) then begin
  721.         Brush.Color := clWindowFrame;
  722.         FrameRect(ClientRect);
  723.     end;
  724.  
  725.   end;
  726.  
  727.   If (CMessageRunning) and (Picture = nil) then FreeMsg;
  728.   If (MessageRunning) and (Picture = nil) then FreeMsg;
  729. end;
  730. {------------------------------------------------------------------------}
  731.  
  732. procedure TPDBMultiImage.PaintTheDelpiWay;
  733. var
  734.   W, H: Integer;
  735.   R: TRect;
  736.   S: String[63];
  737. begin
  738.   with Canvas do
  739.   begin
  740.     Brush.Style := bsSolid;
  741.     Brush.Color := Color;
  742.     If FPictureLoaded then
  743.     begin
  744.       If (Stretch) and (Picture.Graphic <> nil) then
  745.         If Picture.Graphic.Empty then
  746.           FillRect(ClientRect) else
  747.           StretchDraw(ClientRect, Picture.Graphic)
  748.       else
  749.       begin
  750.         SetRect(R, 0, 0, Picture.Width, Picture.Height);
  751.         If Center then OffsetRect(R, (ClientWidth - Picture.Width) div 2,
  752.           (ClientHeight - Picture.Height) div 2);
  753.         StretchDraw(R, Picture.Graphic);
  754.         ExcludeClipRect(Handle, R.Left, R.Top, R.Right, R.Bottom);
  755.         FillRect(ClientRect);
  756.         SelectClipRgn(Handle, 0);
  757.       end;
  758.     end else
  759.     begin
  760.       Font := Self.Font;
  761.       If FDataLink.Field <> nil then
  762.         S := FDataLink.Field.DisplayLabel else
  763.         S := Name;
  764.       S := '(' + S + ')';
  765.       W := TextWidth(S);
  766.       H := TextHeight(S);
  767.       R := ClientRect;
  768.       TextRect(R, (R.Right - W) div 2, (R.Bottom - H) div 2, S);
  769.     end;
  770.     If (GetParentForm(Self).ActiveControl = Self) and
  771.       not (csDesigning in ComponentState) then
  772.     begin
  773.       Brush.Color := clWindowFrame;
  774.       FrameRect(ClientRect);
  775.     end;
  776.   end;
  777.  
  778.   If (CMessageRunning) and (Picture = nil) then FreeMsg;
  779.   If (MessageRunning) and (Picture = nil) then FreeMsg;
  780. end;
  781. {------------------------------------------------------------------------}
  782.  
  783. procedure TPDBMultiImage.PictureChanged(Sender: TObject);
  784. begin
  785.   FDataLink.Modified;
  786.   FPictureLoaded := True;
  787.   Invalidate;
  788. end;
  789. {------------------------------------------------------------------------}
  790.  
  791. procedure TPDBMultiImage.Notification(AComponent: TComponent;
  792.   Operation: TOperation);
  793. begin
  794.   inherited Notification(AComponent, Operation);
  795.   If (Operation = opRemove) and (FDataLink <> nil) and
  796.     (AComponent = DataSource) then DataSource := nil;
  797. end;
  798. {------------------------------------------------------------------------}
  799.  
  800. procedure TPDBMultiImage.LoadPicture;
  801. var
  802.    Stream       :  TMemoryStream;
  803.    Bitmap       :  TBitmap;
  804.    Cursor       :  hCursor;
  805.    Temp         :  String;
  806.    Dith         :  Integer;
  807.    ReadRes      :  Integer;
  808.  
  809. begin
  810.   If not FPictureLoaded and (FDataLink.Field is TBlobField) then begin
  811.  
  812.   If TBlobField(FDataLink.Field).IsNull then Exit;
  813.  
  814.   If FReadResolution = Color16 then ReadRes := 4;
  815.   If FReadResolution = Color256 then ReadRes := 8;
  816.   If FReadResolution = ColorTrue then ReadRes := 24;
  817.  
  818.   If FDither then
  819.     Dith:=1
  820.   else
  821.     Dith:=0;
  822.  
  823.    Temp:=GetInfoAndType;
  824.  
  825.    If Temp = 'SCM' then begin
  826.       Stream:=TMemoryStream.Create;
  827.       try
  828.         Cursor := SetCursor(LoadCursor(0,idc_Wait));
  829.          FreeMsg;
  830.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  831.          LoadMessageFromStream(Stream);
  832.          If @TPDBMultiImageCallBack <> nil then
  833.            TPDBMultiImageCallBack(0);
  834.        finally
  835.          SetCursor(Cursor);
  836.          Stream.Free;
  837.        end;
  838.    end else
  839.  
  840.    If Temp = 'CMS' then begin
  841.       Stream:=TMemoryStream.Create;
  842.       try
  843.         Cursor := SetCursor(LoadCursor(0,idc_Wait));
  844.          FreeMsg;
  845.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  846.          LoadCreditMessageFromStream(Stream);
  847.          If @TPDBMultiImageCallBack <> nil then
  848.            TPDBMultiImageCallBack(0);
  849.        finally
  850.          SetCursor(Cursor);
  851.          Stream.Free;
  852.        end;
  853.    end else
  854.  
  855.    If Temp = 'PNG' then begin
  856.       Stream:=TMemoryStream.Create;
  857.       Bitmap:=TBitmap.Create;
  858.       try
  859.          FreeMsg;
  860.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  861.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  862.          If not PNGblob(Stream.Memory,Stream.Size, ReadRes, Dith, Bitmap, TPDBMultiImageCallBack) then begin
  863.             MessageDlg('Invallid or empty PNG blobfield', mtInformation, [mbOk], 0);
  864.             Picture.Assign(Nil);
  865.          end else
  866.             Picture.Assign(Bitmap);
  867.          finally
  868.             SetCursor(Cursor);
  869.             Bitmap.free;
  870.             Stream.Free;
  871.          end;
  872.    end else
  873.  
  874.    If Temp = 'GIF' then begin
  875.       Stream:=TMemoryStream.Create;
  876.       Bitmap:=TBitmap.Create;
  877.       try
  878.          FreeMsg;
  879.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  880.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  881.          If not GIFblob(Stream.Memory,Stream.Size, ReadRes, Dith, Bitmap, TPDBMultiImageCallBack) then begin
  882.             MessageDlg('Invallid or empty GIF blobfield', mtInformation, [mbOk], 0);
  883.             Picture.Assign(Nil);
  884.          end else
  885.             Picture.Assign(Bitmap);
  886.          finally
  887.             SetCursor(Cursor);
  888.             Bitmap.free;
  889.             Stream.Free;
  890.          end;
  891.    end else
  892.  
  893.    If Temp = 'PCX' then begin
  894.       Stream:=TMemoryStream.Create;
  895.       Bitmap:=TBitmap.Create;
  896.       try
  897.          FreeMsg;
  898.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  899.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  900.          If not PCXblob(Stream.Memory,Stream.Size, ReadRes, Dith, Bitmap, TPDBMultiImageCallBack) then begin
  901.             MessageDlg('Invallid or empty PCX blobfield', mtInformation, [mbOk], 0);
  902.             Picture.Assign(Nil);
  903.          end else
  904.             Picture.Assign(Bitmap);
  905.          finally
  906.           SetCursor(Cursor);
  907.           Bitmap.free;
  908.           Stream.Free;
  909.          end;
  910.    end else
  911.  
  912.    If Temp = 'BMP' then begin
  913.       Stream:=TMemoryStream.Create;
  914.       Bitmap:=TBitmap.Create;
  915.       try
  916.          FreeMsg;
  917.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  918.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  919.          If not BMPblob(Stream.Memory,Stream.Size, ReadRes, Dith, Bitmap, TPDBMultiImageCallBack) then begin
  920.             MessageDlg('Invallid or empty BMP blobfield', mtInformation, [mbOk], 0);
  921.             Picture.Assign(Nil);
  922.          end else
  923.             Picture.Assign(Bitmap);
  924.          finally
  925.           SetCursor(Cursor);
  926.           Bitmap.free;
  927.           Stream.Free;
  928.          end;
  929.    end else
  930.  
  931.    If Temp = 'JPG' then begin
  932.       Stream:=TMemoryStream.Create;
  933.       Bitmap:=TBitmap.Create;
  934.       try
  935.          FreeMsg;
  936.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  937.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  938.          If not JPGblob(Stream.Memory,Stream.Size, ReadRes, Dith, Bitmap, TPDBMultiImageCallBack) then begin
  939.             MessageDlg('Invallid or empty Jpeg Blobfield', mtInformation, [mbOk], 0);
  940.             Picture.Assign(Nil);
  941.          end else
  942.              Picture.Assign(Bitmap);
  943.          finally
  944.              SetCursor(Cursor);
  945.              Bitmap.free;
  946.              Stream.Free;
  947.          end;
  948.     end;
  949.     GetInfoAndType;
  950.  end;
  951. end;
  952. {------------------------------------------------------------------------}
  953.  
  954. procedure TPDBMultiImage.DataChange(Sender: TObject);
  955. begin
  956.   If CMessageRunning then FreeMsg;
  957.   If MessageRunning then FreeMsg;
  958.   Picture.Graphic := nil;
  959.   FPictureLoaded := False;
  960.   If FAutoDisplay then LoadPicture;
  961. end;
  962. {------------------------------------------------------------------------}
  963.  
  964. procedure TPDBMultiImage.SetUpdateAsJPG(Value: Boolean);
  965. begin
  966.     FUpdateAsJPG:=True;
  967.     FUpdateAsBMP:=False;
  968.     FUpdateAsGIF:=False;
  969.     FUpdateAsPCX:=False;
  970.     FUpdateAsPNG:=False;
  971. end;
  972. {------------------------------------------------------------------------}
  973.  
  974. procedure TPDBMultiImage.SetUpdateAsGIF(Value: Boolean);
  975. begin
  976.     FUpdateAsJPG:=False;
  977.     FUpdateAsBMP:=False;
  978.     FUpdateAsGIF:=True;
  979.     FUpdateAsPCX:=False;
  980.     FUpdateAsPNG:=False;
  981. end;
  982. {------------------------------------------------------------------------}
  983.  
  984. procedure TPDBMultiImage.SetUpdateAsPCX(Value: Boolean);
  985. begin
  986.     FUpdateAsJPG:=False;
  987.     FUpdateAsBMP:=False;
  988.     FUpdateAsGIF:=False;
  989.     FUpdateAsPCX:=True;
  990.     FUpdateAsPNG:=False;
  991. end;
  992. {------------------------------------------------------------------------}
  993.  
  994. procedure TPDBMultiImage.SetUpdateAsBMP(Value: Boolean);
  995. begin
  996.     FUpdateAsJPG:=False;
  997.     FUpdateAsBMP:=True;
  998.     FUpdateAsGIF:=False;
  999.     FUpdateAsPCX:=False;
  1000.     FUpdateAsPNG:=False;
  1001. end;
  1002. {------------------------------------------------------------------------}
  1003.  
  1004. procedure TPDBMultiImage.SetUpdateAsPNG(Value: Boolean);
  1005. begin
  1006.     FUpdateAsJPG:=False;
  1007.     FUpdateAsBMP:=False;
  1008.     FUpdateAsGIF:=False;
  1009.     FUpdateAsPCX:=False;
  1010.     FUpdateAsPNG:=True;
  1011. end;
  1012. {------------------------------------------------------------------------}
  1013.  
  1014. procedure TPDBMultiImage.UpdateData(Sender: TObject);
  1015. var
  1016.    Stream       :  TMemoryStream;
  1017.    Cursor       :  hCursor;
  1018.    Usize        :  Longint;
  1019.    x,y          :  Longint;
  1020.    p            :  Pointer;
  1021.    WriteRes     :  Integer;
  1022.    InterL       :  Byte;
  1023. begin
  1024.   If FDataLink.Field is TBlobField then begin
  1025.  
  1026.     If Picture.Graphic is TBitmap then begin
  1027.       x:=Picture.Bitmap.Width;
  1028.       y:=Picture.Bitmap.Height;
  1029.  
  1030.       y:=y+(y div 5);
  1031.       x:=x+(x div 5);
  1032.  
  1033.       Usize:=(y * x);
  1034.  
  1035.       If Usize < 90000 then Usize:=Usize*2;
  1036.  
  1037.       {Since we can't know how much memory we need to allocate
  1038.       to write the picture to the stream we need to guess it. This
  1039.       is done using the width and height of the Bitmap. After the call
  1040.       to the dll using PUTJPGBLOB or PUTBMPBLOB Usize contains the
  1041.       correct size of the Bitmap stored in P^. You can increase or decrease
  1042.       the guessed memory by altering the Div by. For instance
  1043.  
  1044.       y:=y+(y div 3);
  1045.       x:=x+(x div 3);
  1046.  
  1047.       will allocate more memory then
  1048.  
  1049.       y:=y+(y div 6);
  1050.       x:=x+(x div 6);
  1051.  
  1052.       We played it on the save side. Use this "guess work" very carefully}
  1053.  
  1054.  
  1055.       P := GlobalAllocPtr(HeapAllocFlags, Usize);
  1056.  
  1057.       If P = Nil then
  1058.         Exit;
  1059.  
  1060.       If FWriteResolution = Color16 then WriteRes := 4;
  1061.       If FWriteResolution = Color256 then WriteRes := 8;
  1062.       If FWriteResolution = ColorTrue then WriteRes := 24;
  1063.  
  1064.       If FInterlaced then InterL :=1 else InterL :=0;
  1065.  
  1066.       If FUpdateAsJPG then
  1067.          If not putJPGblob(P, USize, FSaveQuality, FSaveSmooth, Picture.Bitmap, TPDBMultiImageCallBack) then
  1068.            MessageDlg('Jpeg BLOB Write Error', mtInformation, [mbOk], 0);
  1069.  
  1070.       If FUpdateAsBMP then
  1071.          If not putBMPblob(P, USize, WriteRes, Picture.Bitmap, TPDBMultiImageCallBack) then
  1072.            MessageDlg('BMP BLOB Write Error', mtInformation, [mbOk], 0);
  1073.  
  1074.       If FUpdateAsPCX then
  1075.          If not putPCXblob(P, USize, WriteRes, Picture.Bitmap, TPDBMultiImageCallBack) then
  1076.            MessageDlg('PCX BLOB Write Error', mtInformation, [mbOk], 0);
  1077.  
  1078.       If FUpdateAsGIF then
  1079.          If not putGIFblob(P, USize, WriteRes, Picture.Bitmap, TPDBMultiImageCallBack) then
  1080.            MessageDlg('GIF BLOB Write Error', mtInformation, [mbOk], 0);
  1081.  
  1082.       If FUpdateAsPNG then
  1083.          If not putPNGblob(P, USize, WriteRes, InterL, Picture.Bitmap, TPDBMultiImageCallBack) then
  1084.            MessageDlg('PNG BLOB Write Error', mtInformation, [mbOk], 0);
  1085.  
  1086.  
  1087.       Stream:=TMemoryStream.Create;
  1088.       Stream.Write(P^,USize);
  1089.       GlobalFreePtr(P);
  1090.  
  1091.       try
  1092.         TBlobField(FDataLink.Field).LoadFromStream(Stream);
  1093.       finally
  1094.         Stream.Free;
  1095.       end;
  1096.  
  1097.     end else
  1098.       TBlobField(FDataLink.Field).Clear;
  1099.    end;
  1100.    GetInfoAndType;
  1101. end;
  1102. {------------------------------------------------------------------------}
  1103.  
  1104. procedure TPDBMultiImage.CopyToClipboard;
  1105. begin
  1106.   If Picture.Graphic <> nil then Clipboard.Assign(Picture);
  1107. end;
  1108. {------------------------------------------------------------------------}
  1109.  
  1110. procedure TPDBMultiImage.CutToClipboard;
  1111. begin
  1112.   If Picture.Graphic <> nil then
  1113.   begin
  1114.     CopyToClipboard;
  1115.     If FDataLink.Edit then
  1116.       Picture.Graphic := nil;
  1117.   end;
  1118. end;
  1119. {------------------------------------------------------------------------}
  1120.  
  1121. procedure TPDBMultiImage.PasteFromClipboard;
  1122. begin
  1123.   If Clipboard.HasFormat(CF_PICTURE) and FDataLink.Edit then begin
  1124.     CMessageRunning:=False;
  1125.     MessageRunning:=False;
  1126.     Picture.Assign(Clipboard);
  1127.    end;
  1128. end;
  1129. {------------------------------------------------------------------------}
  1130.  
  1131. procedure TPDBMultiImage.CreateParams(var Params: TCreateParams);
  1132. begin
  1133.   inherited CreateParams(Params);
  1134.   If FBorderStyle = bsSingle then
  1135.     Params.Style := Params.Style or WS_BORDER;
  1136. end;
  1137. {------------------------------------------------------------------------}
  1138.  
  1139. procedure TPDBMultiImage.KeyDown(var Key: Word; Shift: TShiftState);
  1140. begin
  1141.   inherited KeyDown(Key, Shift);
  1142.   case Key of
  1143.     VK_INSERT:
  1144.       If ssShift in Shift then PasteFromClipBoard else
  1145.         If ssCtrl in Shift then CopyToClipBoard;
  1146.     VK_DELETE:
  1147.       If ssShift in Shift then CutToClipBoard;
  1148.   end;
  1149. end;
  1150. {------------------------------------------------------------------------}
  1151.  
  1152. procedure TPDBMultiImage.KeyPress(var Key: Char);
  1153. begin
  1154.   inherited KeyPress(Key);
  1155.   case Key of
  1156.     ^X: CutToClipBoard;
  1157.     ^C: CopyToClipBoard;
  1158.     ^V: PasteFromClipBoard;
  1159.     #13: LoadPicture;
  1160.     #27: FDataLink.Reset;
  1161.   end;
  1162. end;
  1163. {------------------------------------------------------------------------}
  1164.  
  1165. procedure TPDBMultiImage.CMEnter(var Message: TCMEnter);
  1166. begin
  1167.   Invalidate; { Draw the focus marker }
  1168.   inherited;
  1169. end;
  1170. {------------------------------------------------------------------------}
  1171.  
  1172. procedure TPDBMultiImage.CMExit(var Message: TCMExit);
  1173. begin
  1174.   Invalidate; { Erase the focus marker }
  1175.   inherited;
  1176. end;
  1177. {------------------------------------------------------------------------}
  1178.  
  1179. procedure TPDBMultiImage.CMTextChanged(var Message: TMessage);
  1180. begin
  1181.   inherited;
  1182.   If not FPictureLoaded then Invalidate;
  1183. end;
  1184. {------------------------------------------------------------------------}
  1185.  
  1186. procedure TPDBMultiImage.WMLButtonDown(var Message: TWMLButtonDown);
  1187. begin
  1188.   If TabStop and CanFocus then SetFocus;
  1189.   inherited;
  1190. end;
  1191. {------------------------------------------------------------------------}
  1192.  
  1193. procedure TPDBMultiImage.WMLButtonDblClk(var Message: TWMLButtonDblClk);
  1194. begin
  1195.   LoadPicture;
  1196.   inherited;
  1197. end;
  1198. {------------------------------------------------------------------------}
  1199.  
  1200. procedure TPDBMultiImage.WMCut(var Message: TMessage);
  1201. begin
  1202.   CutToClipboard;
  1203. end;
  1204. {------------------------------------------------------------------------}
  1205.  
  1206. procedure TPDBMultiImage.WMCopy(var Message: TMessage);
  1207. begin
  1208.   CopyToClipboard;
  1209. end;
  1210. {------------------------------------------------------------------------}
  1211.  
  1212. procedure TPDBMultiImage.WMPaste(var Message: TMessage);
  1213. begin
  1214.   PasteFromClipboard;
  1215. end;
  1216. {------------------------------------------------------------------------}
  1217.  
  1218. procedure TPDBMultiImage.LoadFromFile(Filename : TFilename);
  1219. var
  1220.    Cursor       :  hCursor;
  1221. begin
  1222.   If not FileExists(Filename) then begin
  1223.     MessageDlg('File not found', mtInformation, [mbOk], 0);
  1224.     Exit;
  1225.   end;
  1226.  
  1227.   If UpperCase(ExtractFileExt(Filename)) <> '.JPG' then
  1228.   If UpperCase(ExtractFileExt(Filename)) <> '.GIF' then
  1229.   If UpperCase(ExtractFileExt(Filename)) <> '.PCX' then
  1230.   If UpperCase(ExtractFileExt(Filename)) <> '.BMP' then
  1231.   If UpperCase(ExtractFileExt(Filename)) <> '.PNG' then
  1232.   If UpperCase(ExtractFileExt(Filename)) <> '.SCM' then
  1233.   If UpperCase(ExtractFileExt(Filename)) <> '.CMS' then
  1234.   begin
  1235.     MessageDlg('Not a Jpeg, GIF, PCX, SCM, PNG, CMS or BMP File', mtInformation, [mbOk], 0);
  1236.     Exit;
  1237.   end;
  1238.  
  1239.   If FDataLink.Field is TBlobField then begin
  1240.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1241.     TBlobField(FDataLink.Field).LoadFromFile(Filename);
  1242.     SetCursor(Cursor);
  1243.   end else begin
  1244.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  1245.     Exit;
  1246.   end;
  1247.   GetInfoAndType;
  1248. end;
  1249. {------------------------------------------------------------------------}
  1250.  
  1251. procedure TPDBMultiImage.SaveToFile(Filename : TFilename);
  1252. var
  1253.   Cursor       :  hCursor;
  1254. begin
  1255.   If FDataLink.Field is TBlobField then begin
  1256.  
  1257.     If TBlobField(FDataLink.Field).IsNull then begin
  1258.        MessageDlg('Can''t save, blobfield is empty', mtInformation, [mbOk], 0);
  1259.        Exit;
  1260.     end;
  1261.  
  1262.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1263.     TBlobField(FDataLink.Field).SaveToFile(Filename);
  1264.     GetInfoAndType;
  1265.     SetCursor(Cursor)
  1266.  
  1267.   end else begin
  1268.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  1269.     Exit;
  1270.   end;
  1271. end;
  1272. {------------------------------------------------------------------------}
  1273.  
  1274. procedure TPDBMultiImage.SaveToFileAsBMP(Filename : TFilename);
  1275. var
  1276.   Cursor       :  hCursor;
  1277.   WriteRes     :  Integer;
  1278. begin
  1279.   If FDataLink.Field is TBlobField then begin
  1280.  
  1281.     If TBlobField(FDataLink.Field).IsNull then begin
  1282.        MessageDlg('Can''t save, blobfield Bitmap is empty', mtInformation, [mbOk], 0);
  1283.        Exit;
  1284.     end;
  1285.  
  1286.     If picture.Bitmap.empty then begin
  1287.        MessageDlg('Can''t save, image is not displayed, Set Autodisplay or double click display to view image first.',
  1288.                   mtInformation, [mbOk], 0);
  1289.        Exit;
  1290.     end;
  1291.  
  1292.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1293.  
  1294.     If FWriteResolution = Color16 then WriteRes := 4;
  1295.     If FWriteResolution = Color256 then WriteRes := 8;
  1296.     If FWriteResolution = ColorTrue then WriteRes := 24;
  1297.  
  1298.     If not putBMPfile(Filename, WriteRes, Picture.Bitmap, TPDBMultiImageCallBack) then begin
  1299.       SetCursor(Cursor);
  1300.       MessageDlg('Writing BMP file failed', mtInformation, [mbOk], 0);
  1301.       Exit;
  1302.     end;
  1303.  
  1304.     GetInfoAndType
  1305.  
  1306.   end else begin
  1307.     SetCursor(Cursor);
  1308.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  1309.     Exit;
  1310.   end;
  1311.  
  1312.   SetCursor(Cursor);
  1313. end;
  1314. {------------------------------------------------------------------------}
  1315.  
  1316. procedure TPDBMultiImage.SaveToFileAsGIF(Filename : TFilename);
  1317. var
  1318.   Cursor       :  hCursor;
  1319.   WriteRes     :  Integer;
  1320. begin
  1321.   If FDataLink.Field is TBlobField then begin
  1322.  
  1323.     If TBlobField(FDataLink.Field).IsNull then begin
  1324.        MessageDlg('Can''t save, blobfield Bitmap is empty', mtInformation, [mbOk], 0);
  1325.        Exit;
  1326.     end;
  1327.  
  1328.     If picture.Bitmap.empty then begin
  1329.        MessageDlg('Can''t save, image is not displayed, Set Autodisplay or double click display to view image first.',
  1330.                   mtInformation, [mbOk], 0);
  1331.        Exit;
  1332.     end;
  1333.  
  1334.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1335.  
  1336.     If FWriteResolution = Color16 then WriteRes := 4;
  1337.     If FWriteResolution = Color256 then WriteRes := 8;
  1338.     If FWriteResolution = ColorTrue then WriteRes := 24;
  1339.  
  1340.     If not putGIFfile(Filename, WriteRes, Picture.Bitmap, TPDBMultiImageCallBack) then begin
  1341.       SetCursor(Cursor);
  1342.       MessageDlg('Writing GIF file failed', mtInformation, [mbOk], 0);
  1343.       Exit;
  1344.     end;
  1345.  
  1346.     GetInfoAndType
  1347.  
  1348.   end else begin
  1349.     SetCursor(Cursor);
  1350.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  1351.     Exit;
  1352.   end;
  1353.  
  1354.   SetCursor(Cursor);
  1355. end;
  1356. {------------------------------------------------------------------------}
  1357.  
  1358. procedure TPDBMultiImage.SaveToFileAsPCX(Filename : TFilename);
  1359. var
  1360.   Cursor       :  hCursor;
  1361.   WriteRes     :  Integer;
  1362. begin
  1363.   If FDataLink.Field is TBlobField then begin
  1364.  
  1365.     If TBlobField(FDataLink.Field).IsNull then begin
  1366.        MessageDlg('Can''t save, blobfield Bitmap is empty', mtInformation, [mbOk], 0);
  1367.        Exit;
  1368.     end;
  1369.  
  1370.     If picture.Bitmap.empty then begin
  1371.        MessageDlg('Can''t save, image is not displayed, Set Autodisplay or double click display to view image first.',
  1372.                   mtInformation, [mbOk], 0);
  1373.        Exit;
  1374.     end;
  1375.  
  1376.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1377.  
  1378.     If FWriteResolution = Color16 then WriteRes := 4;
  1379.     If FWriteResolution = Color256 then WriteRes := 8;
  1380.     If FWriteResolution = ColorTrue then WriteRes := 24;
  1381.  
  1382.     If not putPCXfile(Filename, WriteRes, Picture.Bitmap, TPDBMultiImageCallBack) then begin
  1383.       SetCursor(Cursor);
  1384.       MessageDlg('Writing PCX file failed', mtInformation, [mbOk], 0);
  1385.       Exit;
  1386.     end;
  1387.  
  1388.     GetInfoAndType
  1389.  
  1390.   end else begin
  1391.     SetCursor(Cursor);
  1392.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  1393.     Exit;
  1394.   end;
  1395.  
  1396.   SetCursor(Cursor);
  1397. end;
  1398. {------------------------------------------------------------------------}
  1399.  
  1400. procedure TPDBMultiImage.SaveToFileAsPNG(Filename : TFilename);
  1401. var
  1402.   Cursor       :  hCursor;
  1403.   WriteRes     :  Integer;
  1404.   InterL       :  Byte;
  1405. begin
  1406.   If FDataLink.Field is TBlobField then begin
  1407.  
  1408.     If TBlobField(FDataLink.Field).IsNull then begin
  1409.        MessageDlg('Can''t save, blobfield Bitmap is empty', mtInformation, [mbOk], 0);
  1410.        Exit;
  1411.     end;
  1412.  
  1413.     If picture.Bitmap.empty then begin
  1414.        MessageDlg('Can''t save, image is not displayed, Set Autodisplay or double click display to view image first.',
  1415.                   mtInformation, [mbOk], 0);
  1416.        Exit;
  1417.     end;
  1418.  
  1419.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1420.  
  1421.     If FWriteResolution = Color16 then WriteRes := 4;
  1422.     If FWriteResolution = Color256 then WriteRes := 8;
  1423.     If FWriteResolution = ColorTrue then WriteRes := 24;
  1424.     If FInterlaced then InterL :=1 else InterL :=0;
  1425.  
  1426.     If not putPNGfile(Filename, WriteRes, Interl, Picture.Bitmap, TPDBMultiImageCallBack) then begin
  1427.       SetCursor(Cursor);
  1428.       MessageDlg('Writing PNG file failed', mtInformation, [mbOk], 0);
  1429.       Exit;
  1430.     end;
  1431.  
  1432.     GetInfoAndType
  1433.  
  1434.   end else begin
  1435.     SetCursor(Cursor);
  1436.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  1437.     Exit;
  1438.   end;
  1439.  
  1440.   SetCursor(Cursor);
  1441. end;
  1442. {------------------------------------------------------------------------}
  1443.  
  1444. procedure TPDBMultiImage.SaveToFileAsJPG(Filename : TFilename);
  1445. var
  1446.   Cursor       :  hCursor;
  1447. begin
  1448.   If FDataLink.Field is TBlobField then begin
  1449.  
  1450.     If TBlobField(FDataLink.Field).IsNull then begin
  1451.        MessageDlg('Can''t save, blobfield Bitmap is empty', mtInformation, [mbOk], 0);
  1452.        Exit;
  1453.     end;
  1454.  
  1455.     If picture.Bitmap = nil then begin
  1456.        MessageDlg('Can''t save, image is not displayed', mtInformation, [mbOk], 0);
  1457.        Exit;
  1458.     end;
  1459.  
  1460.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1461.  
  1462.     If not putJPGfile(Filename, FSaveQuality, FSaveSmooth, picture.Bitmap, TPDBMultiImageCallBack) then begin
  1463.       SetCursor(Cursor);
  1464.       MessageDlg('Writing JPG file failed', mtInformation, [mbOk], 0);
  1465.       Exit;
  1466.     end;
  1467.  
  1468.     GetInfoAndType
  1469.  
  1470.   end else begin
  1471.     SetCursor(Cursor);
  1472.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  1473.     Exit;
  1474.   end;
  1475.  
  1476.   SetCursor(Cursor);
  1477. end;
  1478.  
  1479.  
  1480. {------------------------------------------------------------------------}
  1481.  
  1482. function TPDBMultiImage.GetInfoAndType : String;
  1483. var
  1484.  Stream       :  TMemoryStream;
  1485.  Hdr          :  Array[0..45] of char;
  1486.  i            :  Byte;
  1487. begin
  1488.   If (FDataLink.Field is TBlobField) then
  1489.    If TBlobField(FDataLink.Field).IsNull then Exit;
  1490.  
  1491.    BFileType := 'Empty';
  1492.    Bwidth:=-1;
  1493.    BHeight:=-1;
  1494.    Bbitspixel:=-1;
  1495.    Bplanes:=-1;
  1496.    Bnumcolors:=-1;
  1497.    Bcompression:='-1';
  1498.    BSize:=-1;
  1499.    GetInfoAndType :='-1';
  1500.  
  1501.    Stream:=TMemoryStream.Create;
  1502.    TBlobField(FDataLink.Field).SaveToStream(Stream);
  1503.  
  1504.   If Stream.Memory = nil then begin
  1505.      MessageDlg('Error allocation Temporary blob memory', mtInformation, [mbOk], 0);
  1506.      Exit;
  1507.   end;
  1508.  
  1509.   Stream.Seek(0,0);
  1510.   Stream.read(hdr,SizeOf(Hdr)-1);
  1511.  
  1512.   for i:=0 to SizeOf(hdr)-1 do
  1513.    If hdr[i] = #0 then hdr[i]:=' ';
  1514.  
  1515.   If StrPos(hdr,'kevinjan') <> nil then begin
  1516.         Bwidth:=-1;
  1517.         BHeight:=-1;
  1518.         Bbitspixel:=-1;
  1519.         Bplanes:=-1;
  1520.         Bnumcolors:=-1;
  1521.         Bcompression:='MSG';
  1522.         BSize:=Stream.Size;
  1523.         BFileType:= 'SCM';
  1524.         GetInfoAndType:='SCM';
  1525.         If Stream.Memory <> nil then Stream.Free;
  1526.         Exit;
  1527.    end else
  1528.  
  1529.   If StrPos(hdr,'jankevin') <> nil then begin
  1530.         Bwidth:=-1;
  1531.         BHeight:=-1;
  1532.         Bbitspixel:=-1;
  1533.         Bplanes:=-1;
  1534.         Bnumcolors:=-1;
  1535.         Bcompression:='MSG';
  1536.         BSize:=Stream.Size;
  1537.         BFileType:= 'CMS';
  1538.         GetInfoAndType:='CMS';
  1539.         If Stream.Memory <> nil then Stream.Free;
  1540.         Exit;
  1541.    end else
  1542.  
  1543.    If not GetBlobInfo(Stream.Memory,
  1544.                     Stream.Size,
  1545.                     BFileType,
  1546.                     Bwidth,
  1547.                     BHeight,
  1548.                     Bbitspixel,
  1549.                     Bplanes,
  1550.                     Bnumcolors,
  1551.                     Bcompression) then
  1552.     MessageDlg('blobfield getinfo failed', mtInformation, [mbOk], 0) else
  1553.     begin
  1554.          BSize:=Stream.Size;
  1555.          If UpperCase(BFileType) = 'PNG' then GetInfoAndType:='PNG' else
  1556.          If UpperCase(BFileType) = 'GIF' then GetInfoAndType:='GIF' else
  1557.          If UpperCase(BFileType) = 'PCX' then GetInfoAndType:='PCX' else
  1558.          If UpperCase(BFileType) = 'JPEG' then GetInfoAndType:='JPG' else
  1559.          If UpperCase(BFileType) = 'BMP' then GetInfoAndType:='BMP';
  1560.     end;
  1561.   If Stream.Memory <> nil then Stream.Free;
  1562. end;
  1563. {------------------------------------------------------------------------}
  1564.  
  1565. function TPDBMultiImage.GetSmooth : Byte;
  1566. begin
  1567.   GetSmooth:=FSaveSmooth;
  1568. end;
  1569. {------------------------------------------------------------------------}
  1570.  
  1571. procedure TPDBMultiImage.SetSmooth(Smooth : Byte);
  1572. begin
  1573.   If (Smooth > 100) or (Smooth < 0) then FSaveSmooth:=5 else
  1574.    FSaveSmooth:=Smooth;
  1575. end;
  1576. {------------------------------------------------------------------------}
  1577.  
  1578. function TPDBMultiImage.GetQuality : Byte;
  1579. begin
  1580.   GetQuality:=FSaveQuality;
  1581. end;
  1582. {------------------------------------------------------------------------}
  1583.  
  1584. procedure TPDBMultiImage.SetQuality(Quality : Byte);
  1585. begin
  1586.   If (Quality > 100) OR (Quality < 1) then FSaveQuality:=25 else
  1587.    FSaveQuality:=Quality;
  1588. end;
  1589. {------------------------------------------------------------------------}
  1590.  
  1591. procedure TPDBMultiImage.SetReadRes(Res : TResolution);
  1592. begin
  1593.   FReadResolution := Res;
  1594. end;
  1595. {------------------------------------------------------------------------}
  1596.  
  1597. procedure TPDBMultiImage.SetWriteRes(Res : TResolution);
  1598. begin
  1599.   FWriteResolution := Res;
  1600. end;
  1601. {------------------------------------------------------------------------}
  1602.  
  1603. {------------------------------------------------------------------------
  1604.  scrolling message stuff
  1605. ------------------------------------------------------------------------}
  1606.  
  1607. procedure TPDBMultiImage.LoadMessageFromStream(MessageStream : TStream);
  1608. var
  1609.   Msg      : TLabel;
  1610. begin
  1611.   FreeMsg;
  1612.   ScreenWd:=Width;
  1613.   ScreenHt:=Height;
  1614.   Msg := TLabel.Create(Self);
  1615.   readmessagefromstream(MessageStream, MsgFont, MsgSpeed, MsgBkGrnd, MsgText);
  1616.   Refresh;
  1617.   If MsgText[Length(MsgText)] <> ' ' then MsgText:=MsgText+' ';
  1618.   Msg.Parent :=Self;
  1619.   Msg.Visible := False;
  1620.   Msg.Font := MsgFont;
  1621.   Msg.Caption := MsgText;
  1622.   BitWidth:=Msg.Width;
  1623.   SMessageLeft := ScreenWd;
  1624.   SMessageRight := ScreenWd + Msg.Width;
  1625.   SMessageTop := (ScreenHt - Msg.Height) Div 2;
  1626.   BitMsg.Width := Msg.Width;
  1627.   BitMsg.Height := Msg.Height;
  1628.   OldColor:=Color;
  1629.   Color:=MsgBkGrnd;
  1630.  
  1631.   with BitMsg.Canvas do begin
  1632.     Brush.Color := MsgBkGrnd;
  1633.     Font := Msg.Font;
  1634.     TextOut(0,0,Msg.Caption);
  1635.   end;
  1636.  
  1637.    Msg.Free;
  1638.    Msg := nil;
  1639.    MessageRunning:=True;
  1640. end;
  1641. {------------------------------------------------------------------------}
  1642.  
  1643. procedure TPDBMultiImage.NewMessage;
  1644. var
  1645.   Msg      : TLabel;
  1646. begin
  1647.   FreeMsg;
  1648.   If MsgText = '' then Exit;
  1649.   If MsgText[Length(MsgText)] <> ' ' then MsgText:=MsgText+' ';
  1650.   ScreenWd:=Width;
  1651.   ScreenHt:=Height;
  1652.   Msg := TLabel.Create(Self);
  1653.   Refresh;
  1654.   Msg.Parent :=Self;
  1655.   Msg.Visible := False;
  1656.   Msg.Font := MsgFont;
  1657.   Msg.Caption := MsgText;
  1658.   BitWidth:=Msg.Width;
  1659.   SMessageLeft := ScreenWd;
  1660.   SMessageRight := ScreenWd + Msg.Width;
  1661.   SMessageTop := (ScreenHt - Msg.Height) Div 2;
  1662.   BitMsg.Width := Msg.Width;
  1663.   BitMsg.Height := Msg.Height;
  1664.   OldColor:=Color;
  1665.   Color:=MsgBkGrnd;
  1666.  
  1667.   with BitMsg.Canvas do begin
  1668.     Brush.Color := MsgBkGrnd;
  1669.     Font := Msg.Font;
  1670.     TextOut(0,0,Msg.Caption);
  1671.   end;
  1672.  
  1673.    Msg.Free;
  1674.    Msg := nil;
  1675.    MessageRunning:=True;
  1676. end;
  1677. {------------------------------------------------------------------------}
  1678.  
  1679. Function TPDBMultiImage.CreateMessage : Boolean;
  1680. begin
  1681.  Result:=False;
  1682.  SetupMsg30:=TSetupMsg30.Create(Self);
  1683.  SetupMsg30.ShowModal;
  1684.  If SetupMsg30.ModalResult = mrOK then begin
  1685.   Result:=SaveMessageToStream(SetupMsg30.MessageFont,
  1686.                               SetupMsg30.MessageSpeed,
  1687.                               SetupMsg30.MessageColor,
  1688.                               SetupMsg30.MessageMsg);
  1689.  end;
  1690.  SetupMsg30.destroy;
  1691.  SetupMsg30:=Nil;
  1692. end;
  1693. {------------------------------------------------------------------------}
  1694.  
  1695. Procedure TPDBMultiImage.FreeMsg;
  1696. Begin
  1697.   If MessageRunning then
  1698.    Color:=OldColor;
  1699.   If CMessageRunning then
  1700.    Color:=OldColor;
  1701.   CMessageRunning:=False;
  1702.   MessageRunning:=False;
  1703.   Picture.Assign(nil);
  1704. end;
  1705. {------------------------------------------------------------------------}
  1706.  
  1707. Function TPDBMultiImage.Delay(Ms : Integer) : boolean;
  1708. Begin
  1709.  Inc(DelayCounter);
  1710.  If DelayCounter > MS then begin
  1711.   DelayCounter:=0;
  1712.   Result:=True;
  1713.  end else
  1714.   Result:=False;
  1715. end;
  1716. {------------------------------------------------------------------------}
  1717.  
  1718. Procedure TPDBMultiImage.MoveMsg(Var WinMsg : TMessage);
  1719. Begin
  1720.   If Not MessageRunning then Exit;
  1721.   If Not Delay(MsgSpeed)then Exit;
  1722.   Dec(SMessageLeft,1);
  1723.   Dec(SMessageRight,1);
  1724.   Inc(MmsgCount,1);
  1725.   If SMessageRight < 0 then begin
  1726.     SMessageLeft := ScreenWd;
  1727.     SMessageRight := SMessageLeft + BitWidth;
  1728.   end;
  1729.     with Canvas do
  1730.        Draw(SMessageLeft,SMessageTop,BitMsg);
  1731. end;
  1732. {------------------------------------------------------------------------}
  1733.  
  1734. Procedure TPDBMultiImage.Trigger;
  1735. Begin
  1736.   If SetupMsg30 <> nil then SetupMsg30.Trigger;
  1737.   If SetupCredMsg30 <> nil then SetupCredMsg30.Trigger;
  1738.  
  1739.   If (visible) and (enabled) then begin
  1740.    PostMessage(Handle, WM_Trigger, 0, 0);
  1741.    PostMessage(Handle, WM_CTrigger, 0, 0);
  1742.   end;
  1743.  
  1744. End;
  1745. {------------------------------------------------------------------------}
  1746.  
  1747. Function TPDBMultiImage.SaveMessageToStream(MFont  : Tfont;
  1748.                                            Mspeed : Integer;
  1749.                                            MColor : Tcolor;
  1750.                                            MMsg   : String) : Boolean;
  1751. var
  1752.    Stream       :  TMemoryStream;
  1753.    Cursor       :  hCursor;
  1754.    Usize        :  Longint;
  1755.    P            :  Array[0..1602] of char;
  1756. begin
  1757.   Result:=True;
  1758.   If FDataLink.Field is TBlobField then begin
  1759.      If Length(MMsg) < 1 then
  1760.       begin
  1761.         Result:=False;
  1762.         Exit;
  1763.        end;
  1764.  
  1765.       Usize:=WriteMessageToStream(MFont, MSpeed, MColor, MMsg, P);
  1766.  
  1767.       If Usize < 1 then
  1768.        begin
  1769.         Result:=False;
  1770.         Exit;
  1771.        end;
  1772.  
  1773.       Stream:=TMemoryStream.Create;
  1774.       Stream.Write(P,Usize+1);
  1775.  
  1776.       try
  1777.         TBlobField(FDataLink.Field).LoadFromStream(Stream);
  1778.       finally
  1779.         Stream.Free;
  1780.       end;
  1781.      GetInfoAndType;
  1782.    end;
  1783. end;
  1784.  
  1785.  
  1786. {------------------------------------------------------------------------
  1787.  credit message stuff
  1788. ------------------------------------------------------------------------}
  1789.  
  1790. procedure TPDBMultiImage.LoadCreditMessageFromStream(MessageStream : TStream);
  1791. var
  1792.   Msg      : TLabel;
  1793. begin
  1794.   Picture.Assign(nil);
  1795.   ReadCreditFromStream(MessageStream, MsgFont, MsgSpeed, MsgBkGrnd, CreditBoxList);
  1796.   Creditcounter:=0;
  1797.   If CreditBoxList.Count <1 then Exit;
  1798.   MsgText:=CreditBoxList.Strings[Creditcounter];
  1799.  
  1800.   If MsgText = '' then Exit;
  1801.   If MsgText[1] <> ' ' then MsgText:='  ' + MsgText;
  1802.   If MsgText[Length(MsgText)] <> ' ' then MsgText:=MsgText+' ';
  1803.  
  1804.   ScreenWd:=Width;
  1805.   ScreenHt:=Height;
  1806.   Refresh;
  1807.   Msg := TLabel.Create(Self);
  1808.   Refresh;
  1809.   Msg.Parent :=Self;
  1810.   Msg.Visible := False;
  1811.   Msg.Font := MsgFont;
  1812.   Msg.Caption := MsgText;
  1813.   Msg.Width:=Msg.Width+(Msg.Width div (Length(MsgText)-2));
  1814.   BitHeight:=Msg.Height;
  1815.   BitWidth:=Msg.Width;
  1816.   SMessageLeft :=(ScreenWd - Msg.Width) Div 2;
  1817.   SMessageTop := ScreenHt;
  1818.   SMessageBottom := SMessageTop + Msg.Height;
  1819.  
  1820.   BitMsg.Width := Msg.Width;
  1821.   BitMsg.Height := Msg.Height+5;
  1822.   OldColor:=Color;
  1823.   Color:=MsgBkGrnd;
  1824.  
  1825.   with Canvas do begin
  1826.     Brush.Style := bsSolid;
  1827.     Brush.Color:=MsgBkGrnd;
  1828.     Rectangle(0, 0, Width, Height);
  1829.   end;
  1830.  
  1831.   with BitMsg.Canvas do begin
  1832.     Brush.Color := MsgBkGrnd;
  1833.     Pen.Color:=MsgBkGrnd;
  1834.     Rectangle(0, 0, BitMsg.Width, BitMsg.Height);
  1835.     Font := Msg.Font;
  1836.     TextOut(0,0,Msg.Caption);
  1837.   end;
  1838.  
  1839.    Msg.Free;
  1840.    Msg := nil;
  1841.    CMessageRunning:=True;
  1842. end;
  1843. {------------------------------------------------------------------------}
  1844.  
  1845. procedure TPDBMultiImage.NewCreditMessage;
  1846. var
  1847.   Msg : TLabel;
  1848. begin
  1849.   If CreditBoxList.Count <1 then Exit;
  1850.   If Creditcounter > CreditBoxList.Count then Creditcounter:=0;
  1851.  
  1852.   MsgText:=CreditBoxList.Strings[Creditcounter];
  1853.   If MsgText = '' then Exit;
  1854.  
  1855.   If MsgText[1] <> ' ' then MsgText:='  ' + MsgText;
  1856.   If MsgText[Length(MsgText)] <> ' ' then MsgText:=MsgText+' ';
  1857.  
  1858.   ScreenWd:=Width;
  1859.   ScreenHt:=Height;
  1860.   Msg := TLabel.Create(Self);
  1861.   Refresh;
  1862.   Msg.Parent :=Self;
  1863.   Msg.Visible := False;
  1864.   Msg.Font := MsgFont;
  1865.   Msg.Caption := MsgText;
  1866.   BitHeight:=Msg.Height;
  1867.   Msg.Width:=Msg.Width+(Msg.Width div (Length(MsgText)-2));
  1868.   BitWidth:=Msg.Width;
  1869.   SMessageLeft :=(ScreenWd - Msg.Width) Div 2;
  1870.   SMessageTop := ScreenHt;
  1871.   SMessageBottom := SMessageTop + Msg.Height;
  1872.   BitMsg.Width := Msg.Width;
  1873.   BitMsg.Height := Msg.Height+5;
  1874.   if not CMessageRunning then
  1875.    OldColor:=Color;
  1876.   Color:=MsgBkGrnd;
  1877.  
  1878.   with Canvas do begin
  1879.     Brush.Style := bsSolid;
  1880.     Brush.Color:=MsgBkGrnd;
  1881.     Rectangle(0, 0, Width, Height);
  1882.   end;
  1883.  
  1884.   with BitMsg.Canvas do begin
  1885.     Brush.Color := MsgBkGrnd;
  1886.     Pen.Color:=MsgBkGrnd;
  1887.     Rectangle(0, 0, BitMsg.Width, BitMsg.Height);
  1888.     Font := Msg.Font;
  1889.     TextOut(0,0,Msg.Caption);
  1890.   end;
  1891.  
  1892.    Msg.Free;
  1893.    Msg := nil;
  1894.    CMessageRunning:=True;
  1895. end;
  1896. {------------------------------------------------------------------------}
  1897.  
  1898. Function TPDBMultiImage.SaveCreditMessageToStream(MFont  : Tfont;
  1899.                                                   Mspeed : integer;
  1900.                                                   MColor : Tcolor;
  1901.                                                   MMsg   : TStringList) : Boolean;
  1902. var
  1903.    Stream       :  TMemoryStream;
  1904.    Cursor       :  hCursor;
  1905.    Usize        :  longInt;
  1906.    P            :  PChar;
  1907. begin
  1908.   Result:=True;
  1909.   if FDataLink.Field is TBlobField then begin
  1910.  
  1911.       GetMem(P,65528);
  1912.  
  1913.       Usize:=WriteCreditToStream(MFont, MSpeed, MColor, MMsg, P);
  1914.  
  1915.       If Usize < 1 then
  1916.        begin
  1917.         Result:=False;
  1918.         FreeMem(P,65528);
  1919.         exit;
  1920.        end;
  1921.  
  1922.       Stream:=TMemoryStream.Create;
  1923.       Stream.Write(P^,Usize+1);
  1924.  
  1925.       FreeMem(P,65528);
  1926.  
  1927.       try
  1928.         TBlobField(FDataLink.Field).LoadFromStream(Stream);
  1929.       finally
  1930.         Stream.Free;
  1931.       end;
  1932.  
  1933.      GetInfoAndType;
  1934.    end;
  1935. end;
  1936.  
  1937. {------------------------------------------------------------------------}
  1938.  
  1939. Function TPDBMultiImage.CreateCreditMessage : Boolean;
  1940. begin
  1941.  Result:=False;
  1942.  
  1943.  SetupCredMsg30:=TSetupCredMsg30.Create(Self);
  1944.  
  1945.  SetupCredMsg30.ShowModal;
  1946.  
  1947.  if SetupCredMsg30.ModalResult = mrOK then begin
  1948.   Result:=SaveCreditMessageToStream(SetupCredMsg30.MessageFont,
  1949.                                     SetupCredMsg30.MessageSpeed,
  1950.                                     SetupCredMsg30.MessageColor,
  1951.                                     SetupCredMsg30.MessageStrList);
  1952.  end;
  1953.  SetupCredMsg30.destroy;
  1954.  SetupCredMsg30:=Nil;
  1955. end;
  1956.  
  1957. {------------------------------------------------------------------------}
  1958.  
  1959. Procedure TPDBMultiImage.MoveCredMsg(Var WinMsg : TMessage);
  1960. Begin
  1961.   If Not CMessageRunning then Exit;
  1962.   If not Delay(MsgSpeed) then Exit;
  1963.   Dec(SMessageTop,1);
  1964.   Dec(SMessageBottom,1);
  1965.   If SMessageTop < (0-BitHeight)-5 then begin
  1966.      If CreditBoxList.Count >0 then begin
  1967.         If Creditcounter < CreditBoxList.Count-1 then
  1968.            Inc(Creditcounter)
  1969.         else Creditcounter:=0;
  1970.         NewCreditMessage;
  1971.      end else begin
  1972.          SMessageTop := ScreenHt;
  1973.          SMessageBottom := SMessageTop + BitHeight;
  1974.      end;
  1975.   end;
  1976.  
  1977.   with Canvas do Draw(SMessageLeft,SMessageTop,BitMsg);
  1978. end;
  1979.  
  1980. {------------------------------------------------------------------------
  1981. Printing Stuff
  1982. ------------------------------------------------------------------------}
  1983.  
  1984. procedure TPDBMultiImage.PrintMultiImage(X, Y, pWidth, pHeight: Integer);
  1985. begin
  1986.  If Picture.Graphic.Empty then Exit;
  1987.  
  1988.  If (BFiletype = 'ICO') or (BFiletype = 'WMF') then
  1989.    PrintICOWMF(X, Y, pWidth, pHeight)
  1990.  else
  1991.    PrintBitmap(X, Y, pWidth, pHeight)
  1992. end;
  1993. {---------------------------------------------------------------------}
  1994.  
  1995. procedure TPDBMultiImage.PrintBitmap(X, Y, pWidth, pHeight: Integer);
  1996. var
  1997.   Info     : PBitmapInfo;
  1998.   InfoSize : Integer;
  1999.   Image    : Pointer;
  2000.   ImageSize: Longint;
  2001. begin
  2002.    If (pWidth < 1) or (pHeight < 1) then begin
  2003.       pWidth:=Picture.Bitmap.Width;
  2004.       pHeight:=Picture.Bitmap.Height;
  2005.    end;
  2006.  
  2007.    Printer.Begindoc;
  2008.  
  2009.     with Picture.Bitmap do begin
  2010.       GetDIBSizes(Handle, InfoSize, ImageSize);
  2011.       Info := MemAlloc(InfoSize);
  2012.       try
  2013.         Image := MemAlloc(ImageSize);
  2014.         try
  2015.           GetDIB(Handle, Palette, Info^, Image^);
  2016.           with Info^.bmiHeader do
  2017.            StretchDIBits(Printer.Canvas.Handle, X, Y, pWidth,
  2018.             pHeight, 0, 0, biWidth, biHeight, Image, Info^,
  2019.             DIB_RGB_COLORS, SRCCOPY)
  2020.          finally
  2021.           FreeMem(Image, ImageSize);
  2022.          end;
  2023.       finally
  2024.        FreeMem(Info, InfoSize);
  2025.       end;
  2026.     end;
  2027.     Printer.Enddoc;
  2028.   end;
  2029. {---------------------------------------------------------------------}
  2030.  
  2031. procedure TPDBMultiImage.PrintICOWMF(X, Y, pWidth, pHeight: Integer);
  2032. begin
  2033.    If (pWidth < 1) or (pHeight < 1) then begin
  2034.     pWidth:=Picture.Graphic.Width;
  2035.     pHeight:=Picture.Graphic.Height;
  2036.    end;
  2037.  
  2038.    Printer.Begindoc;
  2039.  
  2040.    Printer.Canvas.StretchDraw(Rect(X, Y, pWidth, pHeight), Picture.Graphic);
  2041.  
  2042.    Printer.Enddoc;
  2043. end;
  2044. {------------------------------------------------------------------------
  2045.  end TPDBMultiImage
  2046. ------------------------------------------------------------------------}
  2047.  
  2048.  
  2049.  
  2050. {TPDBMultiMedia}
  2051.  
  2052. constructor TPDBMultiMedia.Create(AOwner: TComponent);
  2053. begin
  2054.   inherited Create(AOwner);
  2055.   ControlStyle := ControlStyle + [csFramed, csOpaque];
  2056.   Width := 105;
  2057.   Height := 105;
  2058.   TabStop := True;
  2059.   ParentColor := False;
  2060.   FPicture := TPicture.Create;
  2061.   FPicture.OnChange := PictureChanged;
  2062.   FBorderStyle := bsSingle;
  2063.   FAutoDisplay := True;
  2064.   FImageLibPalette:=True;
  2065.   FCenter := True;
  2066.   FUpdateAsJPG := True;
  2067.   FDither:=True;
  2068.   FReadResolution := Color256;
  2069.   FWriteResolution := Color256;
  2070.   FSaveQuality:=25;
  2071.   FSaveSmooth:=0;
  2072.   FDataLink := TFieldDataLink.Create;
  2073.   FDataLink.Control := Self;
  2074.   FDataLink.OnDataChange := DataChange;
  2075.   FDataLink.OnUpdateData := UpdateData;
  2076.   FMOVTempFile:='$$$.MOV';
  2077.   FMPGTempFile:='$$$.MPG';
  2078.   FAVITempFile:='$$$.AVI';
  2079.   FWAVTempFile:='$$$.WAV';
  2080.   FMIDTempFile:='$$$.MID';
  2081.   FRMITempFile:='$$$.RMI';
  2082.   FTempFilePath:='C:\';
  2083.   MsgFont:=TFont.Create;
  2084.   BitMsg := TBitmap.Create;
  2085.   MessageRunning:=False;
  2086.   CMessageRunning:=False;
  2087.   SetupMsg30:=Nil;
  2088.   SetupCredMsg30:=Nil;
  2089.   CreditBoxList:=TStringList.Create;
  2090.   Creditcounter:=0;
  2091.   DelayCounter:=0;
  2092.   Color:=clWindow;
  2093.   FAutoMMHide := False;
  2094. end;
  2095. {------------------------------------------------------------------------}
  2096.  
  2097. destructor TPDBMultiMedia.Destroy;
  2098. begin
  2099.   CleanUpMultiMedia;
  2100.   FPicture.Free;
  2101.   FDataLink.Free;
  2102.   MsgFont.Free;
  2103.   BitMsg.Free;
  2104.   FDataLink := nil;
  2105.   CreditBoxList.Free;
  2106.   inherited Destroy;
  2107. end;
  2108. {------------------------------------------------------------------------}
  2109.  
  2110. function TPDBMultiMedia.GetDataSource: TDataSource;
  2111. begin
  2112.   Result := FDataLink.DataSource;
  2113. end;
  2114. {------------------------------------------------------------------------}
  2115.  
  2116. procedure TPDBMultiMedia.SetDataSource(Value: TDataSource);
  2117. begin
  2118.   FDataLink.DataSource := Value;
  2119. end;
  2120. {------------------------------------------------------------------------}
  2121.  
  2122. function TPDBMultiMedia.GetDataField: String;
  2123. begin
  2124.   Result := FDataLink.FieldName;
  2125. end;
  2126. {------------------------------------------------------------------------}
  2127.  
  2128. procedure TPDBMultiMedia.SetDataField(const Value: String);
  2129. begin
  2130.   FDataLink.FieldName := Value;
  2131. end;
  2132. {------------------------------------------------------------------------}
  2133.  
  2134. function TPDBMultiMedia.GetReadOnly: Boolean;
  2135. begin
  2136.   Result := FDataLink.ReadOnly;
  2137. end;
  2138. {------------------------------------------------------------------------}
  2139.  
  2140. procedure TPDBMultiMedia.SetReadOnly(Value: Boolean);
  2141. begin
  2142.   FDataLink.ReadOnly := Value;
  2143. end;
  2144. {------------------------------------------------------------------------}
  2145.  
  2146. function TPDBMultiMedia.GetField: TField;
  2147. begin
  2148.   Result := FDataLink.Field;
  2149. end;
  2150. {------------------------------------------------------------------------}
  2151.  
  2152. function TPDBMultiMedia.GetPalette: HPALETTE;
  2153. begin
  2154.   Result := 0;
  2155.   If ImageLibPalette then Exit;
  2156.   If FPicture.Graphic is TBitmap then
  2157.     Result := TBitmap(FPicture.Graphic).Palette;
  2158. end;
  2159. {------------------------------------------------------------------------}
  2160.  
  2161. procedure TPDBMultiMedia.SetAutoDisplay(Value: Boolean);
  2162. begin
  2163.   If FAutoDisplay <> Value then
  2164.   begin
  2165.     FAutoDisplay := Value;
  2166.     If Value then LoadMedia;
  2167.   end;
  2168. end;
  2169. {------------------------------------------------------------------------}
  2170.  
  2171. procedure TPDBMultiMedia.SetBorderStyle(Value: TBorderStyle);
  2172. begin
  2173.   If FBorderStyle <> Value then
  2174.   begin
  2175.     FBorderStyle := Value;
  2176.     RecreateWnd;
  2177.   end;
  2178. end;
  2179. {------------------------------------------------------------------------}
  2180.  
  2181. procedure TPDBMultiMedia.SetCenter(Value: Boolean);
  2182. begin
  2183.   If FCenter <> Value then
  2184.   begin
  2185.     FCenter := Value;
  2186.     Invalidate;
  2187.   end;
  2188. end;
  2189. {------------------------------------------------------------------------}
  2190.  
  2191. procedure TPDBMultiMedia.SetPicture(Value: TPicture);
  2192. begin
  2193.   FPicture.Assign(Value);
  2194. end;
  2195. {------------------------------------------------------------------------}
  2196.  
  2197. procedure TPDBMultiMedia.SetStretch(Value: Boolean);
  2198. begin
  2199.   If FStretch <> Value then
  2200.   begin
  2201.     FStretch := Value;
  2202.     Invalidate;
  2203.   end;
  2204. end;
  2205. {------------------------------------------------------------------------}
  2206.  
  2207. procedure TPDBMultiMedia.Paint;
  2208. var
  2209.   W, H        : Integer;
  2210.   R           : TRect;
  2211.   S           : String[63];
  2212.   OldBitmap   : HBitmap;
  2213.   MemDC       : HDC;
  2214.   hOldPal     : HPalette;
  2215. begin
  2216.  
  2217.   If (BFileType = 'ICO') or (BFileType = 'WMF') or (not ImageLibPalette) then begin
  2218.       PaintTheDelpiWay;
  2219.       Exit;
  2220.   end;
  2221.  
  2222.   with Canvas do begin
  2223.     Brush.Style := bsSolid;
  2224.     Brush.Color := Color;
  2225.  
  2226.     If FPictureLoaded then begin
  2227.       If (Stretch) and (Picture.Graphic <> nil) then
  2228.  
  2229.         If Picture.Graphic.Empty then
  2230.           FillRect(ClientRect) else
  2231.          begin
  2232.  
  2233.             hOldPal := SelectPalette(Canvas.handle,Picture.Bitmap.Palette,False);
  2234.             RealizePalette(Canvas.handle);
  2235.  
  2236.             MemDC := CreateCompatibleDC(Canvas.handle);
  2237.             OldBitmap := SelectObject(MemDC,Picture.Bitmap.Handle);
  2238.  
  2239.             SetStretchBltMode(canvas.handle,STRETCH_DELETESCANS);
  2240.  
  2241.             StretchBlt(Canvas.handle,
  2242.                        ClientRect.Left,
  2243.                        ClientRect.Top,
  2244.                        ClientRect.Right,
  2245.                        ClientRect.Bottom,
  2246.                        MemDC,
  2247.                        ClientRect.Left,
  2248.                        ClientRect.Top,
  2249.                        Picture.Bitmap.Width,
  2250.                        Picture.Bitmap.Height,
  2251.                        srcCopy);
  2252.  
  2253.              SelectObject(MemDC,OldBitmap);
  2254.              DeleteDC(MemDC);
  2255.              SelectPalette(Canvas.handle,hOldPal,False);
  2256.       end else begin
  2257.  
  2258.         SetRect(R, 0, 0, Picture.Width, Picture.Height);
  2259.         If Center then OffsetRect(R, (ClientWidth - Picture.Width) div 2,
  2260.           (ClientHeight - Picture.Height) div 2);
  2261.  
  2262.            hOldPal := SelectPalette(Canvas.handle,Picture.Bitmap.Palette,False);
  2263.            RealizePalette(Canvas.handle);
  2264.  
  2265.            MemDC := CreateCompatibleDC(Canvas.handle);
  2266.            OldBitmap := SelectObject(MemDC,Picture.Bitmap.Handle);
  2267.  
  2268.             BitBlt(Canvas.handle,
  2269.                        R.Left,
  2270.                        R.Top,
  2271.                        Picture.Bitmap.Width,
  2272.                        Picture.Bitmap.Height,
  2273.                        MemDC,
  2274.                        0,
  2275.                        0,
  2276.                        srcCopy);
  2277.  
  2278.              SelectObject(MemDC,OldBitmap);
  2279.              DeleteDC(MemDC);
  2280.              SelectPalette(Canvas.handle,hOldPal,False);
  2281.  
  2282.              ExcludeClipRect(Handle, R.Left, R.Top, R.Right, R.Bottom);
  2283.              FillRect(ClientRect);
  2284.              SelectClipRgn(Handle, 0);
  2285.       end;
  2286.     end else begin
  2287.      Font := Self.Font;
  2288.      If FDataLink.Field <> nil then
  2289.         S := FDataLink.Field.DisplayLabel
  2290.      else
  2291.         S := Name;
  2292.       S := '(' + S + ')';
  2293.       W := TextWidth(S);
  2294.       H := TextHeight(S);
  2295.       R := ClientRect;
  2296.       TextRect(R, (R.Right - W) div 2, (R.Bottom - H) div 2, S);
  2297.     end;
  2298.  
  2299.     If (GetParentForm(Self).ActiveControl = Self) and
  2300.       not (csDesigning in ComponentState) then begin
  2301.         Brush.Color := clWindowFrame;
  2302.         FrameRect(ClientRect);
  2303.     end;
  2304.  
  2305.   end;
  2306.  
  2307.   If (CMessageRunning) and (Picture = nil) then FreeMsg;
  2308.   If (MessageRunning) and (Picture = nil) then FreeMsg;
  2309. end;
  2310. {------------------------------------------------------------------------}
  2311.  
  2312. procedure TPDBMultiMedia.PaintTheDelpiWay;
  2313. var
  2314.   W, H: Integer;
  2315.   R: TRect;
  2316.   S: String[63];
  2317. begin
  2318.   with Canvas do
  2319.   begin
  2320.     Brush.Style := bsSolid;
  2321.     Brush.Color := Color;
  2322.     If FPictureLoaded then
  2323.     begin
  2324.       If (Stretch) and (Picture.Graphic <> nil) then
  2325.         If Picture.Graphic.Empty then
  2326.           FillRect(ClientRect) else
  2327.           StretchDraw(ClientRect, Picture.Graphic)
  2328.       else
  2329.       begin
  2330.         SetRect(R, 0, 0, Picture.Width, Picture.Height);
  2331.         If Center then OffsetRect(R, (ClientWidth - Picture.Width) div 2,
  2332.           (ClientHeight - Picture.Height) div 2);
  2333.         StretchDraw(R, Picture.Graphic);
  2334.         ExcludeClipRect(Handle, R.Left, R.Top, R.Right, R.Bottom);
  2335.         FillRect(ClientRect);
  2336.         SelectClipRgn(Handle, 0);
  2337.       end;
  2338.     end else
  2339.     begin
  2340.       Font := Self.Font;
  2341.       If FDataLink.Field <> nil then
  2342.         S := FDataLink.Field.DisplayLabel else
  2343.         S := Name;
  2344.       S := '(' + S + ')';
  2345.       W := TextWidth(S);
  2346.       H := TextHeight(S);
  2347.       R := ClientRect;
  2348.       TextRect(R, (R.Right - W) div 2, (R.Bottom - H) div 2, S);
  2349.     end;
  2350.     If (GetParentForm(Self).ActiveControl = Self) and
  2351.       not (csDesigning in ComponentState) then
  2352.     begin
  2353.       Brush.Color := clWindowFrame;
  2354.       FrameRect(ClientRect);
  2355.     end;
  2356.   end;
  2357.   If (MessageRunning) and (Picture = nil) then FreeMsg;
  2358.   If (CMessageRunning) and (Picture = nil) then FreeMsg;
  2359. end;
  2360. {------------------------------------------------------------------------}
  2361.  
  2362. procedure TPDBMultiMedia.PictureChanged(Sender: TObject);
  2363. begin
  2364.   FDataLink.Modified;
  2365.   FPictureLoaded := True;
  2366.   Invalidate;
  2367. end;
  2368. {------------------------------------------------------------------------}
  2369.  
  2370. procedure TPDBMultiMedia.Notification(AComponent: TComponent;
  2371.   Operation: TOperation);
  2372. begin
  2373.   inherited Notification(AComponent, Operation);
  2374.   If (Operation = opRemove) and (FDataLink <> nil) and
  2375.     (AComponent = DataSource) then DataSource := nil;
  2376.  
  2377.   If (Operation = opRemove) and
  2378.     (AComponent = FMediaPlayer) then FMediaPlayer := nil;
  2379. end;
  2380. {------------------------------------------------------------------------}
  2381.  
  2382. Procedure TPDBMultiMedia.CleanUpMultiMedia;
  2383. begin
  2384.    If (csDesigning in ComponentState) then Exit;
  2385.    deletefile(FTempFilePath+FMPGTempFile);
  2386.    deletefile(FTempFilePath+FMOVTempFile);
  2387.    deletefile(FTempFilePath+FAVITempFile);
  2388.    deletefile(FTempFilePath+FWAVTempFile);
  2389.    deletefile(FTempFilePath+FMIDTempFile);
  2390.    deletefile(FTempFilePath+FRMITempFile);
  2391. end;
  2392.  
  2393. Procedure TPDBMultiMedia.ScrollErrorMessage(ErString : String);
  2394. begin
  2395.    FreeMsg;
  2396.    MsgText:=ErString;
  2397.    MsgFont.Name:='Arial';
  2398.    MsgFont.Size:=-16;
  2399.    MsgFont.Style:=[fsItalic];
  2400.    MsgFont.Color:=clWhite;
  2401.    MsgBkGrnd:=clTeal;
  2402.    MsgSpeed:=3;
  2403.    NewMessage;
  2404. end;
  2405.  
  2406. procedure TPDBMultiMedia.LoadMedia;
  2407. var
  2408.    Stream       :  TMemoryStream;
  2409.    Bitmap       :  TBitmap;
  2410.    Cursor       :  hCursor;
  2411.    Temp         :  String;
  2412.    Dith         :  Integer;
  2413.    ReadRes      :  Integer;
  2414.  
  2415. begin
  2416.   If not FPictureLoaded and (FDataLink.Field is TBlobField) then begin
  2417.  
  2418.    If TBlobField(FDataLink.Field).IsNull then Exit;
  2419.  
  2420.    Temp:=GetInfoAndType;
  2421.  
  2422.    If FMediaPlayer <> nil then
  2423.      FMediaPlayer.Close;
  2424.  
  2425.    CleanUpMultiMedia;
  2426.  
  2427.   If FReadResolution = Color16 then ReadRes := 4;
  2428.   If FReadResolution = Color256 then ReadRes := 8;
  2429.   If FReadResolution = ColorTrue then ReadRes := 24;
  2430.  
  2431.   If FDither then
  2432.     Dith:=1
  2433.   else
  2434.     Dith:=0;
  2435.  
  2436.   If Temp = 'SCM' then begin
  2437.       Stream:=TMemoryStream.Create;
  2438.       try
  2439.        If FMediaPlayer <> nil then
  2440.          If FAutoMMHide then
  2441.            FMediaPlayer.Visible:=False;
  2442.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  2443.          FreeMsg;
  2444.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  2445.          LoadMessageFromStream(Stream);
  2446.          KillTimer(handle,1);
  2447.          If @TPDBMultiMediaCallBack <> nil then
  2448.            TPDBMultiMediaCallBack(0);
  2449.        finally
  2450.          SetCursor(Cursor);
  2451.          Stream.Free;
  2452.        end;
  2453.    end else
  2454.  
  2455.   If Temp = 'CMS' then begin
  2456.       Stream:=TMemoryStream.Create;
  2457.       try
  2458.        If FMediaPlayer <> nil then
  2459.          If FAutoMMHide then
  2460.            FMediaPlayer.Visible:=False;
  2461.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  2462.          FreeMsg;
  2463.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  2464.          LoadCreditMessageFromStream(Stream);
  2465.          KillTimer(handle,1);
  2466.          If @TPDBMultiMediaCallBack <> nil then
  2467.            TPDBMultiMediaCallBack(0);
  2468.        finally
  2469.          SetCursor(Cursor);
  2470.          Stream.Free;
  2471.        end;
  2472.    end else
  2473.  
  2474.   If Temp = 'MPG' then begin
  2475.          try
  2476.             If (csDesigning in ComponentState) then Exit;
  2477.  
  2478.             If not IsValidMultiMedia('MPG') then begin
  2479.               ScrollErrorMessage('MPG Movie file can''t be played on this computer!');
  2480.               Exit;
  2481.             end;
  2482.  
  2483.               Cursor := SetCursor(LoadCursor(0,idc_Wait));
  2484.               FreeMsg;
  2485.               If FMediaPlayer <> nil then begin
  2486.                FMediaPlayer.Visible:=True;
  2487.                TBlobField(FDataLink.Field).SaveToFile(FTempFilePath+FMPGTempFile);
  2488.                FMediaPlayer.Filename:=FTempFilePath+FMPGTempFile;
  2489.                FMediaPlayer.Open;
  2490.                If FAutoPlayMM then
  2491.                  FMediaPlayer.Play;
  2492.                SetTimer(handle,1,500,nil);
  2493.             end;
  2494.          finally
  2495.             SetCursor(Cursor);
  2496.          end;
  2497.    end else
  2498.  
  2499.    If Temp = 'MOV' then begin
  2500.          try
  2501.             If (csDesigning in ComponentState) then Exit;
  2502.  
  2503.             If not IsValidMultiMedia('MOV') then begin
  2504.               ScrollErrorMessage('MOV Quicktime Movie file can''t be played on this computer!');
  2505.               Exit;
  2506.             end;
  2507.  
  2508.               Cursor := SetCursor(LoadCursor(0,idc_Wait));
  2509.               FreeMsg;
  2510.               If FMediaPlayer <> nil then begin
  2511.                FMediaPlayer.Visible:=True;
  2512.                TBlobField(FDataLink.Field).SaveToFile(FTempFilePath+FMOVTempFile);
  2513.                FMediaPlayer.Filename:=FTempFilePath+FMOVTempFile;
  2514.                FMediaPlayer.Open;
  2515.                If FAutoPlayMM then
  2516.                  FMediaPlayer.Play;
  2517.                SetTimer(handle,1,500,nil);
  2518.             end;
  2519.          finally
  2520.             SetCursor(Cursor);
  2521.          end;
  2522.    end else
  2523.  
  2524.    If Temp = 'AVI' then begin
  2525.          try
  2526.             If (csDesigning in ComponentState) then Exit;
  2527.  
  2528.             If not IsValidMultiMedia('AVI') then begin
  2529.               ScrollErrorMessage('AVI Movie file can''t be played on this computer!');
  2530.               Exit;
  2531.             end;
  2532.  
  2533.               Cursor := SetCursor(LoadCursor(0,idc_Wait));
  2534.               FreeMsg;
  2535.               If FMediaPlayer <> nil then begin
  2536.                FMediaPlayer.Visible:=True;
  2537.                TBlobField(FDataLink.Field).SaveToFile(FTempFilePath+FAVITempFile);
  2538.                FMediaPlayer.Filename:=FTempFilePath+FAVITempFile;
  2539.                FMediaPlayer.Open;
  2540.                If FAutoPlayMM then
  2541.                  FMediaPlayer.Play;
  2542.                SetTimer(handle,1,500,nil);
  2543.             end;
  2544.          finally
  2545.             SetCursor(Cursor);
  2546.          end;
  2547.    end else
  2548.  
  2549.    If Temp = 'WAV' then begin
  2550.          try
  2551.             If (csDesigning in ComponentState) then Exit;
  2552.  
  2553.             If not IsValidMultiMedia('WAV') then begin
  2554.               ScrollErrorMessage('Wave Sound file can''t be played on this computer!');
  2555.               Exit;
  2556.             end;
  2557.  
  2558.              Cursor := SetCursor(LoadCursor(0,idc_Wait));
  2559.              FreeMsg;
  2560.              If FMediaPlayer <> nil then begin
  2561.                FMediaPlayer.Visible:=True;
  2562.                TBlobField(FDataLink.Field).SaveToFile(FTempFilePath+FWAVTempFile);
  2563.                FMediaPlayer.Filename:=FTempFilePath+FWAVTempFile;
  2564.                FMediaPlayer.Open;
  2565.                If FAutoPlayMM then
  2566.                  FMediaPlayer.Play;
  2567.                SetTimer(handle,1,500,nil);
  2568.             end;
  2569.          finally
  2570.             SetCursor(Cursor);
  2571.          end;
  2572.    end else
  2573.  
  2574.    If Temp = 'MID' then begin
  2575.          try
  2576.             If (csDesigning in ComponentState) then Exit;
  2577.  
  2578.             If not IsValidMultiMedia('MID') then begin
  2579.               ScrollErrorMessage('Midi Sound file can''t be played on this computer!');
  2580.               Exit;
  2581.             end;
  2582.  
  2583.              Cursor := SetCursor(LoadCursor(0,idc_Wait));
  2584.              FreeMsg;
  2585.              If FMediaPlayer <> nil then begin
  2586.                FMediaPlayer.Visible:=True;
  2587.                TBlobField(FDataLink.Field).SaveToFile(FTempFilePath+FMIDTempFile);
  2588.                FMediaPlayer.Filename:=FTempFilePath+FMIDTempFile;
  2589.                FMediaPlayer.Open;
  2590.                If FAutoPlayMM then
  2591.                  FMediaPlayer.Play;
  2592.                SetTimer(handle,1,500,nil);
  2593.             end;
  2594.          finally
  2595.             SetCursor(Cursor);
  2596.          end;
  2597.    end else
  2598.  
  2599.    If Temp = 'RMI' then begin
  2600.          try
  2601.             If (csDesigning in ComponentState) then Exit;
  2602.  
  2603.             If not IsValidMultiMedia('RMI') then begin
  2604.               ScrollErrorMessage('RMI Sound file can''t be played on this computer!');
  2605.               Exit;
  2606.             end;
  2607.  
  2608.             Cursor := SetCursor(LoadCursor(0,idc_Wait));
  2609.             FreeMsg;
  2610.             If FMediaPlayer <> nil then begin
  2611.                FMediaPlayer.Visible:=True;
  2612.                TBlobField(FDataLink.Field).SaveToFile(FTempFilePath+FRMITempFile);
  2613.                FMediaPlayer.Filename:=FTempFilePath+FRMITempFile;
  2614.                FMediaPlayer.Open;
  2615.                If FAutoPlayMM then
  2616.                  FMediaPlayer.Play;
  2617.                SetTimer(handle,1,500,nil);
  2618.             end;
  2619.          finally
  2620.             SetCursor(Cursor);
  2621.          end;
  2622.    end else
  2623.  
  2624.    If Temp = 'PNG' then begin
  2625.       Stream:=TMemoryStream.Create;
  2626.       Bitmap:=TBitmap.Create;
  2627.       try
  2628.        If FMediaPlayer <> nil then
  2629.          If FAutoMMHide then
  2630.            FMediaPlayer.Visible:=False;
  2631.          KillTimer(handle,1);
  2632.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  2633.          FreeMsg;
  2634.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  2635.          If not PNGblob(Stream.Memory,Stream.Size, ReadRes, Dith, Bitmap, TPDBMultiMediaCallBack) then begin
  2636.             MessageDlg('Invallid or empty PNG blobfield', mtInformation, [mbOk], 0);
  2637.             Picture.Assign(Nil);
  2638.          end else
  2639.             Picture.Assign(Bitmap);
  2640.          finally
  2641.             SetCursor(Cursor);
  2642.             Bitmap.free;
  2643.             Stream.Free;
  2644.          end;
  2645.    end else
  2646.  
  2647.    If Temp = 'GIF' then begin
  2648.       Stream:=TMemoryStream.Create;
  2649.       Bitmap:=TBitmap.Create;
  2650.       try
  2651.        If FMediaPlayer <> nil then
  2652.          If FAutoMMHide then
  2653.            FMediaPlayer.Visible:=False;
  2654.          KillTimer(handle,1);
  2655.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  2656.          FreeMsg;
  2657.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  2658.          If not GIFblob(Stream.Memory, Stream.Size, ReadRes, Dith, Bitmap, TPDBMultiMediaCallBack) then begin
  2659.             MessageDlg('Invallid or empty GIF blobfield', mtInformation, [mbOk], 0);
  2660.             Picture.Assign(Nil);
  2661.          end else
  2662.             Picture.Assign(Bitmap);
  2663.          finally
  2664.             SetCursor(Cursor);
  2665.             Bitmap.free;
  2666.             Stream.Free;
  2667.          end;
  2668.    end else
  2669.  
  2670.    If Temp = 'PCX' then begin
  2671.       Stream:=TMemoryStream.Create;
  2672.       Bitmap:=TBitmap.Create;
  2673.       try
  2674.        If FMediaPlayer <> nil then
  2675.          If FAutoMMHide then
  2676.            FMediaPlayer.Visible:=False;
  2677.          KillTimer(handle,1);
  2678.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  2679.          FreeMsg;
  2680.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  2681.          If not PCXblob(Stream.Memory, Stream.Size, ReadRes, Dith, Bitmap, TPDBMultiMediaCallBack) then begin
  2682.             MessageDlg('Invallid or empty PCX blobfield', mtInformation, [mbOk], 0);
  2683.             Picture.Assign(Nil);
  2684.          end else
  2685.             Picture.Assign(Bitmap);
  2686.          finally
  2687.           SetCursor(Cursor);
  2688.           Bitmap.free;
  2689.           Stream.Free;
  2690.          end;
  2691.    end else
  2692.  
  2693.    If Temp = 'BMP' then begin
  2694.       Stream:=TMemoryStream.Create;
  2695.       Bitmap:=TBitmap.Create;
  2696.       try
  2697.        If FMediaPlayer <> nil then
  2698.          If FAutoMMHide then
  2699.            FMediaPlayer.Visible:=False;
  2700.          KillTimer(handle,1);
  2701.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  2702.          FreeMsg;
  2703.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  2704.          If not BMPblob(Stream.Memory, Stream.Size, ReadRes, Dith, Bitmap, TPDBMultiMediaCallBack) then begin
  2705.             MessageDlg('Invallid or empty BMP blobfield', mtInformation, [mbOk], 0);
  2706.             Picture.Assign(Nil);
  2707.          end else
  2708.             Picture.Assign(Bitmap);
  2709.          finally
  2710.           SetCursor(Cursor);
  2711.           Bitmap.free;
  2712.           Stream.Free;
  2713.          end;
  2714.    end else
  2715.  
  2716.    If Temp = 'JPG' then begin
  2717.       Stream:=TMemoryStream.Create;
  2718.       Bitmap:=TBitmap.Create;
  2719.       try
  2720.        If FMediaPlayer <> nil then
  2721.          If FAutoMMHide then
  2722.            FMediaPlayer.Visible:=False;
  2723.          KillTimer(handle,1);
  2724.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  2725.          FreeMsg;
  2726.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  2727.          If not JPGblob(Stream.Memory,Stream.Size, ReadRes, Dith, Bitmap, TPDBMultiMediaCallBack) then begin
  2728.             MessageDlg('Invallid or empty Jpeg Blobfield', mtInformation, [mbOk], 0);
  2729.             Picture.Assign(Nil);
  2730.          end else
  2731.              Picture.Assign(Bitmap);
  2732.          finally
  2733.              SetCursor(Cursor);
  2734.              Bitmap.free;
  2735.              Stream.Free;
  2736.          end;
  2737.     end else
  2738.      KillTimer(handle,1);
  2739.     {GetInfoAndType;}
  2740.  end;
  2741. end;
  2742. {------------------------------------------------------------------------}
  2743.  
  2744. procedure TPDBMultiMedia.DataChange(Sender: TObject);
  2745. begin
  2746.   If CMessageRunning then FreeMsg;
  2747.   If MessageRunning then FreeMsg;
  2748.   Picture.Graphic := nil;
  2749.   FPictureLoaded := False;
  2750.   If FAutoDisplay then LoadMedia;
  2751. end;
  2752. {------------------------------------------------------------------------}
  2753.  
  2754. procedure TPDBMultiMedia.SetUpdateAsJPG(Value: Boolean);
  2755. begin
  2756.     FUpdateAsJPG:=True;
  2757.     FUpdateAsBMP:=False;
  2758.     FUpdateAsGIF:=False;
  2759.     FUpdateAsPCX:=False;
  2760.     FUpdateAsPNG:=False;
  2761. end;
  2762. {------------------------------------------------------------------------}
  2763.  
  2764. procedure TPDBMultiMedia.SetUpdateAsGIF(Value: Boolean);
  2765. begin
  2766.     FUpdateAsJPG:=False;
  2767.     FUpdateAsBMP:=False;
  2768.     FUpdateAsGIF:=True;
  2769.     FUpdateAsPCX:=False;
  2770.     FUpdateAsPNG:=False;
  2771. end;
  2772. {------------------------------------------------------------------------}
  2773.  
  2774. procedure TPDBMultiMedia.SetUpdateAsPCX(Value: Boolean);
  2775. begin
  2776.     FUpdateAsJPG:=False;
  2777.     FUpdateAsBMP:=False;
  2778.     FUpdateAsGIF:=False;
  2779.     FUpdateAsPCX:=True;
  2780.     FUpdateAsPNG:=False;
  2781. end;
  2782. {------------------------------------------------------------------------}
  2783.  
  2784. procedure TPDBMultiMedia.SetUpdateAsBMP(Value: Boolean);
  2785. begin
  2786.     FUpdateAsJPG:=False;
  2787.     FUpdateAsBMP:=True;
  2788.     FUpdateAsGIF:=False;
  2789.     FUpdateAsPCX:=False;
  2790.     FUpdateAsPNG:=False;
  2791. end;
  2792. {------------------------------------------------------------------------}
  2793.  
  2794. procedure TPDBMultiMedia.SetUpdateAsPNG(Value: Boolean);
  2795. begin
  2796.     FUpdateAsJPG:=False;
  2797.     FUpdateAsBMP:=False;
  2798.     FUpdateAsGIF:=False;
  2799.     FUpdateAsPCX:=False;
  2800.     FUpdateAsPNG:=True;
  2801. end;
  2802. {------------------------------------------------------------------------}
  2803.  
  2804. procedure TPDBMultiMedia.UpdateData(Sender: TObject);
  2805. var
  2806.    Stream       :  TMemoryStream;
  2807.    Cursor       :  hCursor;
  2808.    Usize        :  Longint;
  2809.    x,y          :  Longint;
  2810.    p            :  Pointer;
  2811.    WriteRes     :  Integer;
  2812.    InterL       :  Byte;
  2813. begin
  2814.   If FDataLink.Field is TBlobField then begin
  2815.  
  2816.     If Picture.Graphic is TBitmap then begin
  2817.       x:=Picture.Bitmap.Width;
  2818.       y:=Picture.Bitmap.Height;
  2819.  
  2820.       y:=y+(y div 5);
  2821.       x:=x+(x div 5);
  2822.  
  2823.       Usize:=(y * x);
  2824.  
  2825.       If Usize < 90000 then Usize:=Usize*2;
  2826.  
  2827.       {Since we can't know how much memory we need to allocate
  2828.       to write the picture to the stream we need to guess it. This
  2829.       is done using the width and height of the Bitmap. After the call
  2830.       to the dll using PUTJPGBLOB or PUTBMPBLOB Usize contains the
  2831.       correct size of the Bitmap stored in P^. You can increase or decrease
  2832.       the guessed memory by altering the Div by. For instance
  2833.  
  2834.       y:=y+(y div 3);
  2835.       x:=x+(x div 3);
  2836.  
  2837.       will allocate more memory then
  2838.  
  2839.       y:=y+(y div 6);
  2840.       x:=x+(x div 6);
  2841.  
  2842.       We played it on the save side. Use this "guess work" very carefully}
  2843.  
  2844.  
  2845.       P := GlobalAllocPtr(HeapAllocFlags, Usize);
  2846.       If P = Nil then
  2847.         Exit;
  2848.  
  2849.       If FWriteResolution = Color16 then WriteRes := 4;
  2850.       If FWriteResolution = Color256 then WriteRes := 8;
  2851.       If FWriteResolution = ColorTrue then WriteRes := 24;
  2852.  
  2853.       If FInterlaced then InterL :=1 else InterL :=0;
  2854.  
  2855.       If FUpdateAsJPG then
  2856.          If not putJPGblob(P, USize, FSaveQuality, FSaveSmooth, Picture.Bitmap, TPDBMultiImageCallBack) then
  2857.            MessageDlg('Jpeg BLOB Write Error', mtInformation, [mbOk], 0);
  2858.  
  2859.       If FUpdateAsBMP then
  2860.          If not putBMPblob(P, USize, WriteRes, Picture.Bitmap, TPDBMultiImageCallBack) then
  2861.            MessageDlg('BMP BLOB Write Error', mtInformation, [mbOk], 0);
  2862.  
  2863.       If FUpdateAsPCX then
  2864.          If not putPCXblob(P, USize, WriteRes, Picture.Bitmap, TPDBMultiImageCallBack) then
  2865.            MessageDlg('PCX BLOB Write Error', mtInformation, [mbOk], 0);
  2866.  
  2867.       If FUpdateAsGIF then
  2868.          If not putGIFblob(P, USize, WriteRes, Picture.Bitmap, TPDBMultiImageCallBack) then
  2869.            MessageDlg('GIF BLOB Write Error', mtInformation, [mbOk], 0);
  2870.  
  2871.       If FUpdateAsPNG then
  2872.          If not putPNGblob(P, USize, WriteRes, InterL, Picture.Bitmap, TPDBMultiImageCallBack) then
  2873.            MessageDlg('PNG BLOB Write Error', mtInformation, [mbOk], 0);
  2874.  
  2875.       Stream:=TMemoryStream.Create;
  2876.       Stream.Write(P^,USize);
  2877.       GlobalFreePtr(P);
  2878.  
  2879.       try
  2880.         TBlobField(FDataLink.Field).LoadFromStream(Stream);
  2881.       finally
  2882.         Stream.Free;
  2883.       end;
  2884.  
  2885.     end else
  2886.       TBlobField(FDataLink.Field).Clear;
  2887.    end;
  2888.    GetInfoAndType;
  2889. end;
  2890. {------------------------------------------------------------------------}
  2891.  
  2892. procedure TPDBMultiMedia.CopyToClipboard;
  2893. begin
  2894.   If Picture.Graphic <> nil then Clipboard.Assign(Picture);
  2895. end;
  2896. {------------------------------------------------------------------------}
  2897.  
  2898. procedure TPDBMultiMedia.CutToClipboard;
  2899. begin
  2900.   If Picture.Graphic <> nil then
  2901.   begin
  2902.     CopyToClipboard;
  2903.     If FDataLink.Edit then
  2904.       Picture.Graphic := nil;
  2905.   end;
  2906. end;
  2907. {------------------------------------------------------------------------}
  2908.  
  2909. procedure TPDBMultiMedia.PasteFromClipboard;
  2910. begin
  2911.   If Clipboard.HasFormat(CF_PICTURE) and FDataLink.Edit then begin
  2912.     MessageRunning:=False;
  2913.     CMessageRunning:=False;
  2914.     Picture.Assign(Clipboard);
  2915.    end;
  2916. end;
  2917. {------------------------------------------------------------------------}
  2918.  
  2919. procedure TPDBMultiMedia.CreateParams(var Params: TCreateParams);
  2920. begin
  2921.   inherited CreateParams(Params);
  2922.   If FBorderStyle = bsSingle then
  2923.     Params.Style := Params.Style or WS_BORDER;
  2924. end;
  2925. {------------------------------------------------------------------------}
  2926.  
  2927. procedure TPDBMultiMedia.KeyDown(var Key: Word; Shift: TShiftState);
  2928. begin
  2929.   inherited KeyDown(Key, Shift);
  2930.   case Key of
  2931.     VK_INSERT:
  2932.       If ssShift in Shift then PasteFromClipBoard else
  2933.         If ssCtrl in Shift then CopyToClipBoard;
  2934.     VK_DELETE:
  2935.       If ssShift in Shift then CutToClipBoard;
  2936.   end;
  2937. end;
  2938. {------------------------------------------------------------------------}
  2939.  
  2940. procedure TPDBMultiMedia.KeyPress(var Key: Char);
  2941. begin
  2942.   inherited KeyPress(Key);
  2943.   case Key of
  2944.     ^X: CutToClipBoard;
  2945.     ^C: CopyToClipBoard;
  2946.     ^V: PasteFromClipBoard;
  2947.     #13: LoadMedia;
  2948.     #27: FDataLink.Reset;
  2949.   end;
  2950. end;
  2951. {------------------------------------------------------------------------}
  2952.  
  2953. procedure TPDBMultiMedia.CMEnter(var Message: TCMEnter);
  2954. begin
  2955.   Invalidate; { Draw the focus marker }
  2956.   inherited;
  2957. end;
  2958. {------------------------------------------------------------------------}
  2959.  
  2960. procedure TPDBMultiMedia.CMExit(var Message: TCMExit);
  2961. begin
  2962.   Invalidate; { Erase the focus marker }
  2963.   inherited;
  2964. end;
  2965. {------------------------------------------------------------------------}
  2966.  
  2967. procedure TPDBMultiMedia.CMTextChanged(var Message: TMessage);
  2968. begin
  2969.   inherited;
  2970.   If not FPictureLoaded then Invalidate;
  2971. end;
  2972. {------------------------------------------------------------------------}
  2973.  
  2974. procedure TPDBMultiMedia.WMLButtonDown(var Message: TWMLButtonDown);
  2975. begin
  2976.   If TabStop and CanFocus then SetFocus;
  2977.   inherited;
  2978. end;
  2979. {------------------------------------------------------------------------}
  2980.  
  2981. procedure TPDBMultiMedia.WMLButtonDblClk(var Message: TWMLButtonDblClk);
  2982. begin
  2983.   LoadMedia;
  2984.   inherited;
  2985. end;
  2986. {------------------------------------------------------------------------}
  2987.  
  2988. procedure TPDBMultiMedia.WMCut(var Message: TMessage);
  2989. begin
  2990.   CutToClipboard;
  2991. end;
  2992. {------------------------------------------------------------------------}
  2993.  
  2994. procedure TPDBMultiMedia.WMCopy(var Message: TMessage);
  2995. begin
  2996.   CopyToClipboard;
  2997. end;
  2998. {------------------------------------------------------------------------}
  2999.  
  3000. procedure TPDBMultiMedia.WMPaste(var Message: TMessage);
  3001. begin
  3002.   PasteFromClipboard;
  3003. end;
  3004. {------------------------------------------------------------------------}
  3005.  
  3006. procedure TPDBMultiMedia.LoadFromFile(Filename : TFilename);
  3007. var
  3008.    Cursor       :  hCursor;
  3009. begin
  3010.  
  3011.   If not FileExists(Filename) then begin
  3012.     MessageDlg('File not found', mtInformation, [mbOk], 0);
  3013.     Exit;
  3014.   end;
  3015.  
  3016.   If UpperCase(ExtractFileExt(Filename)) <> '.JPG' then
  3017.   If UpperCase(ExtractFileExt(Filename)) <> '.PNG' then
  3018.   If UpperCase(ExtractFileExt(Filename)) <> '.GIF' then
  3019.   If UpperCase(ExtractFileExt(Filename)) <> '.PCX' then
  3020.   If UpperCase(ExtractFileExt(Filename)) <> '.BMP' then
  3021.   If UpperCase(ExtractFileExt(Filename)) <> '.WAV' then
  3022.   If UpperCase(ExtractFileExt(Filename)) <> '.AVI' then
  3023.   If UpperCase(ExtractFileExt(Filename)) <> '.MOV' then
  3024.   If UpperCase(ExtractFileExt(Filename)) <> '.MID' then
  3025.   If UpperCase(ExtractFileExt(Filename)) <> '.RMI' then
  3026.   If UpperCase(ExtractFileExt(Filename)) <> '.SCM' then
  3027.   If UpperCase(ExtractFileExt(Filename)) <> '.CMS' then
  3028.   {If UpperCase(ExtractFileExt(Filename)) <> '.MPG' then}
  3029.   begin
  3030.     MessageDlg('A None Supported File Format', mtInformation, [mbOk], 0);
  3031.     Exit;
  3032.   end;
  3033.  
  3034.   If FDataLink.Field is TBlobField then begin
  3035.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  3036.     TBlobField(FDataLink.Field).LoadFromFile(Filename);
  3037.     SetCursor(Cursor);
  3038.   end else begin
  3039.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  3040.     Exit;
  3041.   end;
  3042.   {GetInfoAndType;}
  3043.   SetCursor(Cursor);
  3044. end;
  3045. {------------------------------------------------------------------------}
  3046.  
  3047. procedure TPDBMultiMedia.SaveToFile(Filename : TFilename);
  3048. var
  3049.   Cursor       :  hCursor;
  3050. begin
  3051.   If FDataLink.Field is TBlobField then begin
  3052.  
  3053.     If TBlobField(FDataLink.Field).IsNull then begin
  3054.        MessageDlg('Can''t save, blobfield is empty', mtInformation, [mbOk], 0);
  3055.        Exit;
  3056.     end;
  3057.  
  3058.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  3059.     TBlobField(FDataLink.Field).SaveToFile(Filename);
  3060.     GetInfoAndType;
  3061.     SetCursor(Cursor)
  3062.  
  3063.   end else begin
  3064.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  3065.     Exit;
  3066.   end;
  3067. end;
  3068. {------------------------------------------------------------------------}
  3069.  
  3070. procedure TPDBMultiMedia.SaveToFileAsBMP(Filename : TFilename);
  3071. var
  3072.   Cursor       :  hCursor;
  3073.   WriteRes     :  Integer;
  3074. begin
  3075.   If FDataLink.Field is TBlobField then begin
  3076.  
  3077.     If TBlobField(FDataLink.Field).IsNull then begin
  3078.        MessageDlg('Can''t save, blobfield Bitmap is empty', mtInformation, [mbOk], 0);
  3079.        Exit;
  3080.     end;
  3081.  
  3082.     If picture.Bitmap.empty then begin
  3083.        MessageDlg('Can''t save, image is not displayed, Set Autodisplay or double click display to view image first.',
  3084.                   mtInformation, [mbOk], 0);
  3085.        Exit;
  3086.     end;
  3087.  
  3088.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  3089.  
  3090.     If FWriteResolution = Color16 then WriteRes := 4;
  3091.     If FWriteResolution = Color256 then WriteRes := 8;
  3092.     If FWriteResolution = ColorTrue then WriteRes := 24;
  3093.  
  3094.     If not putBMPfile(Filename, WriteRes, Picture.Bitmap, TPDBMultiImageCallBack) then begin
  3095.       SetCursor(Cursor);
  3096.       MessageDlg('Writing BMP file failed', mtInformation, [mbOk], 0);
  3097.       Exit;
  3098.     end;
  3099.  
  3100.     GetInfoAndType
  3101.  
  3102.   end else begin
  3103.     SetCursor(Cursor);
  3104.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  3105.     Exit;
  3106.   end;
  3107.  
  3108.   SetCursor(Cursor);
  3109. end;
  3110. {------------------------------------------------------------------------}
  3111.  
  3112. procedure TPDBMultiMedia.SaveToFileAsGIF(Filename : TFilename);
  3113. var
  3114.   Cursor       :  hCursor;
  3115.   WriteRes     :  Integer;
  3116. begin
  3117.   If FDataLink.Field is TBlobField then begin
  3118.  
  3119.     If TBlobField(FDataLink.Field).IsNull then begin
  3120.        MessageDlg('Can''t save, blobfield Bitmap is empty', mtInformation, [mbOk], 0);
  3121.        Exit;
  3122.     end;
  3123.  
  3124.     If picture.Bitmap.empty then begin
  3125.        MessageDlg('Can''t save, image is not displayed, Set Autodisplay or double click display to view image first.',
  3126.                   mtInformation, [mbOk], 0);
  3127.        Exit;
  3128.     end;
  3129.  
  3130.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  3131.  
  3132.     If FWriteResolution = Color16 then WriteRes := 4;
  3133.     If FWriteResolution = Color256 then WriteRes := 8;
  3134.     If FWriteResolution = ColorTrue then WriteRes := 24;
  3135.  
  3136.     If not putGIFfile(Filename, WriteRes, Picture.Bitmap, TPDBMultiImageCallBack) then begin
  3137.       SetCursor(Cursor);
  3138.       MessageDlg('Writing GIF file failed', mtInformation, [mbOk], 0);
  3139.       Exit;
  3140.     end;
  3141.  
  3142.     GetInfoAndType
  3143.  
  3144.   end else begin
  3145.     SetCursor(Cursor);
  3146.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  3147.     Exit;
  3148.   end;
  3149.  
  3150.   SetCursor(Cursor);
  3151. end;
  3152. {------------------------------------------------------------------------}
  3153.  
  3154. procedure TPDBMultiMedia.SaveToFileAsPCX(Filename : TFilename);
  3155. var
  3156.   Cursor       :  hCursor;
  3157.   WriteRes     :  Integer;
  3158. begin
  3159.   If FDataLink.Field is TBlobField then begin
  3160.  
  3161.     If TBlobField(FDataLink.Field).IsNull then begin
  3162.        MessageDlg('Can''t save, blobfield Bitmap is empty', mtInformation, [mbOk], 0);
  3163.        Exit;
  3164.     end;
  3165.  
  3166.     If picture.Bitmap.empty then begin
  3167.        MessageDlg('Can''t save, image is not displayed, Set Autodisplay or double click display to view image first.',
  3168.                   mtInformation, [mbOk], 0);
  3169.        Exit;
  3170.     end;
  3171.  
  3172.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  3173.  
  3174.     If FWriteResolution = Color16 then WriteRes := 4;
  3175.     If FWriteResolution = Color256 then WriteRes := 8;
  3176.     If FWriteResolution = ColorTrue then WriteRes := 24;
  3177.  
  3178.     If not putPCXfile(Filename, WriteRes, Picture.Bitmap, TPDBMultiImageCallBack) then begin
  3179.       SetCursor(Cursor);
  3180.       MessageDlg('Writing PCX file failed', mtInformation, [mbOk], 0);
  3181.       Exit;
  3182.     end;
  3183.  
  3184.     GetInfoAndType
  3185.  
  3186.   end else begin
  3187.     SetCursor(Cursor);
  3188.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  3189.     Exit;
  3190.   end;
  3191.  
  3192.   SetCursor(Cursor);
  3193. end;
  3194. {------------------------------------------------------------------------}
  3195.  
  3196. procedure TPDBMultiMedia.SaveToFileAsPNG(Filename : TFilename);
  3197. var
  3198.   Cursor       :  hCursor;
  3199.   WriteRes     :  Integer;
  3200.   InterL       :  Byte;
  3201. begin
  3202.   If FDataLink.Field is TBlobField then begin
  3203.  
  3204.     If TBlobField(FDataLink.Field).IsNull then begin
  3205.        MessageDlg('Can''t save, blobfield Bitmap is empty', mtInformation, [mbOk], 0);
  3206.        Exit;
  3207.     end;
  3208.  
  3209.     If picture.Bitmap.empty then begin
  3210.        MessageDlg('Can''t save, image is not displayed, Set Autodisplay or double click display to view image first.',
  3211.                   mtInformation, [mbOk], 0);
  3212.        Exit;
  3213.     end;
  3214.  
  3215.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  3216.  
  3217.     If FWriteResolution = Color16 then WriteRes := 4;
  3218.     If FWriteResolution = Color256 then WriteRes := 8;
  3219.     If FWriteResolution = ColorTrue then WriteRes := 24;
  3220.     If FInterlaced then InterL :=1 else InterL :=0;
  3221.  
  3222.     If not putPNGfile(Filename, WriteRes, Interl, Picture.Bitmap, TPDBMultiImageCallBack) then begin
  3223.       SetCursor(Cursor);
  3224.       MessageDlg('Writing PNG file failed', mtInformation, [mbOk], 0);
  3225.       Exit;
  3226.     end;
  3227.  
  3228.     GetInfoAndType
  3229.  
  3230.   end else begin
  3231.     SetCursor(Cursor);
  3232.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  3233.     Exit;
  3234.   end;
  3235.  
  3236.   SetCursor(Cursor);
  3237. end;
  3238. {------------------------------------------------------------------------}
  3239.  
  3240. procedure TPDBMultiMedia.SaveToFileAsJPG(Filename : TFilename);
  3241. var
  3242.   Cursor       :  hCursor;
  3243. begin
  3244.   If FDataLink.Field is TBlobField then begin
  3245.  
  3246.     If TBlobField(FDataLink.Field).IsNull then begin
  3247.        MessageDlg('Can''t save, blobfield Bitmap is empty', mtInformation, [mbOk], 0);
  3248.        Exit;
  3249.     end;
  3250.  
  3251.     If picture.Bitmap = nil then begin
  3252.        MessageDlg('Can''t save, image is not displayed', mtInformation, [mbOk], 0);
  3253.        Exit;
  3254.     end;
  3255.  
  3256.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  3257.  
  3258.     If not putJPGfile(Filename, FSaveQuality, FSaveSmooth, picture.Bitmap, TPDBMultiImageCallBack) then begin
  3259.       SetCursor(Cursor);
  3260.       MessageDlg('Writing JPG file failed', mtInformation, [mbOk], 0);
  3261.       Exit;
  3262.     end;
  3263.  
  3264.     GetInfoAndType
  3265.  
  3266.   end else begin
  3267.     SetCursor(Cursor);
  3268.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  3269.     Exit;
  3270.   end;
  3271.  
  3272.   SetCursor(Cursor);
  3273. end;
  3274. {------------------------------------------------------------------------}
  3275.  
  3276.  
  3277. function TPDBMultiMedia.GetInfoAndType : String;
  3278. var
  3279.  Stream       :  TMemoryStream;
  3280.  Hdr          :  Array[0..45] of char;
  3281.  i            :  Byte;
  3282. begin
  3283.   If (FDataLink.Field is TBlobField) then
  3284.    If TBlobField(FDataLink.Field).IsNull then Exit;
  3285.  
  3286.    BFileType := 'Empty';
  3287.    Bwidth:=-1;
  3288.    BHeight:=-1;
  3289.    Bbitspixel:=-1;
  3290.    Bplanes:=-1;
  3291.    Bnumcolors:=-1;
  3292.    Bcompression:='-1';
  3293.    BSize:=-1;
  3294.    GetInfoAndType :='-1';
  3295.  
  3296.    Stream:=TMemoryStream.Create;
  3297.    TBlobField(FDataLink.Field).SaveToStream(Stream);
  3298.  
  3299.    If Stream.Memory = nil then begin
  3300.      MessageDlg('Error allocation Temporary blob memory', mtInformation, [mbOk], 0);
  3301.      Exit;
  3302.    end;
  3303.  
  3304.    Stream.Seek(0,0);
  3305.    Stream.read(hdr,SizeOf(Hdr)-1);
  3306.  
  3307.    for i:=0 to SizeOf(hdr)-1 do
  3308.     If hdr[i] = #0 then hdr[i]:=' ';
  3309.  
  3310.    If StrPos(hdr,'RIFF') <> nil then begin
  3311.         Bwidth:=-1;
  3312.         BHeight:=-1;
  3313.         Bbitspixel:=-1;
  3314.         Bplanes:=-1;
  3315.         Bnumcolors:=-1;
  3316.         Bcompression:='RIFF';
  3317.  
  3318.      If StrPos(hdr,'WAV') <> nil then begin
  3319.         BSize:=Stream.Size;
  3320.         BFileType:= 'WAV';
  3321.         GetInfoAndType:='WAV';
  3322.      end;
  3323.  
  3324.      If StrPos(hdr,'AVI') <> nil then begin
  3325.         BSize:=Stream.Size;
  3326.         BFileType:= 'AVI';
  3327.         GetInfoAndType:='AVI';
  3328.      end;
  3329.  
  3330.      If StrPos(hdr,'RMID') <> nil then begin
  3331.         BSize:=Stream.Size;
  3332.         BFileType:= 'RMI';
  3333.         GetInfoAndType:='RMI';
  3334.      end;
  3335.  
  3336.      If Stream.Memory <> nil then Stream.Free;
  3337.      Exit;
  3338.    end else
  3339.  
  3340. {   If StrPos(hdr,'mpeg') <> nil then begin
  3341.         Bwidth:=-1;
  3342.         BHeight:=-1;
  3343.         Bbitspixel:=-1;
  3344.         Bplanes:=-1;
  3345.         Bnumcolors:=-1;
  3346.         Bcompression:='MPEG';
  3347.         BSize:=Stream.Size;
  3348.         BFileType:= 'MPG';
  3349.         GetInfoAndType:='MPG';
  3350.         If Stream.Memory <> nil then Stream.Free;
  3351.         Exit;
  3352.    end else}
  3353.  
  3354.    If StrPos(hdr,'mdat') <> nil then begin
  3355.         Bwidth:=-1;
  3356.         BHeight:=-1;
  3357.         Bbitspixel:=-1;
  3358.         Bplanes:=-1;
  3359.         Bnumcolors:=-1;
  3360.         Bcompression:='QTM';
  3361.         BSize:=Stream.Size;
  3362.         BFileType:= 'MOV';
  3363.         GetInfoAndType:='MOV';
  3364.         If Stream.Memory <> nil then Stream.Free;
  3365.         Exit;
  3366.    end else
  3367.  
  3368.    If StrPos(hdr,'MThd') <> nil then begin
  3369.         Bwidth:=-1;
  3370.         BHeight:=-1;
  3371.         Bbitspixel:=-1;
  3372.         Bplanes:=-1;
  3373.         Bnumcolors:=-1;
  3374.         Bcompression:='MIDI';
  3375.         BSize:=Stream.Size;
  3376.         BFileType:= 'MID';
  3377.         GetInfoAndType:='MID';
  3378.         If Stream.Memory <> nil then Stream.Free;
  3379.         Exit;
  3380.      end else
  3381.  
  3382.    If StrPos(hdr,'kevinjan') <> nil then begin
  3383.         Bwidth:=-1;
  3384.         BHeight:=-1;
  3385.         Bbitspixel:=-1;
  3386.         Bplanes:=-1;
  3387.         Bnumcolors:=-1;
  3388.         Bcompression:='MSG';
  3389.         BSize:=Stream.Size;
  3390.         BFileType:= 'SCM';
  3391.         GetInfoAndType:='SCM';
  3392.         If Stream.Memory <> nil then Stream.Free;
  3393.         Exit;
  3394.      end else
  3395.  
  3396.    If StrPos(hdr,'jankevin') <> nil then begin
  3397.         Bwidth:=-1;
  3398.         BHeight:=-1;
  3399.         Bbitspixel:=-1;
  3400.         Bplanes:=-1;
  3401.         Bnumcolors:=-1;
  3402.         Bcompression:='MSG';
  3403.         BSize:=Stream.Size;
  3404.         BFileType:= 'CMS';
  3405.         GetInfoAndType:='CMS';
  3406.         If Stream.Memory <> nil then Stream.Free;
  3407.         Exit;
  3408.      end else
  3409.  
  3410.  If not GetBlobInfo(Stream.Memory,
  3411.                     Stream.Size,
  3412.                     BFileType,
  3413.                     Bwidth,
  3414.                     BHeight,
  3415.                     Bbitspixel,
  3416.                     Bplanes,
  3417.                     Bnumcolors,
  3418.                     Bcompression) then
  3419.        MessageDlg('blobfield getinfo failed', mtInformation, [mbOk], 0)
  3420.     else begin
  3421.        BSize:=Stream.Size;
  3422.        If UpperCase(BFileType) = 'PNG' then GetInfoAndType:='PNG' else
  3423.        If UpperCase(BFileType) = 'GIF' then GetInfoAndType:='GIF' else
  3424.        If UpperCase(BFileType) = 'PCX' then GetInfoAndType:='PCX' else
  3425.        If UpperCase(BFileType) = 'JPEG' then GetInfoAndType:='JPG' else
  3426.        If UpperCase(BFileType) = 'BMP' then GetInfoAndType:='BMP';
  3427.     end;
  3428.   If Stream.Memory <> nil then Stream.Free;
  3429. end;
  3430. {------------------------------------------------------------------------}
  3431.  
  3432. function TPDBMultiMedia.GetSmooth : Byte;
  3433. begin
  3434.   GetSmooth:=FSaveSmooth;
  3435. end;
  3436. {------------------------------------------------------------------------}
  3437.  
  3438. procedure TPDBMultiMedia.SetSmooth(Smooth : Byte);
  3439. begin
  3440.   If (Smooth > 100) or (Smooth < 0) then FSaveSmooth:=5 else
  3441.    FSaveSmooth:=Smooth;
  3442. end;
  3443. {------------------------------------------------------------------------}
  3444.  
  3445. function TPDBMultiMedia.GetQuality : Byte;
  3446. begin
  3447.   GetQuality:=FSaveQuality;
  3448. end;
  3449. {------------------------------------------------------------------------}
  3450.  
  3451. procedure TPDBMultiMedia.SetQuality(Quality : Byte);
  3452. begin
  3453.   If (Quality > 100) or (Quality < 1) then FSaveQuality:=25 else
  3454.    FSaveQuality:=Quality;
  3455. end;
  3456. {------------------------------------------------------------------------}
  3457.  
  3458.  
  3459. function TPDBMultiMedia.GetTempPath : String;
  3460. begin
  3461.   GetTempPath:=FTempFilePath;
  3462. end;
  3463. {------------------------------------------------------------------------}
  3464.  
  3465. procedure TPDBMultiMedia.SetTempPath(Temppath : String);
  3466. var
  3467.  Temp, OldDir : String;
  3468. begin
  3469.   Temp:=AddBackSlash(TempPath);
  3470.   GetDir(0,OldDir);
  3471.  
  3472.   {$I-}
  3473.    ChDir(Temp);
  3474.    If IOResult <> 0 then Temp:='C:\';
  3475.   {$I+}
  3476.  
  3477.   ChDir(OldDir);
  3478.   FTempFilePath:=Temp;
  3479. end;
  3480. {------------------------------------------------------------------------}
  3481.  
  3482. procedure TPDBMultiMedia.SetReadRes(Res : TResolution);
  3483. begin
  3484.   FReadResolution := Res;
  3485. end;
  3486. {------------------------------------------------------------------------}
  3487.  
  3488. procedure TPDBMultiMedia.SetWriteRes(Res : TResolution);
  3489. begin
  3490.   FWriteResolution := Res;
  3491. end;
  3492. {------------------------------------------------------------------------}
  3493.  
  3494. function TPDBMultiMedia.GetMediaPlayer: TPDBMediaPlayer;
  3495. begin
  3496.  Result:=FMediaPlayer;
  3497. end;
  3498. {------------------------------------------------------------------------}
  3499.  
  3500. procedure TPDBMultiMedia.SetMediaPlayer(Value: TPDBMediaPlayer);
  3501. begin
  3502.   FMediaPlayer:=Value;
  3503. end;
  3504. {------------------------------------------------------------------------}
  3505.  
  3506. function TPDBMultiMedia.AddBackSlash(DirName : String) : String;
  3507. const
  3508.   DosDelimSet : set of Char = ['\', ':', #0];
  3509.   begin
  3510.     If DirName[Length(DirName)] in DosDelimSet then
  3511.       AddBackSlash := DirName
  3512.     else
  3513.       AddBackSlash := DirName+'\';
  3514.   end;
  3515. {------------------------------------------------------------------------}
  3516.  
  3517. function TPDBMultiMedia.IsValidMultiMedia(Name : PChar) : boolean;
  3518.  var
  3519.   Temp : Array[0..25] of char;
  3520. begin
  3521.    Result:=ValidMultiMedia(Name);
  3522. end;
  3523. {------------------------------------------------------------------------}
  3524.  
  3525. function TPDBMultiMedia.GetMultiMediaExtensions : String;
  3526. var
  3527.   Temp : String;
  3528. begin
  3529.   Temp:='All Media|*.BMP;*.GIF;*.PCX;*.JPG;*.SCM;*.PNG;*.CMS;';
  3530.  
  3531.   If IsValidMultiMedia('wav') then
  3532.     Temp:=Temp+'*.wav;';
  3533.   If IsValidMultiMedia('mid') then
  3534.     Temp:=Temp+'*.mid;';
  3535.   If IsValidMultiMedia('rmi') then
  3536.     Temp:=Temp+'*.rmi;';
  3537.   If IsValidMultiMedia('avi') then
  3538.     Temp:=Temp+'*.avi;';
  3539.   If IsValidMultiMedia('mov') then
  3540.     Temp:=Temp+'*.mov;';
  3541.  
  3542.   Temp:=Temp+'|BMP |*.BMP';
  3543.   Temp:=Temp+'|GIF |*.GIF';
  3544.   Temp:=Temp+'|JPG |*.JPG';
  3545.   Temp:=Temp+'|PCX |*.PCX';
  3546.   Temp:=Temp+'|SCM |*.SCM';
  3547.   Temp:=Temp+'|PNG |*.PNG';
  3548.   Temp:=Temp+'|CMS |*.CMS';
  3549.  
  3550.   If IsValidMultiMedia('wav') then
  3551.     Temp:=Temp+'|Wave|*.wav';
  3552.   If IsValidMultiMedia('mid') then
  3553.     Temp:=Temp+'|Midi|*.mid';
  3554.   If IsValidMultiMedia('rmi') then
  3555.     Temp:=Temp+'|RMI |*.rmi';
  3556.   If IsValidMultiMedia('avi') then
  3557.     Temp:=Temp+'|AVI |*.avi';
  3558.   If IsValidMultiMedia('mov') then
  3559.     Temp:=Temp+'|Movie|*.mov';
  3560.  
  3561.   Result:=Temp;
  3562. end;
  3563. {------------------------------------------------------------------------}
  3564.  
  3565. procedure TPDBMultiMedia.TimerNotify(var Message: TMessage);
  3566. var
  3567.   MPosition : Integer;
  3568. begin
  3569.  If FMediaPlayer = nil then Exit;
  3570.  
  3571.  If not AutoRePlayMultiMedia then
  3572.    If FMediaPlayer.Mode <> MpPlaying then Exit;
  3573.  
  3574.   MPosition:=Round(FMediaPlayer.Position * (100 / FMediaPlayer.length));
  3575.  
  3576.   If @TPDBMultiMediaCallBack <> nil then
  3577.    TPDBMultiMediaCallBack(MPosition);
  3578.  
  3579.   If (FAutoRePlayMM) and (MPosition >= 100) and (FMediaPlayer.Filename <> '') then
  3580.    FMediaPlayer.Play;
  3581.  
  3582. end;
  3583. {------------------------------------------------------------------------
  3584.  scrolling message stuff
  3585. ------------------------------------------------------------------------}
  3586.  
  3587. procedure TPDBMultiMedia.LoadMessageFromStream(MessageStream : TStream);
  3588. var
  3589.   Msg      : TLabel;
  3590. begin
  3591.   FreeMsg;
  3592.   ScreenWd:=Width;
  3593.   ScreenHt:=Height;
  3594.   Msg := TLabel.Create(Self);
  3595.   readmessagefromstream(MessageStream, MsgFont, MsgSpeed, MsgBkGrnd, MsgText);
  3596.   Refresh;
  3597.   If MsgText[Length(MsgText)] <> ' ' then MsgText:=MsgText+' ';
  3598.   Msg.Parent :=Self;
  3599.   Msg.Visible := False;
  3600.   Msg.Font := MsgFont;
  3601.   Msg.Caption := MsgText;
  3602.   BitWidth:=Msg.Width;
  3603.   SMessageLeft := ScreenWd;
  3604.   SMessageRight := ScreenWd + Msg.Width;
  3605.   SMessageTop := (ScreenHt - Msg.Height) Div 2;
  3606.   BitMsg.Width := Msg.Width;
  3607.   BitMsg.Height := Msg.Height;
  3608.   OldColor:=Color;
  3609.   Color:=MsgBkGrnd;
  3610.  
  3611.   with BitMsg.Canvas do begin
  3612.     Brush.Color := MsgBkGrnd;
  3613.     Font := Msg.Font;
  3614.     TextOut(0,0,Msg.Caption);
  3615.   end;
  3616.  
  3617.    Msg.Free;
  3618.    Msg := nil;
  3619.    MessageRunning:=True;
  3620. end;
  3621. {------------------------------------------------------------------------}
  3622.  
  3623. procedure TPDBMultiMedia.NewMessage;
  3624. var
  3625.   Msg      : TLabel;
  3626. begin
  3627.   FreeMsg;
  3628.   If MsgText = '' then Exit;
  3629.   If MsgText[Length(MsgText)] <> ' ' then MsgText:=MsgText+' ';
  3630.   ScreenWd:=Width;
  3631.   ScreenHt:=Height;
  3632.   Msg := TLabel.Create(Self);
  3633.   Refresh;
  3634.   Msg.Parent :=Self;
  3635.   Msg.Visible := False;
  3636.   Msg.Font := MsgFont;
  3637.   Msg.Caption := MsgText;
  3638.   BitWidth:=Msg.Width;
  3639.   SMessageLeft := ScreenWd;
  3640.   SMessageRight := ScreenWd + Msg.Width;
  3641.   SMessageTop := (ScreenHt - Msg.Height) Div 2;
  3642.   BitMsg.Width := Msg.Width;
  3643.   BitMsg.Height := Msg.Height;
  3644.   OldColor:=Color;
  3645.   Color:=MsgBkGrnd;
  3646.  
  3647.   with BitMsg.Canvas do begin
  3648.     Brush.Color := MsgBkGrnd;
  3649.     Font := Msg.Font;
  3650.     TextOut(0,0,Msg.Caption);
  3651.   end;
  3652.  
  3653.    Msg.Free;
  3654.    Msg := nil;
  3655.    MessageRunning:=True;
  3656. end;
  3657. {------------------------------------------------------------------------}
  3658.  
  3659. Function TPDBMultiMedia.CreateMessage : Boolean;
  3660. begin
  3661.  Result:=False;
  3662.  
  3663.  SetupMsg30:=TSetupMsg30.Create(Self);
  3664.  
  3665.  SetupMsg30.ShowModal;
  3666.  
  3667.  If SetupMsg30.ModalResult = mrOK then begin
  3668.   Result:=SaveMessageToStream(SetupMsg30.MessageFont,
  3669.                               SetupMsg30.MessageSpeed,
  3670.                               SetupMsg30.MessageColor,
  3671.                               SetupMsg30.MessageMsg);
  3672.  end;
  3673.  SetupMsg30.destroy;
  3674.  SetupMsg30:=Nil;
  3675. end;
  3676. {------------------------------------------------------------------------}
  3677.  
  3678. Procedure TPDBMultiMedia.FreeMsg;
  3679. Begin
  3680.   If MessageRunning then
  3681.    Color:=OldColor;
  3682.   If CMessageRunning then
  3683.    Color:=OldColor;
  3684.   CMessageRunning:=False;
  3685.   MessageRunning:=False;
  3686.   Picture.Assign(nil);
  3687. end;
  3688. {------------------------------------------------------------------------}
  3689.  
  3690. Function TPDBMultiMedia.Delay(Ms : Integer) : boolean;
  3691. Begin
  3692.  Inc(DelayCounter);
  3693.  If DelayCounter > MS then begin
  3694.   DelayCounter:=0;
  3695.   Result:=True;
  3696.  end else
  3697.   Result:=False;
  3698. end;
  3699. {------------------------------------------------------------------------}
  3700.  
  3701. Procedure TPDBMultiMedia.MoveMsg(Var WinMsg : TMessage);
  3702. Begin
  3703.   If Not MessageRunning then Exit;
  3704.   If Not Delay(MsgSpeed)then Exit;
  3705.   Dec(SMessageLeft,1);
  3706.   Dec(SMessageRight,1);
  3707.   Inc(MmsgCount,1);
  3708.   If SMessageRight < 0 then begin
  3709.     SMessageLeft := ScreenWd;
  3710.     SMessageRight := SMessageLeft + BitWidth;
  3711.   end;
  3712.     with Canvas do
  3713.        Draw(SMessageLeft,SMessageTop,BitMsg);
  3714. end;
  3715. {------------------------------------------------------------------------}
  3716.  
  3717. Procedure TPDBMultiMedia.Trigger;
  3718. Begin
  3719.   If SetupMsg30 <> nil then SetupMsg30.Trigger;
  3720.   If SetupCredMsg30 <> nil then SetupCredMsg30.Trigger;
  3721.  
  3722.   If (visible) and (enabled) then begin
  3723.    PostMessage(Handle, WM_Trigger, 0, 0);
  3724.    PostMessage(Handle, WM_CTrigger, 0, 0);
  3725.   end;
  3726. End;
  3727. {------------------------------------------------------------------------}
  3728.  
  3729. Function TPDBMultiMedia.SaveMessageToStream(MFont  : Tfont;
  3730.                                            Mspeed : Integer;
  3731.                                            MColor : Tcolor;
  3732.                                            MMsg   : String) : Boolean;
  3733. var
  3734.    Stream       :  TMemoryStream;
  3735.    Cursor       :  hCursor;
  3736.    Usize        :  Longint;
  3737.    P            :  Array[0..1602] of char;
  3738. begin
  3739.   Result:=True;
  3740.   If FDataLink.Field is TBlobField then begin
  3741.  
  3742.      If Length(MMsg) < 1 then
  3743.       begin
  3744.         Result:=False;
  3745.         Exit;
  3746.        end;
  3747.  
  3748.       Usize:=WriteMessageToStream(MFont, MSpeed, MColor, MMsg, P);
  3749.  
  3750.       If Usize < 1 then
  3751.        begin
  3752.         Result:=False;
  3753.         Exit;
  3754.        end;
  3755.  
  3756.       Stream:=TMemoryStream.Create;
  3757.       Stream.Write(P,Usize+1);
  3758.  
  3759.       try
  3760.         TBlobField(FDataLink.Field).LoadFromStream(Stream);
  3761.       finally
  3762.         Stream.Free;
  3763.       end;
  3764.      GetInfoAndType;
  3765.    end;
  3766. end;
  3767.  
  3768.  
  3769. {------------------------------------------------------------------------
  3770.  credit message stuff
  3771. ------------------------------------------------------------------------}
  3772.  
  3773. procedure TPDBMultiMedia.LoadCreditMessageFromStream(MessageStream : TStream);
  3774. var
  3775.   Msg      : TLabel;
  3776. begin
  3777.   Picture.Assign(nil);
  3778.   ReadCreditFromStream(MessageStream, MsgFont, MsgSpeed, MsgBkGrnd, CreditBoxList);
  3779.   Creditcounter:=0;
  3780.   If CreditBoxList.Count <1 then Exit;
  3781.   MsgText:=CreditBoxList.Strings[Creditcounter];
  3782.  
  3783.   If MsgText = '' then Exit;
  3784.   If MsgText[1] <> ' ' then MsgText:='  ' + MsgText;
  3785.   If MsgText[Length(MsgText)] <> ' ' then MsgText:=MsgText+' ';
  3786.  
  3787.   ScreenWd:=Width;
  3788.   ScreenHt:=Height;
  3789.   Refresh;
  3790.   Msg := TLabel.Create(Self);
  3791.   Refresh;
  3792.   Msg.Parent :=Self;
  3793.   Msg.Visible := False;
  3794.   Msg.Font := MsgFont;
  3795.   Msg.Caption := MsgText;
  3796.   Msg.Width:=Msg.Width+(Msg.Width div (Length(MsgText)-2));
  3797.   BitHeight:=Msg.Height;
  3798.   BitWidth:=Msg.Width;
  3799.   SMessageLeft :=(ScreenWd - Msg.Width) Div 2;
  3800.   SMessageTop := ScreenHt;
  3801.   SMessageBottom := SMessageTop + Msg.Height;
  3802.  
  3803.   BitMsg.Width := Msg.Width;
  3804.   BitMsg.Height := Msg.Height+5;
  3805.   OldColor:=Color;
  3806.   Color:=MsgBkGrnd;
  3807.  
  3808.   with Canvas do begin
  3809.     Brush.Style := bsSolid;
  3810.     Brush.Color:=MsgBkGrnd;
  3811.     Rectangle(0, 0, Width, Height);
  3812.   end;
  3813.  
  3814.   with BitMsg.Canvas do begin
  3815.     Brush.Color := MsgBkGrnd;
  3816.     Pen.Color:=MsgBkGrnd;
  3817.     Rectangle(0, 0, BitMsg.Width, BitMsg.Height);
  3818.     Font := Msg.Font;
  3819.     TextOut(0,0,Msg.Caption);
  3820.   end;
  3821.  
  3822.    Msg.Free;
  3823.    Msg := nil;
  3824.    CMessageRunning:=True;
  3825. end;
  3826. {------------------------------------------------------------------------}
  3827.  
  3828. procedure TPDBMultiMedia.NewCreditMessage;
  3829. var
  3830.   Msg : TLabel;
  3831. begin
  3832.   If CreditBoxList.Count <1 then Exit;
  3833.   If Creditcounter > CreditBoxList.Count then Creditcounter:=0;
  3834.  
  3835.   MsgText:=CreditBoxList.Strings[Creditcounter];
  3836.   If MsgText = '' then Exit;
  3837.  
  3838.   If MsgText[1] <> ' ' then MsgText:='  ' + MsgText;
  3839.   If MsgText[Length(MsgText)] <> ' ' then MsgText:=MsgText+' ';
  3840.  
  3841.   ScreenWd:=Width;
  3842.   ScreenHt:=Height;
  3843.   Msg := TLabel.Create(Self);
  3844.   Refresh;
  3845.   Msg.Parent :=Self;
  3846.   Msg.Visible := False;
  3847.   Msg.Font := MsgFont;
  3848.   Msg.Caption := MsgText;
  3849.   BitHeight:=Msg.Height;
  3850.   Msg.Width:=Msg.Width+(Msg.Width div (Length(MsgText)-2));
  3851.   BitWidth:=Msg.Width;
  3852.   SMessageLeft :=(ScreenWd - Msg.Width) Div 2;
  3853.   SMessageTop := ScreenHt;
  3854.   SMessageBottom := SMessageTop + Msg.Height;
  3855.   BitMsg.Width := Msg.Width;
  3856.   BitMsg.Height := Msg.Height+5;
  3857.   if not CMessageRunning then
  3858.    OldColor:=Color;
  3859.   Color:=MsgBkGrnd;
  3860.  
  3861.   with Canvas do begin
  3862.     Brush.Style := bsSolid;
  3863.     Brush.Color:=MsgBkGrnd;
  3864.     Rectangle(0, 0, Width, Height);
  3865.   end;
  3866.  
  3867.   with BitMsg.Canvas do begin
  3868.     Brush.Color := MsgBkGrnd;
  3869.     Pen.Color:=MsgBkGrnd;
  3870.     Rectangle(0, 0, BitMsg.Width, BitMsg.Height);
  3871.     Font := Msg.Font;
  3872.     TextOut(0,0,Msg.Caption);
  3873.   end;
  3874.  
  3875.    Msg.Free;
  3876.    Msg := nil;
  3877.    CMessageRunning:=True;
  3878. end;
  3879. {------------------------------------------------------------------------}
  3880.  
  3881. Function TPDBMultiMedia.SaveCreditMessageToStream(MFont  : Tfont;
  3882.                                                   Mspeed : integer;
  3883.                                                   MColor : Tcolor;
  3884.                                                   MMsg   : TStringList) : Boolean;
  3885. var
  3886.    Stream       :  TMemoryStream;
  3887.    Cursor       :  hCursor;
  3888.    Usize        :  longInt;
  3889.    P            :  PChar;
  3890. begin
  3891.   Result:=True;
  3892.   if FDataLink.Field is TBlobField then begin
  3893.  
  3894.       GetMem(P,65528);
  3895.  
  3896.       Usize:=WriteCreditToStream(MFont, MSpeed, MColor, MMsg, P);
  3897.  
  3898.       If Usize < 1 then
  3899.        begin
  3900.         Result:=False;
  3901.         FreeMem(P,65528);
  3902.         exit;
  3903.        end;
  3904.  
  3905.       Stream:=TMemoryStream.Create;
  3906.       Stream.Write(P^,Usize+1);
  3907.  
  3908.       FreeMem(P,65528);
  3909.  
  3910.       try
  3911.         TBlobField(FDataLink.Field).LoadFromStream(Stream);
  3912.       finally
  3913.         Stream.Free;
  3914.       end;
  3915.  
  3916.      GetInfoAndType;
  3917.    end;
  3918. end;
  3919.  
  3920. {------------------------------------------------------------------------}
  3921.  
  3922. Function TPDBMultiMedia.CreateCreditMessage : Boolean;
  3923. begin
  3924.  Result:=False;
  3925.  
  3926.  SetupCredMsg30:=TSetupCredMsg30.Create(Self);
  3927.  
  3928.  SetupCredMsg30.ShowModal;
  3929.  
  3930.  if SetupCredMsg30.ModalResult = mrOK then begin
  3931.   Result:=SaveCreditMessageToStream(SetupCredMsg30.MessageFont,
  3932.                                     SetupCredMsg30.MessageSpeed,
  3933.                                     SetupCredMsg30.MessageColor,
  3934.                                     SetupCredMsg30.MessageStrList);
  3935.  end;
  3936.  SetupCredMsg30.destroy;
  3937.  SetupCredMsg30:=Nil;
  3938. end;
  3939.  
  3940. {------------------------------------------------------------------------}
  3941.  
  3942. Procedure TPDBMultiMedia.MoveCredMsg(Var WinMsg : TMessage);
  3943. Begin
  3944.   If Not CMessageRunning then Exit;
  3945.   If not Delay(MsgSpeed) then Exit;
  3946.   Dec(SMessageTop,1);
  3947.   Dec(SMessageBottom,1);
  3948.   If SMessageTop < (0-BitHeight)-5 then begin
  3949.      If CreditBoxList.Count >0 then begin
  3950.         If Creditcounter < CreditBoxList.Count-1 then
  3951.            Inc(Creditcounter)
  3952.         else Creditcounter:=0;
  3953.         NewCreditMessage;
  3954.      end else begin
  3955.          SMessageTop := ScreenHt;
  3956.          SMessageBottom := SMessageTop + BitHeight;
  3957.      end;
  3958.   end;
  3959.  
  3960.   with Canvas do Draw(SMessageLeft,SMessageTop,BitMsg);
  3961. end;
  3962.  
  3963.  
  3964. {------------------------------------------------------------------------
  3965. Printing Stuff
  3966. ------------------------------------------------------------------------}
  3967.  
  3968. procedure TPDBMultiMedia.PrintMultiImage(X, Y, pWidth, pHeight: Integer);
  3969. begin
  3970.  If Picture.Graphic.Empty then Exit;
  3971.  
  3972.  If (BFiletype = 'ICO') or (BFiletype = 'WMF') then
  3973.    PrintICOWMF(X, Y, pWidth, pHeight)
  3974.  else
  3975.    PrintBitmap(X, Y, pWidth, pHeight)
  3976. end;
  3977. {---------------------------------------------------------------------}
  3978.  
  3979. procedure TPDBMultiMedia.PrintBitmap(X, Y, pWidth, pHeight: Integer);
  3980. var
  3981.   Info     : PBitmapInfo;
  3982.   InfoSize : Integer;
  3983.   Image    : Pointer;
  3984.   ImageSize: Longint;
  3985. begin
  3986.    If (pWidth < 1) or (pHeight < 1) then begin
  3987.       pWidth:=Picture.Bitmap.Width;
  3988.       pHeight:=Picture.Bitmap.Height;
  3989.    end;
  3990.  
  3991.    Printer.Begindoc;
  3992.  
  3993.     with Picture.Bitmap do begin
  3994.       GetDIBSizes(Handle, InfoSize, ImageSize);
  3995.       Info := MemAlloc(InfoSize);
  3996.       try
  3997.         Image := MemAlloc(ImageSize);
  3998.         try
  3999.           GetDIB(Handle, Palette, Info^, Image^);
  4000.           with Info^.bmiHeader do
  4001.            StretchDIBits(Printer.Canvas.Handle, X, Y, pWidth,
  4002.             pHeight, 0, 0, biWidth, biHeight, Image, Info^,
  4003.             DIB_RGB_COLORS, SRCCOPY)
  4004.          finally
  4005.           FreeMem(Image, ImageSize);
  4006.          end;
  4007.       finally
  4008.        FreeMem(Info, InfoSize);
  4009.       end;
  4010.     end;
  4011.     Printer.Enddoc;
  4012.   end;
  4013. {---------------------------------------------------------------------}
  4014.  
  4015. procedure TPDBMultiMedia.PrintICOWMF(X, Y, pWidth, pHeight: Integer);
  4016. begin
  4017.    If (pWidth < 1) or (pHeight < 1) then begin
  4018.     pWidth:=Picture.Graphic.Width;
  4019.     pHeight:=Picture.Graphic.Height;
  4020.    end;
  4021.  
  4022.    Printer.Begindoc;
  4023.  
  4024.    Printer.Canvas.StretchDraw(Rect(X, Y, pWidth, pHeight), Picture.Graphic);
  4025.  
  4026.    Printer.Enddoc;
  4027. end;
  4028.  
  4029. {------------------------------------------------------------------------}
  4030. {------------------------------------------------------------------------}
  4031.  
  4032.  
  4033. begin
  4034.  TPDBMultiImageCallBack:=nil;
  4035.  TPDBMultiMediaCallBack:=nil;
  4036. end.
  4037.  
  4038.  
  4039.