home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 1997 May / Pcwk0597.iso / delphi / imagelib / tdbmulti.pa_ / tdbmulti.pa
Text File  |  1995-11-19  |  93KB  |  3,025 lines
  1. {$X+,I-,R-,F+,T-}   {<<<<  This is a switch. Don't delete it}
  2.  
  3. {Copyright 1995 by
  4.  Kevin Adams, 74742,1444
  5.  Jan Dekkers, 72130,353
  6.  
  7. No part of this Unit may be copied in any way. However, you may derive
  8. other objects from TDBMultiImage, TDBMultiMedia
  9.  
  10. Part of Imagelib VCL/DLL Library.Uses ImageLib 2.2.1 Changed the callback to a
  11. function instead of a procedure to let the user cancel out.
  12.  
  13. Bug fixes:
  14.  
  15. Changed callback in version 2.21 to a function with cdecl.
  16. using the C calling convention.
  17.  
  18. Version 2.2.2 Added property ImageLibPalette which if set to True will
  19. use the ImageLib Way to paint. If false it will paint the Delphi way.
  20. This is a fix of a Stretchdraw Delphi bug which doesn't paint correctly
  21. 256 color palettes on 256 color Video cards}
  22.  
  23. {Last minute update: Added properties
  24.  
  25. property TempMov
  26. property TempAVI
  27. property TempWAV
  28. property TempMID
  29. property TempRMI
  30.  
  31. MultiMedia blobs (AVI, MOV, WAV, MID, RMI are written to a file first
  32. and than that file is being played. This can cause a problem when you
  33. have two TDBMultiMedia objects on your forum both using the same temp file
  34. (A seldom something). Incase that could happen in your app you need to
  35. assign to both TDBMultiMedia ojects different temp filenames. DON'T change
  36. the extension since the delphi multimedia player is extension sensitive}
  37.  
  38.  
  39.  
  40. unit TDBMulti;
  41.  
  42. interface
  43.  
  44. uses
  45.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Forms,
  46.   Controls, Extctrls, StdCtrls, DLL221, Menus, DB, DBTables, Mask,
  47.   Buttons, MPlayer, SetSrMsg, Printers;
  48.  
  49.  
  50.  
  51. { TDBMultiImage }
  52. Type
  53.   TDBMultiImage = 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.     FUpdateAsJpeg       :  Boolean;
  63.     FReserved           :  Byte;
  64.     Fdither             :  byte;
  65.     FResolution         :  byte;
  66.     FSaveQuality        :  byte;
  67.     FSaveSmooth         :  byte;
  68.     FColor              :  TColor;
  69.     FImageLibPalette    :  Boolean;
  70.     {scrolling message stuff}
  71.     BitMsg              :  TBitmap;
  72.     SMessageLeft        :  Integer;
  73.     SMessageRight       :  Integer;
  74.     SMessageTop         :  Integer;
  75.     ScreenWd            :  Integer;
  76.     ScreenHt            :  Integer;
  77.     BitWidth            :  Integer;
  78.     MessageRunning      :  Boolean;
  79.     DelayCounter        :  LongInt;
  80.     OldColor            :  TColor;
  81.     MmsgCount           :  Integer;
  82.     {end scrolling message stuff}
  83.     procedure DataChange(Sender: TObject);
  84.     function GetDataField: string;
  85.     function GetDataSource: TDataSource;
  86.     function GetField: TField;
  87.     function GetReadOnly: Boolean;
  88.     procedure PictureChanged(Sender: TObject);
  89.     procedure SetAutoDisplay(Value: Boolean);
  90.     procedure SetBorderStyle(Value: TBorderStyle);
  91.     procedure SetCenter(Value: Boolean);
  92.     procedure SetDataField(const Value: string);
  93.     procedure SetDataSource(Value: TDataSource);
  94.     procedure SetPicture(Value: TPicture);
  95.     procedure SetReadOnly(Value: Boolean);
  96.     procedure SetStretch(Value: Boolean);
  97.     procedure UpdateData(Sender: TObject);
  98.     procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
  99.     procedure CMExit(var Message: TCMExit); message CM_EXIT;
  100.     procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
  101.     procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
  102.     procedure WMCut(var Message: TMessage); message WM_CUT;
  103.     procedure WMCopy(var Message: TMessage); message WM_COPY;
  104.     procedure WMPaste(var Message: TMessage); message WM_PASTE;
  105.     procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
  106.   protected
  107.     procedure CreateParams(var Params: TCreateParams); override;
  108.     function GetPalette: HPALETTE; override;
  109.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  110.     procedure KeyPress(var Key: Char); override;
  111.     procedure Notification(AComponent: TComponent;
  112.       Operation: TOperation); override;
  113.     procedure Paint; override;
  114.     procedure PaintTheDelpiWay;
  115.     function GetSmooth : Byte;
  116.     procedure SetSmooth(smooth : Byte);
  117.     function GetQuality : Byte;
  118.     procedure SetQuality(Quality : Byte);
  119.     function GetDither : Byte;
  120.     procedure SetDither(dith : Byte);
  121.     function GetRes : Byte;
  122.     procedure SetRes(res : Byte);
  123.     procedure PrintICOWMF(X, Y, pWidth, pHeight: Integer);
  124.     procedure PrintBitMap(X, Y, pWidth, pHeight: Integer);
  125.     procedure LoadMessageFromStream(MessageStream : TStream);
  126.     Procedure MoveMsg(Var WinMsg : TMessage); message WM_Trigger;
  127.     Function Delay(Ms : Integer) : boolean;
  128.     Function SaveMessageToStream(MFont  : Tfont;
  129.                                   Mspeed : integer;
  130.                                   MColor : Tcolor;
  131.                                   MMsg   : String) : Boolean;
  132.   public
  133.     BFiletype           :  String;
  134.     Bwidth              :  Integer;
  135.     BHeight             :  Integer;
  136.     Bbitspixel          :  Integer;
  137.     Bplanes             :  Integer;
  138.     Bnumcolors          :  Integer;
  139.     BSize               :  Longint;
  140.     Bcompression        :  String;
  141.     {scrolling message stuff}
  142.     MsgText             :  String;
  143.     MsgFont             :  TFont;
  144.     MsgBkGrnd           :  TColor;
  145.     MsgSpeed            :  Integer;
  146.     {End scrolling message stuff}
  147.     constructor Create(AOwner: TComponent); override;
  148.     destructor Destroy; override;
  149.     procedure CopyToClipboard;
  150.     procedure CutToClipboard;
  151.     procedure LoadPicture;
  152.     procedure PasteFromClipboard;
  153.     procedure LoadFromFile(filename : TFilename);
  154.     procedure SaveToFile(filename : TFilename);
  155.     procedure SaveToFileAsBMP(filename : TFilename);
  156.     procedure SaveToFileAsJpeg(filename : TFilename);
  157.     function GetInfoAndType : String;
  158.     property Field: TField read GetField;
  159.     property Picture: TPicture read FPicture write SetPicture;
  160.     Procedure Trigger;
  161.     Function CreateMessage : Boolean;
  162.     procedure NewMessage;
  163.     Procedure FreeMsg;
  164.     procedure PrintMultiImage(X, Y, pWidth, pHeight: Integer);
  165.   published
  166.     property JPegDither : Byte read GetDither write SetDither;
  167.     property JPegResolution : Byte read GetRes write SetRes;
  168.     property JPegSaveQuality : Byte read GetQuality write SetQuality;
  169.     property JPegSaveSmooth : Byte read GetSmooth write SetSmooth;
  170.     property UPdateBlobAsJpeg : Boolean read FUpdateAsJpeg write FUpdateAsJpeg;
  171.     property AutoDisplay: Boolean read FAutoDisplay write SetAutoDisplay default True;
  172.     property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
  173.     property Center: Boolean read FCenter write SetCenter default True;
  174.     property Color;
  175.     property Align;
  176.     property Ctl3D;
  177.     property DataField: string read GetDataField write SetDataField;
  178.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  179.     property DragCursor;
  180.     property DragMode;
  181.     property Enabled;
  182.     property Font;
  183.     property ImageLibPalette : Boolean read FImageLibPalette write FImageLibPalette default True;
  184.     property ParentColor default False;
  185.     property ParentCtl3D;
  186.     property ParentFont;
  187.     property ParentShowHint;
  188.     property PopupMenu;
  189.     property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
  190.     property ShowHint;
  191.     property Stretch: Boolean read FStretch write SetStretch default False;
  192.     property TabOrder;
  193.     property TabStop default True;
  194.     property Visible;
  195.     property OnClick;
  196.     property OnDblClick;
  197.     property OnDragDrop;
  198.     property OnDragOver;
  199.     property OnEndDrag;
  200.     property OnEnter;
  201.     property OnExit;
  202.     property OnKeyDown;
  203.     property OnKeyPress;
  204.     property OnKeyUp;
  205.     property OnMouseDown;
  206.     property OnMouseMove;
  207.     property OnMouseUp;
  208.   end;
  209.  
  210. {TDBMediaPlayer}
  211. Type
  212.   TDBMediaPlayer = class(TMediaPlayer)
  213.   {Just incase you/we want to add some stuff in the
  214.    future we derived a seperate object.}
  215. end;
  216.  
  217.  
  218. {TDBMultiMedia }
  219. Type
  220.   TDBMultiMedia = class(TCustomControl)
  221.   private
  222.     FDataLink           :  TFieldDataLink;
  223.     FPicture            :  TPicture;
  224.     FBorderStyle        :  TBorderStyle;
  225.     FAutoDisplay        :  Boolean;
  226.     FStretch            :  Boolean;
  227.     FCenter             :  Boolean;
  228.     FPictureLoaded      :  Boolean;
  229.     FUpdateAsJpeg       :  Boolean;
  230.     FAutoPlayMM         :  Boolean;
  231.     FAutoMMHide         :  Boolean;
  232.     FAutoRePlayMM       :  Boolean;
  233.     FReserved           :  Byte;
  234.     Fdither             :  byte;
  235.     FResolution         :  byte;
  236.     FSaveQuality        :  byte;
  237.     FSaveSmooth         :  byte;
  238.     FMediaPlayer        :  TDBMediaPlayer;
  239.     FMOVTempFile        :  String;
  240.     FMPGTempFile        :  String;
  241.     FAVITempFile        :  String;
  242.     FWAVTempFile        :  String;
  243.     FMIDTempFile        :  String;
  244.     FRMITempFile        :  String;
  245.     FTempFilePath       :  String;
  246.     FImageLibPalette    :  Boolean;
  247.     {scrolling message stuff}
  248.     BitMsg              :  TBitmap;
  249.     SMessageLeft        :  Integer;
  250.     SMessageRight       :  Integer;
  251.     SMessageTop         :  Integer;
  252.     ScreenWd            :  Integer;
  253.     ScreenHt            :  Integer;
  254.     BitWidth            :  Integer;
  255.     MessageRunning      :  Boolean;
  256.     DelayCounter        :  LongInt;
  257.     OldColor            :  TColor;
  258.     MmsgCount           :  Integer;
  259.     {end scrolling message stuff}
  260.     procedure DataChange(Sender: TObject);
  261.     function GetDataField: string;
  262.     function GetDataSource: TDataSource;
  263.     function GetMediaPlayer: TDBMediaPlayer;
  264.     function GetField: TField;
  265.     function GetReadOnly: Boolean;
  266.     procedure PictureChanged(Sender: TObject);
  267.     procedure SetAutoDisplay(Value: Boolean);
  268.     procedure SetBorderStyle(Value: TBorderStyle);
  269.     procedure SetCenter(Value: Boolean);
  270.     procedure SetDataField(const Value: string);
  271.     procedure SetDataSource(Value: TDataSource);
  272.     procedure SetMediaPlayer(Value: TDBMediaPlayer);
  273.     procedure SetPicture(Value: TPicture);
  274.     procedure SetReadOnly(Value: Boolean);
  275.     procedure SetStretch(Value: Boolean);
  276.     procedure UpdateData(Sender: TObject);
  277.     procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
  278.     procedure CMExit(var Message: TCMExit); message CM_EXIT;
  279.     procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
  280.     procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
  281.     procedure WMCut(var Message: TMessage); message WM_CUT;
  282.     procedure WMCopy(var Message: TMessage); message WM_COPY;
  283.     procedure WMPaste(var Message: TMessage); message WM_PASTE;
  284.     procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
  285.   protected
  286.     procedure CreateParams(var Params: TCreateParams); override;
  287.     function GetPalette: HPALETTE; override;
  288.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  289.     procedure KeyPress(var Key: Char); override;
  290.     procedure Notification(AComponent: TComponent;
  291.       Operation: TOperation); override;
  292.     procedure Paint; override;
  293.     procedure PaintTheDelpiWay;
  294.     function GetSmooth : Byte;
  295.     procedure SetSmooth(smooth : Byte);
  296.     function GetQuality : Byte;
  297.     procedure SetQuality(Quality : Byte);
  298.     function GetDither : Byte;
  299.     procedure SetDither(dith : Byte);
  300.     function GetRes : Byte;
  301.     procedure SetRes(res : Byte);
  302.     function GetTempPath : String;
  303.     procedure SetTempPath(temppath : string);
  304.     function AddBackSlash(DirName : string) : string;
  305.     Procedure CleanUpMultiMedia;
  306.     function IsValidMultiMedia(Name : PChar) : boolean;
  307.     procedure TimerNotify(var Message: TMessage); message WM_TIMER;
  308.     procedure PrintICOWMF(X, Y, pWidth, pHeight: Integer);
  309.     procedure PrintBitMap(X, Y, pWidth, pHeight: Integer);
  310.     procedure LoadMessageFromStream(MessageStream : TStream);
  311.     Procedure MoveMsg(Var WinMsg : TMessage); message WM_Trigger;
  312.     Function Delay(Ms : Integer) : boolean;
  313.     Function SaveMessageToStream(MFont  : Tfont;
  314.                                   Mspeed : integer;
  315.                                   MColor : Tcolor;
  316.                                   MMsg   : String) : Boolean;
  317.   public
  318.     BFiletype           :  String;
  319.     Bwidth              :  Integer;
  320.     BHeight             :  Integer;
  321.     Bbitspixel          :  Integer;
  322.     Bplanes             :  Integer;
  323.     Bnumcolors          :  Integer;
  324.     BSize               :  Longint;
  325.     Bcompression        :  String;
  326.     {scrolling message stuff}
  327.     MsgText             :  String;
  328.     MsgFont             :  TFont;
  329.     MsgBkGrnd           :  TColor;
  330.     MsgSpeed            :  Integer;
  331.     {End scrolling message stuff}
  332.     constructor Create(AOwner: TComponent); override;
  333.     destructor Destroy; override;
  334.     procedure CopyToClipboard;
  335.     procedure CutToClipboard;
  336.     procedure LoadMedia;
  337.     procedure PasteFromClipboard;
  338.     procedure LoadFromFile(filename : TFilename);
  339.     procedure SaveToFile(filename : TFilename);
  340.     procedure SaveToFileAsBMP(filename : TFilename);
  341.     procedure SaveToFileAsJpeg(filename : TFilename);
  342.     function GetInfoAndType : String;
  343.     function GetMultiMediaExtensions : String;
  344.     property Field: TField read GetField;
  345.     property Picture: TPicture read FPicture write SetPicture;
  346.     Procedure Trigger;
  347.     Function CreateMessage : Boolean;
  348.     procedure NewMessage;
  349.     Procedure FreeMsg;
  350.     procedure PrintMultiImage(X, Y, pWidth, pHeight: Integer);
  351.   published
  352.     property JPegDither : Byte read GetDither write SetDither;
  353.     property JPegResolution : Byte read GetRes write SetRes;
  354.     property JPegSaveQuality : Byte read GetQuality write SetQuality;
  355.     property JPegSaveSmooth : Byte read GetSmooth write SetSmooth;
  356.     property UPdateBlobAsJpeg : Boolean read FUpdateAsJpeg write FUpdateAsJpeg;
  357.     property AutoPlayMultiMedia : Boolean read FAutoPlayMM write FAutoPlayMM;
  358.     property AutoRePlayMultiMedia : Boolean read FAutoRePlayMM write FAutoRePlayMM;
  359.     property AutoHideMediaPlayer : Boolean read FAutoMMHide write FAutoMMHide;
  360.     property PathForTempFile : string read GetTempPath write SetTempPath;
  361.     property Align;
  362.     property AutoDisplay: Boolean read FAutoDisplay write SetAutoDisplay default True;
  363.     property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
  364.     property Center: Boolean read FCenter write SetCenter default True;
  365.     property Color;
  366.     property Ctl3D;
  367.     property DataField: string read GetDataField write SetDataField;
  368.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  369.     property MediaPlayer: TDBMediaPlayer read GetMediaPlayer write SetmediaPlayer;
  370.     property DragCursor;
  371.     property DragMode;
  372.     property Enabled;
  373.     property Font;
  374.     property ImageLibPalette : Boolean read FImageLibPalette write FImageLibPalette default True;
  375.     property ParentColor default False;
  376.     property ParentCtl3D;
  377.     property ParentFont;
  378.     property ParentShowHint;
  379.     property PopupMenu;
  380.     property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
  381.     property ShowHint;
  382.     property Stretch: Boolean read FStretch write SetStretch default False;
  383.     property TabOrder;
  384.     property TabStop default True;
  385.     property TempMov : String Read FMOVTempFile write FMOVTempFile;
  386.     property TempAVI : String Read FAVITempFile write FAVITempFile;
  387.     property TempWAV : String Read FWAVTempFile write FWAVTempFile;
  388.     property TempMID : String Read FMIDTempFile write FMIDTempFile;
  389.     property TempRMI : String Read FRMITempFile write FRMITempFile;
  390.     property Visible;
  391.     property OnClick;
  392.     property OnDblClick;
  393.     property OnDragDrop;
  394.     property OnDragOver;
  395.     property OnEndDrag;
  396.     property OnEnter;
  397.     property OnExit;
  398.     property OnKeyDown;
  399.     property OnKeyPress;
  400.     property OnKeyUp;
  401.     property OnMouseDown;
  402.     property OnMouseMove;
  403.     property OnMouseUp;
  404.   end;
  405.  
  406.  
  407.  
  408.  
  409. var
  410.  TDBMultiImageCallBack : TCallBackFunction;
  411.  TDBMultiMediaCallBack : TCallBackFunction;
  412.  
  413. {------------------------------------------------------------------------}
  414. implementation
  415. uses Consts, DBIErrs, DBITypes, Clipbrd, DBConsts, Dialogs;
  416.  
  417. {------------------------------------------------------------------------}
  418.  
  419. {TDBMultiImage}
  420. constructor TDBMultiImage.Create(AOwner: TComponent);
  421. begin
  422.   inherited Create(AOwner);
  423.   ControlStyle := ControlStyle + [csFramed, csOpaque];
  424.   Width := 105;
  425.   Height := 105;
  426.   TabStop := True;
  427.   ParentColor := False;
  428.   FPicture := TPicture.Create;
  429.   FPicture.OnChange := PictureChanged;
  430.   FBorderStyle := bsSingle;
  431.   FAutoDisplay := True;
  432.   FImageLibPalette:=True;
  433.   FCenter := True;
  434.   FUpdateAsJpeg := True;
  435.   Fdither:=4;
  436.   FResolution:=8;
  437.   FSaveQuality:=25;
  438.   FSaveSmooth:=0;
  439.   FDataLink := TFieldDataLink.Create;
  440.   FDataLink.Control := Self;
  441.   FDataLink.OnDataChange := DataChange;
  442.   FDataLink.OnUpdateData := UpdateData;
  443.   MsgFont:=TFont.Create;
  444.   BitMsg := TBitmap.Create;
  445.   MessageRunning:=False;
  446.   SetupMsg:=Nil;
  447.   DelayCounter:=0;
  448.   Color:=clWindow;
  449. end;
  450. {------------------------------------------------------------------------}
  451.  
  452. destructor TDBMultiImage.Destroy;
  453. begin
  454.   FPicture.Free;
  455.   FDataLink.Free;
  456.   MsgFont.Free;
  457.   BitMsg.Free;
  458.   FDataLink := nil;
  459.   inherited Destroy;
  460. end;
  461. {------------------------------------------------------------------------}
  462.  
  463. function TDBMultiImage.GetDataSource: TDataSource;
  464. begin
  465.   Result := FDataLink.DataSource;
  466. end;
  467. {------------------------------------------------------------------------}
  468.  
  469. procedure TDBMultiImage.SetDataSource(Value: TDataSource);
  470. begin
  471.   FDataLink.DataSource := Value;
  472. end;
  473. {------------------------------------------------------------------------}
  474.  
  475. function TDBMultiImage.GetDataField: string;
  476. begin
  477.   Result := FDataLink.FieldName;
  478. end;
  479. {------------------------------------------------------------------------}
  480.  
  481. procedure TDBMultiImage.SetDataField(const Value: string);
  482. begin
  483.   FDataLink.FieldName := Value;
  484. end;
  485. {------------------------------------------------------------------------}
  486.  
  487. function TDBMultiImage.GetReadOnly: Boolean;
  488. begin
  489.   Result := FDataLink.ReadOnly;
  490. end;
  491. {------------------------------------------------------------------------}
  492.  
  493. procedure TDBMultiImage.SetReadOnly(Value: Boolean);
  494. begin
  495.   FDataLink.ReadOnly := Value;
  496. end;
  497. {------------------------------------------------------------------------}
  498.  
  499. function TDBMultiImage.GetField: TField;
  500. begin
  501.   Result := FDataLink.Field;
  502. end;
  503. {------------------------------------------------------------------------}
  504.  
  505. function TDBMultiImage.GetPalette: HPALETTE;
  506. begin
  507.   Result := 0;
  508.   if ImageLibPalette then exit;
  509.   if FPicture.Graphic is TBitmap then
  510.     Result := TBitmap(FPicture.Graphic).Palette;
  511. end;
  512. {------------------------------------------------------------------------}
  513.  
  514. procedure TDBMultiImage.SetAutoDisplay(Value: Boolean);
  515. begin
  516.   if FAutoDisplay <> Value then
  517.   begin
  518.     FAutoDisplay := Value;
  519.     if Value then LoadPicture;
  520.   end;
  521. end;
  522. {------------------------------------------------------------------------}
  523.  
  524. procedure TDBMultiImage.SetBorderStyle(Value: TBorderStyle);
  525. begin
  526.   if FBorderStyle <> Value then
  527.   begin
  528.     FBorderStyle := Value;
  529.     RecreateWnd;
  530.   end;
  531. end;
  532. {------------------------------------------------------------------------}
  533.  
  534. procedure TDBMultiImage.SetCenter(Value: Boolean);
  535. begin
  536.   if FCenter <> Value then
  537.   begin
  538.     FCenter := Value;
  539.     Invalidate;
  540.   end;
  541. end;
  542. {------------------------------------------------------------------------}
  543.  
  544. procedure TDBMultiImage.SetPicture(Value: TPicture);
  545. begin
  546.   FPicture.Assign(Value);
  547. end;
  548. {------------------------------------------------------------------------}
  549.  
  550. procedure TDBMultiImage.SetStretch(Value: Boolean);
  551. begin
  552.   if FStretch <> Value then
  553.   begin
  554.     FStretch := Value;
  555.     Invalidate;
  556.   end;
  557. end;
  558. {------------------------------------------------------------------------}
  559.  
  560. procedure TDBMultiImage.Paint;
  561. var
  562.   W, H        : Integer;
  563.   R           : TRect;
  564.   S           : string[63];
  565.   OldBitmap   : HBitmap;
  566.   MemDC       : HDC;
  567.   hOldPal     : HPalette;
  568. begin
  569.  
  570.   if (BFileType = 'ICO') or (BFileType = 'WMF') or (not ImageLibPalette) then begin
  571.       PaintTheDelpiWay;
  572.       exit;
  573.   end;
  574.  
  575.   with Canvas do begin
  576.     Brush.Style := bsSolid;
  577.     Brush.Color := Color;
  578.  
  579.     if FPictureLoaded then begin
  580.       if (Stretch) and (Picture.Graphic <> nil) then
  581.  
  582.         if Picture.Graphic.Empty then
  583.           FillRect(ClientRect) else
  584.          begin
  585.  
  586.             hOldPal := SelectPalette(Canvas.handle,Picture.BitMap.Palette,False);
  587.             RealizePalette(Canvas.handle);
  588.  
  589.             MemDC := CreateCompatibleDC(Canvas.handle);
  590.             OldBitmap := SelectObject(MemDC,Picture.BitMap.Handle);
  591.  
  592.             SetStretchBltMode(Canvas.handle,STRETCH_DELETESCANS);
  593.  
  594.             StretchBlt(Canvas.handle,
  595.                        ClientRect.Left,
  596.                        ClientRect.Top,
  597.                        ClientRect.Right,
  598.                        ClientRect.Bottom,
  599.                        MemDC,
  600.                        ClientRect.Left,
  601.                        ClientRect.Top,
  602.                        Picture.BitMap.Width,
  603.                        Picture.BitMap.Height,
  604.                        srcCopy);
  605.  
  606.              SelectObject(MemDC,OldBitmap);
  607.              DeleteDC(MemDC);
  608.              SelectPalette(Canvas.handle,hOldPal,False);
  609.       end else begin
  610.  
  611.         SetRect(R, 0, 0, Picture.Width, Picture.Height);
  612.         if Center then OffsetRect(R, (ClientWidth - Picture.Width) div 2,
  613.           (ClientHeight - Picture.Height) div 2);
  614.  
  615.            hOldPal := SelectPalette(Canvas.handle,Picture.BitMap.Palette,False);
  616.            RealizePalette(Canvas.handle);
  617.  
  618.            MemDC := CreateCompatibleDC(Canvas.handle);
  619.            OldBitmap := SelectObject(MemDC,Picture.BitMap.Handle);
  620.  
  621.             BitBlt(Canvas.handle,
  622.                        R.Left,
  623.                        R.Top,
  624.                        Picture.BitMap.Width,
  625.                        Picture.BitMap.Height,
  626.                        MemDC,
  627.                        0,
  628.                        0,
  629.                        srcCopy);
  630.  
  631.              SelectObject(MemDC,OldBitmap);
  632.              DeleteDC(MemDC);
  633.              SelectPalette(Canvas.handle,hOldPal,False);
  634.  
  635.              ExcludeClipRect(Handle, R.Left, R.Top, R.Right, R.Bottom);
  636.              FillRect(ClientRect);
  637.              SelectClipRgn(Handle, 0);
  638.           end;
  639.     end else begin
  640.      Font := Self.Font;
  641.      if FDataLink.Field <> nil then
  642.         S := FDataLink.Field.DisplayLabel
  643.      else
  644.         S := Name;
  645.       S := '(' + S + ')';
  646.       W := TextWidth(S);
  647.       H := TextHeight(S);
  648.       R := ClientRect;
  649.       TextRect(R, (R.Right - W) div 2, (R.Bottom - H) div 2, S);
  650.     end;
  651.  
  652.     if (GetParentForm(Self).ActiveControl = Self) and
  653.       not (csDesigning in ComponentState) then begin
  654.         Brush.Color := clWindowFrame;
  655.         FrameRect(ClientRect);
  656.     end;
  657.  
  658.   end;
  659.  
  660.   if (MessageRunning) and (Picture = nil) then FreeMsg;
  661. end;
  662. {------------------------------------------------------------------------}
  663.  
  664. procedure TDBMultiImage.PaintTheDelpiWay;
  665. var
  666.   W, H: Integer;
  667.   R: TRect;
  668.   S: string[63];
  669. begin
  670.   with Canvas do
  671.   begin
  672.     Brush.Style := bsSolid;
  673.     Brush.Color := Color;
  674.     if FPictureLoaded then
  675.     begin
  676.       if (Stretch) and (Picture.Graphic <> nil) then
  677.         if Picture.Graphic.Empty then
  678.           FillRect(ClientRect) else
  679.           StretchDraw(ClientRect, Picture.Graphic)
  680.       else
  681.       begin
  682.         SetRect(R, 0, 0, Picture.Width, Picture.Height);
  683.         if Center then OffsetRect(R, (ClientWidth - Picture.Width) div 2,
  684.           (ClientHeight - Picture.Height) div 2);
  685.         StretchDraw(R, Picture.Graphic);
  686.         ExcludeClipRect(Handle, R.Left, R.Top, R.Right, R.Bottom);
  687.         FillRect(ClientRect);
  688.         SelectClipRgn(Handle, 0);
  689.       end;
  690.     end else
  691.     begin
  692.       Font := Self.Font;
  693.       if FDataLink.Field <> nil then
  694.         S := FDataLink.Field.DisplayLabel else
  695.         S := Name;
  696.       S := '(' + S + ')';
  697.       W := TextWidth(S);
  698.       H := TextHeight(S);
  699.       R := ClientRect;
  700.       TextRect(R, (R.Right - W) div 2, (R.Bottom - H) div 2, S);
  701.     end;
  702.     if (GetParentForm(Self).ActiveControl = Self) and
  703.       not (csDesigning in ComponentState) then
  704.     begin
  705.       Brush.Color := clWindowFrame;
  706.       FrameRect(ClientRect);
  707.     end;
  708.   end;
  709.   if (MessageRunning) and (Picture = nil) then FreeMsg;
  710. end;
  711. {------------------------------------------------------------------------}
  712.  
  713. procedure TDBMultiImage.PictureChanged(Sender: TObject);
  714. begin
  715.   FDataLink.Modified;
  716.   FPictureLoaded := True;
  717.   Invalidate;
  718. end;
  719. {------------------------------------------------------------------------}
  720.  
  721. procedure TDBMultiImage.Notification(AComponent: TComponent;
  722.   Operation: TOperation);
  723. begin
  724.   inherited Notification(AComponent, Operation);
  725.   if (Operation = opRemove) and (FDataLink <> nil) and
  726.     (AComponent = DataSource) then DataSource := nil;
  727. end;
  728. {------------------------------------------------------------------------}
  729.  
  730. procedure TDBMultiImage.LoadPicture;
  731. var
  732.    Stream       :  TMemoryStream;
  733.    BitMap       :  TBitMap;
  734.    Cursor       :  hCursor;
  735.    temp         :  string;
  736. begin
  737.   if MessageRunning then FreeMsg;
  738.  
  739.   if not FPictureLoaded and (FDataLink.Field is TBlobField) then begin
  740.  
  741.    if TBlobField(FDataLink.Field).IsNull then exit;
  742.  
  743.    Temp:=GetInfoAndType;
  744.  
  745.    if Temp = 'SCM' then begin
  746.       Stream:=TMemoryStream.Create;
  747.       try
  748.         Cursor := SetCursor(LoadCursor(0,idc_Wait));
  749.          FreeMsg;
  750.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  751.          LoadMessageFromStream(Stream);
  752.          if @TDBMultiMediaCallBack <> nil then
  753.            TDBMultiMediaCallBack(0);
  754.        finally
  755.          SetCursor(Cursor);
  756.          Stream.Free;
  757.        end;
  758.    end else
  759.  
  760.    if Temp = 'GIF' then begin
  761.       Stream:=TMemoryStream.Create;
  762.       BitMap:=TBitMap.Create;
  763.       try
  764.          FreeMsg;
  765.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  766.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  767.          if not gifblob(Stream.Memory,Stream.Size, Bitmap, TDBMultiImageCallBack) then begin
  768.             MessageDlg('Invallid or empty GIF blobfield', mtInformation, [mbOk], 0);
  769.             Picture.Assign(Nil);
  770.          end else
  771.             Picture.Assign(BitMap);
  772.          finally
  773.             SetCursor(Cursor);
  774.             BitMap.free;
  775.             Stream.Free;
  776.          end;
  777.    end else
  778.  
  779.    if Temp = 'PCX' then begin
  780.       Stream:=TMemoryStream.Create;
  781.       BitMap:=TBitMap.Create;
  782.       try
  783.          FreeMsg;
  784.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  785.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  786.          if not pcxblob(Stream.Memory,Stream.Size, Bitmap, TDBMultiImageCallBack) then begin
  787.             MessageDlg('Invallid or empty PCX blobfield', mtInformation, [mbOk], 0);
  788.             Picture.Assign(Nil);
  789.          end else
  790.             Picture.Assign(BitMap);
  791.          finally
  792.           SetCursor(Cursor);
  793.           BitMap.free;
  794.           Stream.Free;
  795.          end;
  796.    end else
  797.  
  798.    if Temp = 'BMP' then begin
  799.       Stream:=TMemoryStream.Create;
  800.       BitMap:=TBitMap.Create;
  801.       try
  802.          FreeMsg;
  803.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  804.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  805.          if not bmpblob(Stream.Memory,Stream.Size, Bitmap, TDBMultiImageCallBack) then begin
  806.             MessageDlg('Invallid or empty BMP blobfield', mtInformation, [mbOk], 0);
  807.             Picture.Assign(Nil);
  808.          end else
  809.             Picture.Assign(BitMap);
  810.          finally
  811.           SetCursor(Cursor);
  812.           BitMap.free;
  813.           Stream.Free;
  814.          end;
  815.    end else
  816.  
  817.    if Temp = 'JPG' then begin
  818.       Stream:=TMemoryStream.Create;
  819.       BitMap:=TBitMap.Create;
  820.       if FResolution <> 4 then
  821.       if FResolution <> 8 then
  822.       if FResolution <> 24 then FResolution:=8;
  823.       if (FDither < 0) or (FDither > 4) then FDither:=4;
  824.       try
  825.          FreeMsg;
  826.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  827.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  828.          if not jpgblob(Stream.Memory,Stream.Size, FResolution, Fdither, Bitmap, TDBMultiImageCallBack) then begin
  829.             MessageDlg('Invallid or empty Jpeg Blobfield', mtInformation, [mbOk], 0);
  830.             Picture.Assign(Nil);
  831.          end else
  832.              Picture.Assign(BitMap);
  833.          finally
  834.              SetCursor(Cursor);
  835.              BitMap.free;
  836.              Stream.Free;
  837.          end;
  838.     end;
  839.     GetInfoAndType;
  840.  end;
  841. end;
  842. {------------------------------------------------------------------------}
  843.  
  844. procedure TDBMultiImage.DataChange(Sender: TObject);
  845. begin
  846.   If MessageRunning then FreeMsg;
  847.   Picture.Graphic := nil;
  848.   FPictureLoaded := False;
  849.   if FAutoDisplay then LoadPicture;
  850. end;
  851. {------------------------------------------------------------------------}
  852.  
  853. procedure TDBMultiImage.UpdateData(Sender: TObject);
  854. var
  855.    Stream       :  TMemoryStream;
  856.    Cursor       :  hCursor;
  857.    Usize        :  longInt;
  858.    x,y          :  longInt;
  859.    p            :  Pointer;
  860. begin
  861.   if FDataLink.Field is TBlobField then begin
  862.  
  863.     if Picture.Graphic is TBitmap then begin
  864.       x:=Picture.BitMap.Width;
  865.       y:=Picture.BitMap.Height;
  866.  
  867.       y:=y+(y div 5);
  868.       x:=x+(x div 5);
  869.  
  870.       Usize:=(y * x);
  871.  
  872.       if Usize < 90000 then Usize:=Usize*2;
  873.  
  874.       {Since we can't know how much memory we need to allocate
  875.       to write the picture to the stream we need to guess it. This
  876.       is done using the width and height of the bitmap. After the call
  877.       to the dll using PUTJPGBLOB or PUTBMPBLOB Usize contains the
  878.       correct size of the Bitmap stored in P^. You can increase or decrease
  879.       the guessed memory by altering the Div by. For instance
  880.  
  881.       y:=y+(y div 3);
  882.       x:=x+(x div 3);
  883.  
  884.       will allocate more memory then
  885.  
  886.       y:=y+(y div 6);
  887.       x:=x+(x div 6);
  888.  
  889.       We played it on the save side. Use this "guess work" very carefully}
  890.  
  891.  
  892.       P := GlobalAllocPtr(HeapAllocFlags, Usize);
  893.  
  894.       if P = Nil then
  895.         exit;
  896.  
  897.       if FUpdateAsJpeg then begin
  898.          if not putjpgblob(P, USize, FSaveQuality, FSaveSmooth, Picture.Bitmap, TDBMultiImageCallBack) then
  899.            MessageDlg('Jpeg BLOB Write Error', mtInformation, [mbOk], 0);
  900.       end else begin
  901.          if not putbmpblob(P, USize, Picture.Bitmap, TDBMultiImageCallBack) then
  902.            MessageDlg('BMP BLOB Write Error', mtInformation, [mbOk], 0);
  903.       end;
  904.  
  905.       Stream:=TMemoryStream.Create;
  906.       Stream.Write(P^,USize);
  907.       GlobalFreePtr(P);
  908.  
  909.       try
  910.         TBlobField(FDataLink.Field).LoadFromStream(Stream);
  911.       finally
  912.         Stream.Free;
  913.       end;
  914.  
  915.     end else
  916.       TBlobField(FDataLink.Field).Clear;
  917.    end;
  918.    GetInfoAndType;
  919. end;
  920. {------------------------------------------------------------------------}
  921.  
  922. procedure TDBMultiImage.CopyToClipboard;
  923. begin
  924.   if Picture.Graphic <> nil then Clipboard.Assign(Picture);
  925. end;
  926. {------------------------------------------------------------------------}
  927.  
  928. procedure TDBMultiImage.CutToClipboard;
  929. begin
  930.   if Picture.Graphic <> nil then
  931.   begin
  932.     CopyToClipboard;
  933.     if FDataLink.Edit then
  934.       Picture.Graphic := nil;
  935.   end;
  936. end;
  937. {------------------------------------------------------------------------}
  938.  
  939. procedure TDBMultiImage.PasteFromClipboard;
  940. begin
  941.   if Clipboard.HasFormat(CF_PICTURE) and FDataLink.Edit then begin
  942.     MessageRunning:=False;
  943.     Picture.Assign(Clipboard);
  944.    end;
  945. end;
  946. {------------------------------------------------------------------------}
  947.  
  948. procedure TDBMultiImage.CreateParams(var Params: TCreateParams);
  949. begin
  950.   inherited CreateParams(Params);
  951.   if FBorderStyle = bsSingle then
  952.     Params.Style := Params.Style or WS_BORDER;
  953. end;
  954. {------------------------------------------------------------------------}
  955.  
  956. procedure TDBMultiImage.KeyDown(var Key: Word; Shift: TShiftState);
  957. begin
  958.   inherited KeyDown(Key, Shift);
  959.   case Key of
  960.     VK_INSERT:
  961.       if ssShift in Shift then PasteFromClipBoard else
  962.         if ssCtrl in Shift then CopyToClipBoard;
  963.     VK_DELETE:
  964.       if ssShift in Shift then CutToClipBoard;
  965.   end;
  966. end;
  967. {------------------------------------------------------------------------}
  968.  
  969. procedure TDBMultiImage.KeyPress(var Key: Char);
  970. begin
  971.   inherited KeyPress(Key);
  972.   case Key of
  973.     ^X: CutToClipBoard;
  974.     ^C: CopyToClipBoard;
  975.     ^V: PasteFromClipBoard;
  976.     #13: LoadPicture;
  977.     #27: FDataLink.Reset;
  978.   end;
  979. end;
  980. {------------------------------------------------------------------------}
  981.  
  982. procedure TDBMultiImage.CMEnter(var Message: TCMEnter);
  983. begin
  984.   Invalidate; { Draw the focus marker }
  985.   inherited;
  986. end;
  987. {------------------------------------------------------------------------}
  988.  
  989. procedure TDBMultiImage.CMExit(var Message: TCMExit);
  990. begin
  991.   Invalidate; { Erase the focus marker }
  992.   inherited;
  993. end;
  994. {------------------------------------------------------------------------}
  995.  
  996. procedure TDBMultiImage.CMTextChanged(var Message: TMessage);
  997. begin
  998.   inherited;
  999.   if not FPictureLoaded then Invalidate;
  1000. end;
  1001. {------------------------------------------------------------------------}
  1002.  
  1003. procedure TDBMultiImage.WMLButtonDown(var Message: TWMLButtonDown);
  1004. begin
  1005.   if TabStop and CanFocus then SetFocus;
  1006.   inherited;
  1007. end;
  1008. {------------------------------------------------------------------------}
  1009.  
  1010. procedure TDBMultiImage.WMLButtonDblClk(var Message: TWMLButtonDblClk);
  1011. begin
  1012.   LoadPicture;
  1013.   inherited;
  1014. end;
  1015. {------------------------------------------------------------------------}
  1016.  
  1017. procedure TDBMultiImage.WMCut(var Message: TMessage);
  1018. begin
  1019.   CutToClipboard;
  1020. end;
  1021. {------------------------------------------------------------------------}
  1022.  
  1023. procedure TDBMultiImage.WMCopy(var Message: TMessage);
  1024. begin
  1025.   CopyToClipboard;
  1026. end;
  1027. {------------------------------------------------------------------------}
  1028.  
  1029. procedure TDBMultiImage.WMPaste(var Message: TMessage);
  1030. begin
  1031.   PasteFromClipboard;
  1032. end;
  1033. {------------------------------------------------------------------------}
  1034.  
  1035. procedure TDBMultiImage.LoadFromFile(filename : TFilename);
  1036. var
  1037.    Cursor       :  hCursor;
  1038. begin
  1039.   if not FileExists(filename) then begin
  1040.     MessageDlg('File not found', mtInformation, [mbOk], 0);
  1041.     exit;
  1042.   end;
  1043.  
  1044.   if UpperCase(ExtractFileExt(filename)) <> '.JPG' then
  1045.   if UpperCase(ExtractFileExt(filename)) <> '.GIF' then
  1046.   if UpperCase(ExtractFileExt(filename)) <> '.PCX' then
  1047.   if UpperCase(ExtractFileExt(filename)) <> '.BMP' then
  1048.   if UpperCase(ExtractFileExt(filename)) <> '.SCM' then
  1049.   begin
  1050.     MessageDlg('Not a Jpeg, Gif, Pcx, Scm or Bmp File', mtInformation, [mbOk], 0);
  1051.     exit;
  1052.   end;
  1053.  
  1054.   if FDataLink.Field is TBlobField then begin
  1055.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1056.     TBlobField(FDataLink.Field).LoadFromFile(filename);
  1057.     SetCursor(Cursor);
  1058.   end else begin
  1059.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  1060.     exit;
  1061.   end;
  1062.   GetInfoAndType;
  1063. end;
  1064. {------------------------------------------------------------------------}
  1065.  
  1066. procedure TDBMultiImage.SaveToFile(filename : TFilename);
  1067. var
  1068.   Cursor       :  hCursor;
  1069. begin
  1070.   if FDataLink.Field is TBlobField then begin
  1071.  
  1072.     if TBlobField(FDataLink.Field).IsNull then begin
  1073.        MessageDlg('Can''t save, blobfield is empty', mtInformation, [mbOk], 0);
  1074.        exit;
  1075.     end;
  1076.  
  1077.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1078.     TBlobField(FDataLink.Field).SaveToFile(filename);
  1079.     GetInfoAndType;
  1080.     SetCursor(Cursor)
  1081.  
  1082.   end else begin
  1083.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  1084.     exit;
  1085.   end;
  1086. end;
  1087. {------------------------------------------------------------------------}
  1088.  
  1089. procedure TDBMultiImage.SaveToFileAsBMP(filename : TFilename);
  1090. var
  1091.   Cursor       :  hCursor;
  1092. begin
  1093.   if FDataLink.Field is TBlobField then begin
  1094.  
  1095.     if TBlobField(FDataLink.Field).IsNull then begin
  1096.        MessageDlg('Can''t save, blobfield bitmap is empty', mtInformation, [mbOk], 0);
  1097.        exit;
  1098.     end;
  1099.  
  1100.     if picture.bitmap.empty then begin
  1101.        MessageDlg('Can''t save, image is not displayed, Set Autodisplay or double click display to view image first.',
  1102.                   mtInformation, [mbOk], 0);
  1103.        exit;
  1104.     end;
  1105.  
  1106.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1107.  
  1108.     if not putbmpfile(FileName, picture.Bitmap, TDBMultiImageCallBack) then begin
  1109.       SetCursor(Cursor);
  1110.       MessageDlg('Writing bmp file failed', mtInformation, [mbOk], 0);
  1111.       exit;
  1112.     end;
  1113.  
  1114.     GetInfoAndType
  1115.  
  1116.   end else begin
  1117.     SetCursor(Cursor);
  1118.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  1119.     exit;
  1120.   end;
  1121.  
  1122.   SetCursor(Cursor);
  1123. end;
  1124. {------------------------------------------------------------------------}
  1125.  
  1126. procedure TDBMultiImage.SaveToFileAsJpeg(filename : TFilename);
  1127. var
  1128.   Cursor       :  hCursor;
  1129. begin
  1130.   if FDataLink.Field is TBlobField then begin
  1131.  
  1132.     if TBlobField(FDataLink.Field).IsNull then begin
  1133.        MessageDlg('Can''t save, blobfield bitmap is empty', mtInformation, [mbOk], 0);
  1134.        exit;
  1135.     end;
  1136.  
  1137.     if picture.bitmap = nil then begin
  1138.        MessageDlg('Can''t save, image is not displayed', mtInformation, [mbOk], 0);
  1139.        exit;
  1140.     end;
  1141.  
  1142.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1143.  
  1144.     if not putjpgfile(FileName, FSaveQuality, FSaveSmooth, picture.Bitmap, TDBMultiImageCallBack) then begin
  1145.       SetCursor(Cursor);
  1146.       MessageDlg('Writing jpg file failed', mtInformation, [mbOk], 0);
  1147.       exit;
  1148.     end;
  1149.  
  1150.     GetInfoAndType
  1151.  
  1152.   end else begin
  1153.     SetCursor(Cursor);
  1154.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  1155.     exit;
  1156.   end;
  1157.  
  1158.   SetCursor(Cursor);
  1159. end;
  1160.  
  1161.  
  1162. {------------------------------------------------------------------------}
  1163.  
  1164. function TDBMultiImage.GetInfoAndType : String;
  1165. var
  1166.  Stream       :  TMemoryStream;
  1167.  Hdr          :  Array[0..45] of char;
  1168.  i            :  Byte;
  1169. begin
  1170.   if (FDataLink.Field is TBlobField) then
  1171.    if TBlobField(FDataLink.Field).IsNull then exit;
  1172.  
  1173.    BFileType := 'Empty';
  1174.    Bwidth:=-1;
  1175.    BHeight:=-1;
  1176.    Bbitspixel:=-1;
  1177.    Bplanes:=-1;
  1178.    Bnumcolors:=-1;
  1179.    Bcompression:='-1';
  1180.    BSize:=-1;
  1181.    GetInfoAndType :='-1';
  1182.  
  1183.    Stream:=TMemoryStream.Create;
  1184.    TBlobField(FDataLink.Field).SaveToStream(Stream);
  1185.  
  1186.   if Stream.Memory = nil then begin
  1187.      MessageDlg('Error allocation temporary blob memory', mtInformation, [mbOk], 0);
  1188.      exit;
  1189.   end;
  1190.  
  1191.   Stream.Seek(0,0);
  1192.   Stream.read(hdr,SizeOf(Hdr)-1);
  1193.  
  1194.   for i:=0 to SizeOf(hdr)-1 do
  1195.    if hdr[i] = #0 then hdr[i]:=' ';
  1196.  
  1197.   if StrPos(hdr,'kevinjan') <> nil then begin
  1198.         Bwidth:=-1;
  1199.         BHeight:=-1;
  1200.         Bbitspixel:=-1;
  1201.         Bplanes:=-1;
  1202.         Bnumcolors:=-1;
  1203.         Bcompression:='MSG';
  1204.         BSize:=Stream.Size;
  1205.         BFileType:= 'SCM';
  1206.         GetInfoAndType:='SCM';
  1207.         if Stream.Memory <> nil then Stream.Free;
  1208.         exit;
  1209.    end else
  1210.  
  1211.    if not GetBlobInfo(Stream.Memory,
  1212.                     Stream.Size,
  1213.                     BFileType,
  1214.                     Bwidth,
  1215.                     BHeight,
  1216.                     Bbitspixel,
  1217.                     Bplanes,
  1218.                     Bnumcolors,
  1219.                     Bcompression) then
  1220.     MessageDlg('blobfield getinfo failed', mtInformation, [mbOk], 0) else
  1221.     begin
  1222.          BSize:=Stream.Size;
  1223.          if UpperCase(BFileType) = 'GIF' then GetInfoAndType:='GIF' else
  1224.          if UpperCase(BFileType) = 'PCX' then GetInfoAndType:='PCX' else
  1225.          if UpperCase(BFileType) = 'JPEG' then GetInfoAndType:='JPG' else
  1226.          if UpperCase(BFileType) = 'BMP' then GetInfoAndType:='BMP';
  1227.     end;
  1228.   if Stream.Memory <> nil then Stream.Free;
  1229. end;
  1230. {------------------------------------------------------------------------}
  1231.  
  1232. function TDBMultiImage.GetSmooth : Byte;
  1233. begin
  1234.   GetSmooth:=FSaveSmooth;
  1235. end;
  1236. {------------------------------------------------------------------------}
  1237.  
  1238. procedure TDBMultiImage.SetSmooth(Smooth : Byte);
  1239. begin
  1240.   if (Smooth > 100) or (Smooth < 0) then FSaveSmooth:=5 else
  1241.    FSaveSmooth:=Smooth;
  1242. end;
  1243. {------------------------------------------------------------------------}
  1244.  
  1245. function TDBMultiImage.GetQuality : Byte;
  1246. begin
  1247.   GetQuality:=FSaveQuality;
  1248. end;
  1249. {------------------------------------------------------------------------}
  1250.  
  1251. procedure TDBMultiImage.SetQuality(Quality : Byte);
  1252. begin
  1253.   if (Quality > 100) OR (Quality < 1) then FSaveQuality:=25 else
  1254.    FSaveQuality:=Quality;
  1255. end;
  1256. {------------------------------------------------------------------------}
  1257. function TDBMultiImage.GetDither : Byte;
  1258. begin
  1259.   GetDither:=Fdither
  1260. end;
  1261. {------------------------------------------------------------------------}
  1262.  
  1263. procedure TDBMultiImage.SetDither(dith : Byte);
  1264. begin
  1265.   Fdither:=4;
  1266.   case dith of
  1267.             0..4 :Fdither:=dith;
  1268.   end;
  1269. end;
  1270. {------------------------------------------------------------------------}
  1271.  
  1272. function TDBMultiImage.GetRes : Byte;
  1273. begin
  1274.   GetRes:=FResolution;
  1275. end;
  1276. {------------------------------------------------------------------------}
  1277.  
  1278.  
  1279. procedure TDBMultiImage.SetRes(res : Byte);
  1280. begin
  1281.   FResolution:=8;
  1282.   case res of
  1283.             4 :FResolution:=res;
  1284.             8 :FResolution:=res;
  1285.             24:FResolution:=res;
  1286.   end;
  1287. end;
  1288.  
  1289. {------------------------------------------------------------------------
  1290.  scrolling message stuff
  1291. ------------------------------------------------------------------------}
  1292.  
  1293. procedure TDBMultiImage.LoadMessageFromStream(MessageStream : TStream);
  1294. var
  1295.   Msg      : TLabel;
  1296. begin
  1297.   FreeMsg;
  1298.   ScreenWd:=Width;
  1299.   ScreenHt:=Height;
  1300.   Msg := TLabel.Create(Self);
  1301.   readmessagefromstream(MessageStream, MsgFont, MsgSpeed, MsgBkGrnd, MsgText);
  1302.   Refresh;
  1303.   if MsgText[Length(MsgText)] <> ' ' then MsgText:=MsgText+' ';
  1304.   Msg.Parent :=Self;
  1305.   Msg.Visible := False;
  1306.   Msg.Font := MsgFont;
  1307.   Msg.Caption := MsgText;
  1308.   BitWidth:=Msg.Width;
  1309.   SMessageLeft := ScreenWd;
  1310.   SMessageRight := ScreenWd + Msg.Width;
  1311.   SMessageTop := (ScreenHt - Msg.Height) Div 2;
  1312.   BitMsg.Width := Msg.Width;
  1313.   BitMsg.Height := Msg.Height;
  1314.   OldColor:=Color;
  1315.   Color:=MsgBkGrnd;
  1316.  
  1317.   with BitMsg.Canvas do begin
  1318.     Brush.Color := MsgBkGrnd;
  1319.     Font := Msg.Font;
  1320.     TextOut(0,0,Msg.Caption);
  1321.   end;
  1322.  
  1323.    Msg.Free;
  1324.    Msg := nil;
  1325.    MessageRunning:=True;
  1326. end;
  1327. {------------------------------------------------------------------------}
  1328.  
  1329. procedure TDBMultiImage.NewMessage;
  1330. var
  1331.   Msg      : TLabel;
  1332. begin
  1333.   FreeMsg;
  1334.   if MsgText = '' then exit;
  1335.   if MsgText[Length(MsgText)] <> ' ' then MsgText:=MsgText+' ';
  1336.   ScreenWd:=Width;
  1337.   ScreenHt:=Height;
  1338.   Msg := TLabel.Create(Self);
  1339.   Refresh;
  1340.   Msg.Parent :=Self;
  1341.   Msg.Visible := False;
  1342.   Msg.Font := MsgFont;
  1343.   Msg.Caption := MsgText;
  1344.   BitWidth:=Msg.Width;
  1345.   SMessageLeft := ScreenWd;
  1346.   SMessageRight := ScreenWd + Msg.Width;
  1347.   SMessageTop := (ScreenHt - Msg.Height) Div 2;
  1348.   BitMsg.Width := Msg.Width;
  1349.   BitMsg.Height := Msg.Height;
  1350.   OldColor:=Color;
  1351.   Color:=MsgBkGrnd;
  1352.  
  1353.   with BitMsg.Canvas do begin
  1354.     Brush.Color := MsgBkGrnd;
  1355.     Font := Msg.Font;
  1356.     TextOut(0,0,Msg.Caption);
  1357.   end;
  1358.  
  1359.    Msg.Free;
  1360.    Msg := nil;
  1361.    MessageRunning:=True;
  1362. end;
  1363. {------------------------------------------------------------------------}
  1364.  
  1365. Function TDBMultiImage.CreateMessage : Boolean;
  1366. begin
  1367.  Result:=False;
  1368.  Application.CreateForm(TSetupMsg, SetupMsg );
  1369.  SetupMsg.ShowModal;
  1370.  if SetupMsg.ModalResult = mrOK then begin
  1371.   Result:=SaveMessageToStream(SetupMsg.MessageFont,
  1372.                               SetupMsg.MessageSpeed,
  1373.                               SetupMsg.MessageColor,
  1374.                               SetupMsg.MessageMsg);
  1375.  end;
  1376.  SetupMsg.destroy;
  1377.  SetupMsg:=Nil;
  1378. end;
  1379. {------------------------------------------------------------------------}
  1380.  
  1381. Procedure TDBMultiImage.FreeMsg;
  1382. Begin
  1383.   Picture.Assign(nil);
  1384.   if MessageRunning then
  1385.   Color:=OldColor;
  1386.   MessageRunning:=False;
  1387. end;
  1388. {------------------------------------------------------------------------}
  1389.  
  1390. Function TDBMultiImage.Delay(Ms : Integer) : boolean;
  1391. Begin
  1392.  Inc(DelayCounter);
  1393.  if DelayCounter > MS then begin
  1394.   DelayCounter:=0;
  1395.   Result:=true;
  1396.  end else
  1397.   Result:=false;
  1398. end;
  1399. {------------------------------------------------------------------------}
  1400.  
  1401. Procedure TDBMultiImage.MoveMsg(Var WinMsg : TMessage);
  1402. Begin
  1403.   if Not MessageRunning then exit;
  1404.   if Not Delay(MsgSpeed)then exit;
  1405.   Dec(SMessageLeft,1);
  1406.   Dec(SMessageRight,1);
  1407.   Inc(MmsgCount,1);
  1408.   if SMessageRight < 0 then begin
  1409.     SMessageLeft := ScreenWd;
  1410.     SMessageRight := SMessageLeft + BitWidth;
  1411.   end;
  1412.     with Canvas do
  1413.        Draw(SMessageLeft,SMessageTop,BitMsg);
  1414. end;
  1415. {------------------------------------------------------------------------}
  1416.  
  1417. Procedure TDBMultiImage.Trigger;
  1418. Begin
  1419.   if SetupMsg <> nil then SetupMsg.Trigger;
  1420.     if (visible) and (enabled) then
  1421.    PostMessage(Handle, WM_Trigger, 0, 0);
  1422. End;
  1423. {------------------------------------------------------------------------}
  1424.  
  1425. Function TDBMultiImage.SaveMessageToStream(MFont  : Tfont;
  1426.                                            Mspeed : integer;
  1427.                                            MColor : Tcolor;
  1428.                                            MMsg   : String) : Boolean;
  1429. var
  1430.    Stream       :  TMemoryStream;
  1431.    Cursor       :  hCursor;
  1432.    Usize        :  longInt;
  1433.    P            :  Array[0..1602] of char;
  1434. begin
  1435.   Result:=True;
  1436.   if FDataLink.Field is TBlobField then begin
  1437.      If Length(MMsg) < 1 then
  1438.       begin
  1439.         Result:=False;
  1440.         exit;
  1441.        end;
  1442.  
  1443.       Usize:=WriteMessageToStream(MFont, MSpeed, MColor, MMsg, P);
  1444.  
  1445.       If Usize < 1 then
  1446.        begin
  1447.         Result:=False;
  1448.         exit;
  1449.        end;
  1450.  
  1451.       Stream:=TMemoryStream.Create;
  1452.       Stream.Write(P,Usize+1);
  1453.  
  1454.       try
  1455.         TBlobField(FDataLink.Field).LoadFromStream(Stream);
  1456.       finally
  1457.         Stream.Free;
  1458.       end;
  1459.      GetInfoAndType;
  1460.    end;
  1461. end;
  1462.  
  1463. {------------------------------------------------------------------------
  1464. Printing Stuff
  1465. ------------------------------------------------------------------------}
  1466.  
  1467. procedure TDBMultiImage.PrintMultiImage(X, Y, pWidth, pHeight: Integer);
  1468. begin
  1469.  if Picture.Graphic.Empty then exit;
  1470.  
  1471.  if (BFiletype = 'ICO') or (BFiletype = 'WMF') then
  1472.    PrintICOWMF(X, Y, pWidth, pHeight)
  1473.  else
  1474.    PrintBitMap(X, Y, pWidth, pHeight)
  1475. end;
  1476. {---------------------------------------------------------------------}
  1477.  
  1478. procedure TDBMultiImage.PrintBitMap(X, Y, pWidth, pHeight: Integer);
  1479. var
  1480.   Info     : PBitmapInfo;
  1481.   InfoSize : Integer;
  1482.   Image    : Pointer;
  1483.   ImageSize: Longint;
  1484. begin
  1485.    if (pWidth < 1) or (pHeight < 1) then begin
  1486.       pWidth:=Picture.Bitmap.Width;
  1487.       pHeight:=Picture.Bitmap.Height;
  1488.    end;
  1489.  
  1490.    Printer.Begindoc;
  1491.  
  1492.     with Picture.Bitmap do begin
  1493.       GetDIBSizes(Handle, InfoSize, ImageSize);
  1494.       Info := MemAlloc(InfoSize);
  1495.       try
  1496.         Image := MemAlloc(ImageSize);
  1497.         try
  1498.           GetDIB(Handle, Palette, Info^, Image^);
  1499.           with Info^.bmiHeader do
  1500.            StretchDIBits(Printer.Canvas.Handle, X, Y, pWidth,
  1501.             pHeight, 0, 0, biWidth, biHeight, Image, Info^,
  1502.             DIB_RGB_COLORS, SRCCOPY)
  1503.          finally
  1504.           FreeMem(Image, ImageSize);
  1505.          end;
  1506.       finally
  1507.        FreeMem(Info, InfoSize);
  1508.       end;
  1509.     end;
  1510.     Printer.Enddoc;
  1511.   end;
  1512. {---------------------------------------------------------------------}
  1513.  
  1514. procedure TDBMultiImage.PrintICOWMF(X, Y, pWidth, pHeight: Integer);
  1515. begin
  1516.    if (pWidth < 1) or (pHeight < 1) then begin
  1517.     pWidth:=Picture.Graphic.Width;
  1518.     pHeight:=Picture.Graphic.Height;
  1519.    end;
  1520.  
  1521.    Printer.Begindoc;
  1522.  
  1523.    Printer.Canvas.StretchDraw(Rect(X, Y, pWidth, pHeight), Picture.Graphic);
  1524.  
  1525.    Printer.Enddoc;
  1526. end;
  1527. {------------------------------------------------------------------------
  1528.  end TDBMultiImage
  1529. ------------------------------------------------------------------------}
  1530.  
  1531.  
  1532.  
  1533. {TDBMultiMedia}
  1534.  
  1535. constructor TDBMultiMedia.Create(AOwner: TComponent);
  1536. begin
  1537.   inherited Create(AOwner);
  1538.   ControlStyle := ControlStyle + [csFramed, csOpaque];
  1539.   Width := 105;
  1540.   Height := 105;
  1541.   TabStop := True;
  1542.   ParentColor := False;
  1543.   FPicture := TPicture.Create;
  1544.   FPicture.OnChange := PictureChanged;
  1545.   FBorderStyle := bsSingle;
  1546.   FAutoDisplay := True;
  1547.   FImageLibPalette:=True;
  1548.   FCenter := True;
  1549.   FUpdateAsJpeg := True;
  1550.   Fdither:=4;
  1551.   FResolution:=8;
  1552.   FSaveQuality:=25;
  1553.   FSaveSmooth:=0;
  1554.   FDataLink := TFieldDataLink.Create;
  1555.   FDataLink.Control := Self;
  1556.   FDataLink.OnDataChange := DataChange;
  1557.   FDataLink.OnUpdateData := UpdateData;
  1558.   FMOVTempFile:='$$$.MOV';
  1559.   FMPGTempFile:='$$$.MPG';
  1560.   FAVITempFile:='$$$.AVI';
  1561.   FWAVTempFile:='$$$.WAV';
  1562.   FMIDTempFile:='$$$.MID';
  1563.   FRMITempFile:='$$$.RMI';
  1564.   FTempFilePath:='C:\';
  1565.   MsgFont:=TFont.Create;
  1566.   BitMsg := TBitmap.Create;
  1567.   MessageRunning:=False;
  1568.   SetupMsg:=Nil;
  1569.   DelayCounter:=0;
  1570.   Color:=clWindow;
  1571.   FAutoMMHide := False;
  1572. end;
  1573. {------------------------------------------------------------------------}
  1574.  
  1575. destructor TDBMultiMedia.Destroy;
  1576. begin
  1577.   CleanUpMultiMedia;
  1578.   FPicture.Free;
  1579.   FDataLink.Free;
  1580.   MsgFont.Free;
  1581.   BitMsg.Free;
  1582.   FDataLink := nil;
  1583.   inherited Destroy;
  1584. end;
  1585. {------------------------------------------------------------------------}
  1586.  
  1587. function TDBMultiMedia.GetDataSource: TDataSource;
  1588. begin
  1589.   Result := FDataLink.DataSource;
  1590. end;
  1591. {------------------------------------------------------------------------}
  1592.  
  1593. procedure TDBMultiMedia.SetDataSource(Value: TDataSource);
  1594. begin
  1595.   FDataLink.DataSource := Value;
  1596. end;
  1597. {------------------------------------------------------------------------}
  1598.  
  1599. function TDBMultiMedia.GetDataField: string;
  1600. begin
  1601.   Result := FDataLink.FieldName;
  1602. end;
  1603. {------------------------------------------------------------------------}
  1604.  
  1605. procedure TDBMultiMedia.SetDataField(const Value: string);
  1606. begin
  1607.   FDataLink.FieldName := Value;
  1608. end;
  1609. {------------------------------------------------------------------------}
  1610.  
  1611. function TDBMultiMedia.GetReadOnly: Boolean;
  1612. begin
  1613.   Result := FDataLink.ReadOnly;
  1614. end;
  1615. {------------------------------------------------------------------------}
  1616.  
  1617. procedure TDBMultiMedia.SetReadOnly(Value: Boolean);
  1618. begin
  1619.   FDataLink.ReadOnly := Value;
  1620. end;
  1621. {------------------------------------------------------------------------}
  1622.  
  1623. function TDBMultiMedia.GetField: TField;
  1624. begin
  1625.   Result := FDataLink.Field;
  1626. end;
  1627. {------------------------------------------------------------------------}
  1628.  
  1629. function TDBMultiMedia.GetPalette: HPALETTE;
  1630. begin
  1631.   Result := 0;
  1632.   if ImageLibPalette then exit;
  1633.   if FPicture.Graphic is TBitmap then
  1634.     Result := TBitmap(FPicture.Graphic).Palette;
  1635. end;
  1636. {------------------------------------------------------------------------}
  1637.  
  1638. procedure TDBMultiMedia.SetAutoDisplay(Value: Boolean);
  1639. begin
  1640.   if FAutoDisplay <> Value then
  1641.   begin
  1642.     FAutoDisplay := Value;
  1643.     if Value then LoadMedia;
  1644.   end;
  1645. end;
  1646. {------------------------------------------------------------------------}
  1647.  
  1648. procedure TDBMultiMedia.SetBorderStyle(Value: TBorderStyle);
  1649. begin
  1650.   if FBorderStyle <> Value then
  1651.   begin
  1652.     FBorderStyle := Value;
  1653.     RecreateWnd;
  1654.   end;
  1655. end;
  1656. {------------------------------------------------------------------------}
  1657.  
  1658. procedure TDBMultiMedia.SetCenter(Value: Boolean);
  1659. begin
  1660.   if FCenter <> Value then
  1661.   begin
  1662.     FCenter := Value;
  1663.     Invalidate;
  1664.   end;
  1665. end;
  1666. {------------------------------------------------------------------------}
  1667.  
  1668. procedure TDBMultiMedia.SetPicture(Value: TPicture);
  1669. begin
  1670.   FPicture.Assign(Value);
  1671. end;
  1672. {------------------------------------------------------------------------}
  1673.  
  1674. procedure TDBMultiMedia.SetStretch(Value: Boolean);
  1675. begin
  1676.   if FStretch <> Value then
  1677.   begin
  1678.     FStretch := Value;
  1679.     Invalidate;
  1680.   end;
  1681. end;
  1682. {------------------------------------------------------------------------}
  1683.  
  1684. procedure TDBMultiMedia.Paint;
  1685. var
  1686.   W, H        : Integer;
  1687.   R           : TRect;
  1688.   S           : string[63];
  1689.   OldBitmap   : HBitmap;
  1690.   MemDC       : HDC;
  1691.   hOldPal     : HPalette;
  1692. begin
  1693.  
  1694.   if (BFileType = 'ICO') or (BFileType = 'WMF') or (not ImageLibPalette) then begin
  1695.       PaintTheDelpiWay;
  1696.       exit;
  1697.   end;
  1698.  
  1699.   with Canvas do begin
  1700.     Brush.Style := bsSolid;
  1701.     Brush.Color := Color;
  1702.  
  1703.     if FPictureLoaded then begin
  1704.       if (Stretch) and (Picture.Graphic <> nil) then
  1705.  
  1706.         if Picture.Graphic.Empty then
  1707.           FillRect(ClientRect) else
  1708.          begin
  1709.  
  1710.             hOldPal := SelectPalette(Canvas.handle,Picture.BitMap.Palette,False);
  1711.             RealizePalette(Canvas.handle);
  1712.  
  1713.             MemDC := CreateCompatibleDC(Canvas.handle);
  1714.             OldBitmap := SelectObject(MemDC,Picture.BitMap.Handle);
  1715.  
  1716.             SetStretchBltMode(canvas.handle,STRETCH_DELETESCANS);
  1717.  
  1718.             StretchBlt(Canvas.handle,
  1719.                        ClientRect.Left,
  1720.                        ClientRect.Top,
  1721.                        ClientRect.Right,
  1722.                        ClientRect.Bottom,
  1723.                        MemDC,
  1724.                        ClientRect.Left,
  1725.                        ClientRect.Top,
  1726.                        Picture.BitMap.Width,
  1727.                        Picture.BitMap.Height,
  1728.                        srcCopy);
  1729.  
  1730.              SelectObject(MemDC,OldBitmap);
  1731.              DeleteDC(MemDC);
  1732.              SelectPalette(Canvas.handle,hOldPal,False);
  1733.       end else begin
  1734.  
  1735.         SetRect(R, 0, 0, Picture.Width, Picture.Height);
  1736.         if Center then OffsetRect(R, (ClientWidth - Picture.Width) div 2,
  1737.           (ClientHeight - Picture.Height) div 2);
  1738.  
  1739.            hOldPal := SelectPalette(Canvas.handle,Picture.BitMap.Palette,False);
  1740.            RealizePalette(Canvas.handle);
  1741.  
  1742.            MemDC := CreateCompatibleDC(Canvas.handle);
  1743.            OldBitmap := SelectObject(MemDC,Picture.BitMap.Handle);
  1744.  
  1745.             BitBlt(Canvas.handle,
  1746.                        R.Left,
  1747.                        R.Top,
  1748.                        Picture.BitMap.Width,
  1749.                        Picture.BitMap.Height,
  1750.                        MemDC,
  1751.                        0,
  1752.                        0,
  1753.                        srcCopy);
  1754.  
  1755.              SelectObject(MemDC,OldBitmap);
  1756.              DeleteDC(MemDC);
  1757.              SelectPalette(Canvas.handle,hOldPal,False);
  1758.  
  1759.              ExcludeClipRect(Handle, R.Left, R.Top, R.Right, R.Bottom);
  1760.              FillRect(ClientRect);
  1761.              SelectClipRgn(Handle, 0);
  1762.       end;
  1763.     end else begin
  1764.      Font := Self.Font;
  1765.      if FDataLink.Field <> nil then
  1766.         S := FDataLink.Field.DisplayLabel
  1767.      else
  1768.         S := Name;
  1769.       S := '(' + S + ')';
  1770.       W := TextWidth(S);
  1771.       H := TextHeight(S);
  1772.       R := ClientRect;
  1773.       TextRect(R, (R.Right - W) div 2, (R.Bottom - H) div 2, S);
  1774.     end;
  1775.  
  1776.     if (GetParentForm(Self).ActiveControl = Self) and
  1777.       not (csDesigning in ComponentState) then begin
  1778.         Brush.Color := clWindowFrame;
  1779.         FrameRect(ClientRect);
  1780.     end;
  1781.  
  1782.   end;
  1783.  
  1784.   if (MessageRunning) and (Picture = nil) then FreeMsg;
  1785. end;
  1786. {------------------------------------------------------------------------}
  1787.  
  1788. procedure TDBMultiMedia.PaintTheDelpiWay;
  1789. var
  1790.   W, H: Integer;
  1791.   R: TRect;
  1792.   S: string[63];
  1793. begin
  1794.   with Canvas do
  1795.   begin
  1796.     Brush.Style := bsSolid;
  1797.     Brush.Color := Color;
  1798.     if FPictureLoaded then
  1799.     begin
  1800.       if (Stretch) and (Picture.Graphic <> nil) then
  1801.         if Picture.Graphic.Empty then
  1802.           FillRect(ClientRect) else
  1803.           StretchDraw(ClientRect, Picture.Graphic)
  1804.       else
  1805.       begin
  1806.         SetRect(R, 0, 0, Picture.Width, Picture.Height);
  1807.         if Center then OffsetRect(R, (ClientWidth - Picture.Width) div 2,
  1808.           (ClientHeight - Picture.Height) div 2);
  1809.         StretchDraw(R, Picture.Graphic);
  1810.         ExcludeClipRect(Handle, R.Left, R.Top, R.Right, R.Bottom);
  1811.         FillRect(ClientRect);
  1812.         SelectClipRgn(Handle, 0);
  1813.       end;
  1814.     end else
  1815.     begin
  1816.       Font := Self.Font;
  1817.       if FDataLink.Field <> nil then
  1818.         S := FDataLink.Field.DisplayLabel else
  1819.         S := Name;
  1820.       S := '(' + S + ')';
  1821.       W := TextWidth(S);
  1822.       H := TextHeight(S);
  1823.       R := ClientRect;
  1824.       TextRect(R, (R.Right - W) div 2, (R.Bottom - H) div 2, S);
  1825.     end;
  1826.     if (GetParentForm(Self).ActiveControl = Self) and
  1827.       not (csDesigning in ComponentState) then
  1828.     begin
  1829.       Brush.Color := clWindowFrame;
  1830.       FrameRect(ClientRect);
  1831.     end;
  1832.   end;
  1833.   if (MessageRunning) and (Picture = nil) then FreeMsg;
  1834. end;
  1835. {------------------------------------------------------------------------}
  1836.  
  1837. procedure TDBMultiMedia.PictureChanged(Sender: TObject);
  1838. begin
  1839.   FDataLink.Modified;
  1840.   FPictureLoaded := True;
  1841.   Invalidate;
  1842. end;
  1843. {------------------------------------------------------------------------}
  1844.  
  1845. procedure TDBMultiMedia.Notification(AComponent: TComponent;
  1846.   Operation: TOperation);
  1847. begin
  1848.   inherited Notification(AComponent, Operation);
  1849.   if (Operation = opRemove) and (FDataLink <> nil) and
  1850.     (AComponent = DataSource) then DataSource := nil;
  1851.  
  1852.   if (Operation = opRemove) and
  1853.     (AComponent = FMediaPlayer) then FMediaPlayer := nil;
  1854. end;
  1855. {------------------------------------------------------------------------}
  1856.  
  1857. Procedure TDBMultiMedia.CleanUpMultiMedia;
  1858. begin
  1859.    if (csDesigning in ComponentState) then exit;
  1860.    deletefile(FTempFilePath+FMPGTempFile);
  1861.    deletefile(FTempFilePath+FMOVTempFile);
  1862.    deletefile(FTempFilePath+FAVITempFile);
  1863.    deletefile(FTempFilePath+FWAVTempFile);
  1864.    deletefile(FTempFilePath+FMIDTempFile);
  1865.    deletefile(FTempFilePath+FRMITempFile);
  1866. end;
  1867.  
  1868.  
  1869. procedure TDBMultiMedia.LoadMedia;
  1870. var
  1871.    Stream       :  TMemoryStream;
  1872.    BitMap       :  TBitMap;
  1873.    Cursor       :  hCursor;
  1874.    Temp         :  string;
  1875. begin
  1876.  
  1877.   if (MessageRunning)then FreeMsg;
  1878.  
  1879.   if not FPictureLoaded and (FDataLink.Field is TBlobField) then begin
  1880.  
  1881.    if TBlobField(FDataLink.Field).IsNull then exit;
  1882.  
  1883.    Temp:=GetInfoAndType;
  1884.  
  1885.    if FMediaPlayer <> nil then
  1886.      FMediaPlayer.Close;
  1887.  
  1888.    CleanUpMultiMedia;
  1889.  
  1890.  
  1891.   if Temp = 'SCM' then begin
  1892.       Stream:=TMemoryStream.Create;
  1893.       try
  1894.        if FMediaPlayer <> nil then
  1895.          if FAutoMMHide then
  1896.            FMediaPlayer.Visible:=False;
  1897.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1898.          FreeMsg;
  1899.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  1900.          LoadMessageFromStream(Stream);
  1901.          KillTimer(handle,1);
  1902.          if @TDBMultiMediaCallBack <> nil then
  1903.            TDBMultiMediaCallBack(0);
  1904.        finally
  1905.          SetCursor(Cursor);
  1906.          Stream.Free;
  1907.        end;
  1908.    end else
  1909.  
  1910.   if Temp = 'MPG' then begin
  1911.          try
  1912.             if (csDesigning in ComponentState) then exit;
  1913.             if not IsValidMultiMedia('MPG') then exit;
  1914.               Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1915.               FreeMsg;
  1916.               if FMediaPlayer <> nil then begin
  1917.                FMediaPlayer.Visible:=true;
  1918.                TBlobField(FDataLink.Field).SaveToFile(FTempFilePath+FMPGTempFile);
  1919.                FMediaPlayer.FileName:=FTempFilePath+FMPGTempFile;
  1920.                FMediaPlayer.Open;
  1921.                if FAutoPlayMM then
  1922.                  FMediaPlayer.Play;
  1923.                SetTimer(handle,1,500,nil);
  1924.             end;
  1925.          finally
  1926.             SetCursor(Cursor);
  1927.          end;
  1928.    end else
  1929.  
  1930.    if Temp = 'MOV' then begin
  1931.          try
  1932.             if (csDesigning in ComponentState) then exit;
  1933.             if not IsValidMultiMedia('MOV') then exit;
  1934.               Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1935.               FreeMsg;
  1936.               if FMediaPlayer <> nil then begin
  1937.                FMediaPlayer.Visible:=true;
  1938.                TBlobField(FDataLink.Field).SaveToFile(FTempFilePath+FMOVTempFile);
  1939.                FMediaPlayer.FileName:=FTempFilePath+FMOVTempFile;
  1940.                FMediaPlayer.Open;
  1941.                if FAutoPlayMM then
  1942.                  FMediaPlayer.Play;
  1943.                SetTimer(handle,1,500,nil);
  1944.             end;
  1945.          finally
  1946.             SetCursor(Cursor);
  1947.          end;
  1948.    end else
  1949.  
  1950.    if Temp = 'AVI' then begin
  1951.          try
  1952.             if (csDesigning in ComponentState) then exit;
  1953.             if not IsValidMultiMedia('AVI') then exit;
  1954.               Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1955.               FreeMsg;
  1956.               if FMediaPlayer <> nil then begin
  1957.                FMediaPlayer.Visible:=true;
  1958.                TBlobField(FDataLink.Field).SaveToFile(FTempFilePath+FAVITempFile);
  1959.                FMediaPlayer.FileName:=FTempFilePath+FAVITempFile;
  1960.                FMediaPlayer.Open;
  1961.                if FAutoPlayMM then
  1962.                  FMediaPlayer.Play;
  1963.                SetTimer(handle,1,500,nil);
  1964.             end;
  1965.          finally
  1966.             SetCursor(Cursor);
  1967.          end;
  1968.    end else
  1969.  
  1970.    if Temp = 'WAV' then begin
  1971.          try
  1972.             if (csDesigning in ComponentState) then exit;
  1973.             if not IsValidMultiMedia('WAV') then exit;
  1974.              Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1975.              FreeMsg;
  1976.              if FMediaPlayer <> nil then begin
  1977.                FMediaPlayer.Visible:=true;
  1978.                TBlobField(FDataLink.Field).SaveToFile(FTempFilePath+FWAVTempFile);
  1979.                FMediaPlayer.FileName:=FTempFilePath+FWAVTempFile;
  1980.                FMediaPlayer.Open;
  1981.                if FAutoPlayMM then
  1982.                  FMediaPlayer.Play;
  1983.                SetTimer(handle,1,500,nil);
  1984.             end;
  1985.          finally
  1986.             SetCursor(Cursor);
  1987.          end;
  1988.    end else
  1989.  
  1990.    if Temp = 'MID' then begin
  1991.          try
  1992.             if (csDesigning in ComponentState) then exit;
  1993.             if not IsValidMultiMedia('MID') then exit;
  1994.              Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1995.              FreeMsg;
  1996.              if FMediaPlayer <> nil then begin
  1997.                FMediaPlayer.Visible:=true;
  1998.                TBlobField(FDataLink.Field).SaveToFile(FTempFilePath+FMIDTempFile);
  1999.                FMediaPlayer.FileName:=FTempFilePath+FMIDTempFile;
  2000.                FMediaPlayer.Open;
  2001.                if FAutoPlayMM then
  2002.                  FMediaPlayer.Play;
  2003.                SetTimer(handle,1,500,nil);
  2004.             end;
  2005.          finally
  2006.             SetCursor(Cursor);
  2007.          end;
  2008.    end else
  2009.  
  2010.    if Temp = 'RMI' then begin
  2011.          try
  2012.             if (csDesigning in ComponentState) then exit;
  2013.             if not IsValidMultiMedia('RMI') then exit;
  2014.             Cursor := SetCursor(LoadCursor(0,idc_Wait));
  2015.             FreeMsg;
  2016.             if FMediaPlayer <> nil then begin
  2017.                FMediaPlayer.Visible:=true;
  2018.                TBlobField(FDataLink.Field).SaveToFile(FTempFilePath+FRMITempFile);
  2019.                FMediaPlayer.FileName:=FTempFilePath+FRMITempFile;
  2020.                FMediaPlayer.Open;
  2021.                if FAutoPlayMM then
  2022.                  FMediaPlayer.Play;
  2023.                SetTimer(handle,1,500,nil);
  2024.             end;
  2025.          finally
  2026.             SetCursor(Cursor);
  2027.          end;
  2028.    end else
  2029.  
  2030.    if Temp = 'GIF' then begin
  2031.       Stream:=TMemoryStream.Create;
  2032.       BitMap:=TBitMap.Create;
  2033.       try
  2034.        if FMediaPlayer <> nil then
  2035.          if FAutoMMHide then
  2036.            FMediaPlayer.Visible:=False;
  2037.          KillTimer(handle,1);
  2038.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  2039.          FreeMsg;
  2040.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  2041.          if not gifblob(Stream.Memory,Stream.Size, Bitmap, TDBMultiMediaCallBack) then begin
  2042.             MessageDlg('Invallid or empty GIF blobfield', mtInformation, [mbOk], 0);
  2043.             Picture.Assign(Nil);
  2044.          end else
  2045.             Picture.Assign(BitMap);
  2046.          finally
  2047.             SetCursor(Cursor);
  2048.             BitMap.free;
  2049.             Stream.Free;
  2050.          end;
  2051.    end else
  2052.  
  2053.    if Temp = 'PCX' then begin
  2054.       Stream:=TMemoryStream.Create;
  2055.       BitMap:=TBitMap.Create;
  2056.       try
  2057.        if FMediaPlayer <> nil then
  2058.          if FAutoMMHide then
  2059.            FMediaPlayer.Visible:=False;
  2060.          KillTimer(handle,1);
  2061.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  2062.          FreeMsg;
  2063.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  2064.          if not pcxblob(Stream.Memory,Stream.Size, Bitmap, TDBMultiMediaCallBack) then begin
  2065.             MessageDlg('Invallid or empty PCX blobfield', mtInformation, [mbOk], 0);
  2066.             Picture.Assign(Nil);
  2067.          end else
  2068.             Picture.Assign(BitMap);
  2069.          finally
  2070.           SetCursor(Cursor);
  2071.           BitMap.free;
  2072.           Stream.Free;
  2073.          end;
  2074.    end else
  2075.  
  2076.    if Temp = 'BMP' then begin
  2077.       Stream:=TMemoryStream.Create;
  2078.       BitMap:=TBitMap.Create;
  2079.       try
  2080.        if FMediaPlayer <> nil then
  2081.          if FAutoMMHide then
  2082.            FMediaPlayer.Visible:=False;
  2083.          KillTimer(handle,1);
  2084.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  2085.          FreeMsg;
  2086.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  2087.          if not bmpblob(Stream.Memory,Stream.Size, Bitmap, TDBMultiMediaCallBack) then begin
  2088.             MessageDlg('Invallid or empty BMP blobfield', mtInformation, [mbOk], 0);
  2089.             Picture.Assign(Nil);
  2090.          end else
  2091.             Picture.Assign(BitMap);
  2092.          finally
  2093.           SetCursor(Cursor);
  2094.           BitMap.free;
  2095.           Stream.Free;
  2096.          end;
  2097.    end else
  2098.  
  2099.    if Temp = 'JPG' then begin
  2100.       Stream:=TMemoryStream.Create;
  2101.       BitMap:=TBitMap.Create;
  2102.       if FResolution <> 4 then
  2103.       if FResolution <> 8 then
  2104.       if FResolution <> 24 then FResolution:=8;
  2105.       if (FDither < 0) or (FDither > 4) then FDither:=4;
  2106.       try
  2107.        if FMediaPlayer <> nil then
  2108.          if FAutoMMHide then
  2109.            FMediaPlayer.Visible:=False;
  2110.          KillTimer(handle,1);
  2111.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  2112.          FreeMsg;
  2113.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  2114.          if not jpgblob(Stream.Memory,Stream.Size, FResolution, Fdither, Bitmap, TDBMultiMediaCallBack) then begin
  2115.             MessageDlg('Invallid or empty Jpeg Blobfield', mtInformation, [mbOk], 0);
  2116.             Picture.Assign(Nil);
  2117.          end else
  2118.              Picture.Assign(BitMap);
  2119.          finally
  2120.              SetCursor(Cursor);
  2121.              BitMap.free;
  2122.              Stream.Free;
  2123.          end;
  2124.     end else
  2125.      KillTimer(handle,1);
  2126.     {GetInfoAndType;}
  2127.  end;
  2128. end;
  2129. {------------------------------------------------------------------------}
  2130.  
  2131. procedure TDBMultiMedia.DataChange(Sender: TObject);
  2132. begin
  2133.   If MessageRunning then FreeMsg;
  2134.   Picture.Graphic := nil;
  2135.   FPictureLoaded := False;
  2136.   if FAutoDisplay then LoadMedia;
  2137. end;
  2138. {------------------------------------------------------------------------}
  2139.  
  2140. procedure TDBMultiMedia.UpdateData(Sender: TObject);
  2141. var
  2142.    Stream       :  TMemoryStream;
  2143.    Cursor       :  hCursor;
  2144.    Usize        :  longInt;
  2145.    x,y          :  longInt;
  2146.    p            :  Pointer;
  2147. begin
  2148.   if FDataLink.Field is TBlobField then begin
  2149.  
  2150.     if Picture.Graphic is TBitmap then begin
  2151.       x:=Picture.BitMap.Width;
  2152.       y:=Picture.BitMap.Height;
  2153.  
  2154.       y:=y+(y div 5);
  2155.       x:=x+(x div 5);
  2156.  
  2157.       Usize:=(y * x);
  2158.  
  2159.       if Usize < 90000 then Usize:=Usize*2;
  2160.  
  2161.       {Since we can't know how much memory we need to allocate
  2162.       to write the picture to the stream we need to guess it. This
  2163.       is done using the width and height of the bitmap. After the call
  2164.       to the dll using PUTJPGBLOB or PUTBMPBLOB Usize contains the
  2165.       correct size of the Bitmap stored in P^. You can increase or decrease
  2166.       the guessed memory by altering the Div by. For instance
  2167.  
  2168.       y:=y+(y div 3);
  2169.       x:=x+(x div 3);
  2170.  
  2171.       will allocate more memory then
  2172.  
  2173.       y:=y+(y div 6);
  2174.       x:=x+(x div 6);
  2175.  
  2176.       We played it on the save side. Use this "guess work" very carefully}
  2177.  
  2178.  
  2179.       P := GlobalAllocPtr(HeapAllocFlags, Usize);
  2180.       if P = Nil then
  2181.         exit;
  2182.  
  2183.       if FUpdateAsJpeg then begin
  2184.          if not putjpgblob(P, USize, FSaveQuality, FSaveSmooth, Picture.Bitmap, TDBMultiMediaCallBack) then
  2185.            MessageDlg('Jpeg BLOB Write Error', mtInformation, [mbOk], 0);
  2186.       end else begin
  2187.          if not putbmpblob(P, USize, Picture.Bitmap, TDBMultiMediaCallBack) then
  2188.            MessageDlg('BMP BLOB Write Error', mtInformation, [mbOk], 0);
  2189.       end;
  2190.  
  2191.       Stream:=TMemoryStream.Create;
  2192.       Stream.Write(P^,USize);
  2193.       GlobalFreePtr(P);
  2194.  
  2195.       try
  2196.         TBlobField(FDataLink.Field).LoadFromStream(Stream);
  2197.       finally
  2198.         Stream.Free;
  2199.       end;
  2200.  
  2201.     end else
  2202.       TBlobField(FDataLink.Field).Clear;
  2203.    end;
  2204.    GetInfoAndType;
  2205. end;
  2206. {------------------------------------------------------------------------}
  2207.  
  2208. procedure TDBMultiMedia.CopyToClipboard;
  2209. begin
  2210.   if Picture.Graphic <> nil then Clipboard.Assign(Picture);
  2211. end;
  2212. {------------------------------------------------------------------------}
  2213.  
  2214. procedure TDBMultiMedia.CutToClipboard;
  2215. begin
  2216.   if Picture.Graphic <> nil then
  2217.   begin
  2218.     CopyToClipboard;
  2219.     if FDataLink.Edit then
  2220.       Picture.Graphic := nil;
  2221.   end;
  2222. end;
  2223. {------------------------------------------------------------------------}
  2224.  
  2225. procedure TDBMultiMedia.PasteFromClipboard;
  2226. begin
  2227.   if Clipboard.HasFormat(CF_PICTURE) and FDataLink.Edit then begin
  2228.     MessageRunning:=False;
  2229.     Picture.Assign(Clipboard);
  2230.    end;
  2231. end;
  2232. {------------------------------------------------------------------------}
  2233.  
  2234. procedure TDBMultiMedia.CreateParams(var Params: TCreateParams);
  2235. begin
  2236.   inherited CreateParams(Params);
  2237.   if FBorderStyle = bsSingle then
  2238.     Params.Style := Params.Style or WS_BORDER;
  2239. end;
  2240. {------------------------------------------------------------------------}
  2241.  
  2242. procedure TDBMultiMedia.KeyDown(var Key: Word; Shift: TShiftState);
  2243. begin
  2244.   inherited KeyDown(Key, Shift);
  2245.   case Key of
  2246.     VK_INSERT:
  2247.       if ssShift in Shift then PasteFromClipBoard else
  2248.         if ssCtrl in Shift then CopyToClipBoard;
  2249.     VK_DELETE:
  2250.       if ssShift in Shift then CutToClipBoard;
  2251.   end;
  2252. end;
  2253. {------------------------------------------------------------------------}
  2254.  
  2255. procedure TDBMultiMedia.KeyPress(var Key: Char);
  2256. begin
  2257.   inherited KeyPress(Key);
  2258.   case Key of
  2259.     ^X: CutToClipBoard;
  2260.     ^C: CopyToClipBoard;
  2261.     ^V: PasteFromClipBoard;
  2262.     #13: LoadMedia;
  2263.     #27: FDataLink.Reset;
  2264.   end;
  2265. end;
  2266. {------------------------------------------------------------------------}
  2267.  
  2268. procedure TDBMultiMedia.CMEnter(var Message: TCMEnter);
  2269. begin
  2270.   Invalidate; { Draw the focus marker }
  2271.   inherited;
  2272. end;
  2273. {------------------------------------------------------------------------}
  2274.  
  2275. procedure TDBMultiMedia.CMExit(var Message: TCMExit);
  2276. begin
  2277.   Invalidate; { Erase the focus marker }
  2278.   inherited;
  2279. end;
  2280. {------------------------------------------------------------------------}
  2281.  
  2282. procedure TDBMultiMedia.CMTextChanged(var Message: TMessage);
  2283. begin
  2284.   inherited;
  2285.   if not FPictureLoaded then Invalidate;
  2286. end;
  2287. {------------------------------------------------------------------------}
  2288.  
  2289. procedure TDBMultiMedia.WMLButtonDown(var Message: TWMLButtonDown);
  2290. begin
  2291.   if TabStop and CanFocus then SetFocus;
  2292.   inherited;
  2293. end;
  2294. {------------------------------------------------------------------------}
  2295.  
  2296. procedure TDBMultiMedia.WMLButtonDblClk(var Message: TWMLButtonDblClk);
  2297. begin
  2298.   LoadMedia;
  2299.   inherited;
  2300. end;
  2301. {------------------------------------------------------------------------}
  2302.  
  2303. procedure TDBMultiMedia.WMCut(var Message: TMessage);
  2304. begin
  2305.   CutToClipboard;
  2306. end;
  2307. {------------------------------------------------------------------------}
  2308.  
  2309. procedure TDBMultiMedia.WMCopy(var Message: TMessage);
  2310. begin
  2311.   CopyToClipboard;
  2312. end;
  2313. {------------------------------------------------------------------------}
  2314.  
  2315. procedure TDBMultiMedia.WMPaste(var Message: TMessage);
  2316. begin
  2317.   PasteFromClipboard;
  2318. end;
  2319. {------------------------------------------------------------------------}
  2320.  
  2321. procedure TDBMultiMedia.LoadFromFile(filename : TFilename);
  2322. var
  2323.    Cursor       :  hCursor;
  2324. begin
  2325.  
  2326.   if not FileExists(filename) then begin
  2327.     MessageDlg('File not found', mtInformation, [mbOk], 0);
  2328.     exit;
  2329.   end;
  2330.  
  2331.   if UpperCase(ExtractFileExt(filename)) <> '.JPG' then
  2332.   if UpperCase(ExtractFileExt(filename)) <> '.GIF' then
  2333.   if UpperCase(ExtractFileExt(filename)) <> '.PCX' then
  2334.   if UpperCase(ExtractFileExt(filename)) <> '.BMP' then
  2335.   if UpperCase(ExtractFileExt(filename)) <> '.WAV' then
  2336.   if UpperCase(ExtractFileExt(filename)) <> '.AVI' then
  2337.   if UpperCase(ExtractFileExt(filename)) <> '.MOV' then
  2338.   if UpperCase(ExtractFileExt(filename)) <> '.MID' then
  2339.   if UpperCase(ExtractFileExt(filename)) <> '.RMI' then
  2340.   if UpperCase(ExtractFileExt(filename)) <> '.SCM' then
  2341.   {if UpperCase(ExtractFileExt(filename)) <> '.MPG' then}
  2342.   begin
  2343.     MessageDlg('A None Supported File Format', mtInformation, [mbOk], 0);
  2344.     exit;
  2345.   end;
  2346.  
  2347.   if FDataLink.Field is TBlobField then begin
  2348.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  2349.     TBlobField(FDataLink.Field).LoadFromFile(filename);
  2350.     SetCursor(Cursor);
  2351.   end else begin
  2352.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  2353.     exit;
  2354.   end;
  2355.   {GetInfoAndType;}
  2356.   SetCursor(Cursor);
  2357. end;
  2358. {------------------------------------------------------------------------}
  2359.  
  2360. procedure TDBMultiMedia.SaveToFile(filename : TFilename);
  2361. var
  2362.   Cursor       :  hCursor;
  2363. begin
  2364.   if FDataLink.Field is TBlobField then begin
  2365.  
  2366.     if TBlobField(FDataLink.Field).IsNull then begin
  2367.        MessageDlg('Can''t save, blobfield is empty', mtInformation, [mbOk], 0);
  2368.        exit;
  2369.     end;
  2370.  
  2371.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  2372.     TBlobField(FDataLink.Field).SaveToFile(filename);
  2373.     GetInfoAndType;
  2374.     SetCursor(Cursor)
  2375.  
  2376.   end else begin
  2377.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  2378.     exit;
  2379.   end;
  2380. end;
  2381. {------------------------------------------------------------------------}
  2382.  
  2383. procedure TDBMultiMedia.SaveToFileAsBMP(filename : TFilename);
  2384. var
  2385.   Cursor       :  hCursor;
  2386. begin
  2387.   if FDataLink.Field is TBlobField then begin
  2388.  
  2389.     if TBlobField(FDataLink.Field).IsNull then begin
  2390.        MessageDlg('Can''t save, blobfield bitmap is empty', mtInformation, [mbOk], 0);
  2391.        exit;
  2392.     end;
  2393.  
  2394.     if picture.bitmap.empty then begin
  2395.        MessageDlg('Can''t save, image is not displayed, Set Autodisplay or double click display to view image first.',
  2396.                   mtInformation, [mbOk], 0);
  2397.        exit;
  2398.     end;
  2399.  
  2400.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  2401.  
  2402.     if not putbmpfile(FileName, picture.Bitmap, TDBMultiMediaCallBack) then begin
  2403.       SetCursor(Cursor);
  2404.       MessageDlg('Writing bmp file failed', mtInformation, [mbOk], 0);
  2405.       exit;
  2406.     end;
  2407.  
  2408.     GetInfoAndType
  2409.  
  2410.   end else begin
  2411.     SetCursor(Cursor);
  2412.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  2413.     exit;
  2414.   end;
  2415.  
  2416.   SetCursor(Cursor);
  2417. end;
  2418. {------------------------------------------------------------------------}
  2419.  
  2420. procedure TDBMultiMedia.SaveToFileAsJpeg(filename : TFilename);
  2421. var
  2422.   Cursor       :  hCursor;
  2423. begin
  2424.   if FDataLink.Field is TBlobField then begin
  2425.  
  2426.     if TBlobField(FDataLink.Field).IsNull then begin
  2427.        MessageDlg('Can''t save, blobfield bitmap is empty', mtInformation, [mbOk], 0);
  2428.        exit;
  2429.     end;
  2430.  
  2431.     if picture.bitmap = nil then begin
  2432.        MessageDlg('Can''t save, image is not displayed, Set Autodisplay or double click display to view image first.',
  2433.                   mtInformation, [mbOk], 0);
  2434.        exit;
  2435.     end;
  2436.  
  2437.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  2438.  
  2439.     if not putjpgfile(FileName, FSaveQuality, FSaveSmooth, picture.Bitmap, TDBMultiMediaCallBack) then begin
  2440.       SetCursor(Cursor);
  2441.       MessageDlg('Writing jpg file failed', mtInformation, [mbOk], 0);
  2442.       exit;
  2443.     end;
  2444.  
  2445.     GetInfoAndType
  2446.  
  2447.   end else begin
  2448.     SetCursor(Cursor);
  2449.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  2450.     exit;
  2451.   end;
  2452.  
  2453.   SetCursor(Cursor);
  2454. end;
  2455. {------------------------------------------------------------------------}
  2456.  
  2457.  
  2458. function TDBMultiMedia.GetInfoAndType : String;
  2459. var
  2460.  Stream       :  TMemoryStream;
  2461.  Hdr          :  Array[0..45] of char;
  2462.  i            :  Byte;
  2463. begin
  2464.   if (FDataLink.Field is TBlobField) then
  2465.    if TBlobField(FDataLink.Field).IsNull then exit;
  2466.  
  2467.    BFileType := 'Empty';
  2468.    Bwidth:=-1;
  2469.    BHeight:=-1;
  2470.    Bbitspixel:=-1;
  2471.    Bplanes:=-1;
  2472.    Bnumcolors:=-1;
  2473.    Bcompression:='-1';
  2474.    BSize:=-1;
  2475.    GetInfoAndType :='-1';
  2476.  
  2477.    Stream:=TMemoryStream.Create;
  2478.    TBlobField(FDataLink.Field).SaveToStream(Stream);
  2479.  
  2480.    if Stream.Memory = nil then begin
  2481.      MessageDlg('Error allocation temporary blob memory', mtInformation, [mbOk], 0);
  2482.      exit;
  2483.    end;
  2484.  
  2485.    Stream.Seek(0,0);
  2486.    Stream.read(hdr,SizeOf(Hdr)-1);
  2487.  
  2488.    for i:=0 to SizeOf(hdr)-1 do
  2489.     if hdr[i] = #0 then hdr[i]:=' ';
  2490.  
  2491.    if StrPos(hdr,'RIFF') <> nil then begin
  2492.         Bwidth:=-1;
  2493.         BHeight:=-1;
  2494.         Bbitspixel:=-1;
  2495.         Bplanes:=-1;
  2496.         Bnumcolors:=-1;
  2497.         Bcompression:='RIFF';
  2498.  
  2499.      if StrPos(hdr,'WAV') <> nil then begin
  2500.         BSize:=Stream.Size;
  2501.         BFileType:= 'WAV';
  2502.         GetInfoAndType:='WAV';
  2503.      end;
  2504.  
  2505.      if StrPos(hdr,'AVI') <> nil then begin
  2506.         BSize:=Stream.Size;
  2507.         BFileType:= 'AVI';
  2508.         GetInfoAndType:='AVI';
  2509.      end;
  2510.  
  2511.      if StrPos(hdr,'RMID') <> nil then begin
  2512.         BSize:=Stream.Size;
  2513.         BFileType:= 'RMI';
  2514.         GetInfoAndType:='RMI';
  2515.      end;
  2516.  
  2517.      if Stream.Memory <> nil then Stream.Free;
  2518.      exit;
  2519.    end else
  2520.  
  2521. {   if StrPos(hdr,'mpeg') <> nil then begin
  2522.         Bwidth:=-1;
  2523.         BHeight:=-1;
  2524.         Bbitspixel:=-1;
  2525.         Bplanes:=-1;
  2526.         Bnumcolors:=-1;
  2527.         Bcompression:='MPEG';
  2528.         BSize:=Stream.Size;
  2529.         BFileType:= 'MPG';
  2530.         GetInfoAndType:='MPG';
  2531.         if Stream.Memory <> nil then Stream.Free;
  2532.         exit;
  2533.    end else}
  2534.  
  2535.    if StrPos(hdr,'mdat') <> nil then begin
  2536.         Bwidth:=-1;
  2537.         BHeight:=-1;
  2538.         Bbitspixel:=-1;
  2539.         Bplanes:=-1;
  2540.         Bnumcolors:=-1;
  2541.         Bcompression:='QTM';
  2542.         BSize:=Stream.Size;
  2543.         BFileType:= 'MOV';
  2544.         GetInfoAndType:='MOV';
  2545.         if Stream.Memory <> nil then Stream.Free;
  2546.         exit;
  2547.    end else
  2548.  
  2549.    if StrPos(hdr,'MThd') <> nil then begin
  2550.         Bwidth:=-1;
  2551.         BHeight:=-1;
  2552.         Bbitspixel:=-1;
  2553.         Bplanes:=-1;
  2554.         Bnumcolors:=-1;
  2555.         Bcompression:='MIDI';
  2556.         BSize:=Stream.Size;
  2557.         BFileType:= 'MID';
  2558.         GetInfoAndType:='MID';
  2559.         if Stream.Memory <> nil then Stream.Free;
  2560.         exit;
  2561.      end else
  2562.  
  2563.    if StrPos(hdr,'kevinjan') <> nil then begin
  2564.         Bwidth:=-1;
  2565.         BHeight:=-1;
  2566.         Bbitspixel:=-1;
  2567.         Bplanes:=-1;
  2568.         Bnumcolors:=-1;
  2569.         Bcompression:='MSG';
  2570.         BSize:=Stream.Size;
  2571.         BFileType:= 'SCM';
  2572.         GetInfoAndType:='SCM';
  2573.         if Stream.Memory <> nil then Stream.Free;
  2574.         exit;
  2575.      end else
  2576.  
  2577.  if not GetBlobInfo(Stream.Memory,
  2578.                     Stream.Size,
  2579.                     BFileType,
  2580.                     Bwidth,
  2581.                     BHeight,
  2582.                     Bbitspixel,
  2583.                     Bplanes,
  2584.                     Bnumcolors,
  2585.                     Bcompression) then
  2586.        MessageDlg('blobfield getinfo failed', mtInformation, [mbOk], 0)
  2587.     else begin
  2588.        BSize:=Stream.Size;
  2589.        if UpperCase(BFileType) = 'GIF' then GetInfoAndType:='GIF' else
  2590.        if UpperCase(BFileType) = 'PCX' then GetInfoAndType:='PCX' else
  2591.        if UpperCase(BFileType) = 'JPEG' then GetInfoAndType:='JPG' else
  2592.        if UpperCase(BFileType) = 'BMP' then GetInfoAndType:='BMP';
  2593.     end;
  2594.   if Stream.Memory <> nil then Stream.Free;
  2595. end;
  2596. {------------------------------------------------------------------------}
  2597.  
  2598. function TDBMultiMedia.GetSmooth : Byte;
  2599. begin
  2600.   GetSmooth:=FSaveSmooth;
  2601. end;
  2602. {------------------------------------------------------------------------}
  2603.  
  2604. procedure TDBMultiMedia.SetSmooth(Smooth : Byte);
  2605. begin
  2606.   if (Smooth > 100) or (Smooth < 0) then FSaveSmooth:=5 else
  2607.    FSaveSmooth:=Smooth;
  2608. end;
  2609. {------------------------------------------------------------------------}
  2610.  
  2611. function TDBMultiMedia.GetQuality : Byte;
  2612. begin
  2613.   GetQuality:=FSaveQuality;
  2614. end;
  2615. {------------------------------------------------------------------------}
  2616.  
  2617. procedure TDBMultiMedia.SetQuality(Quality : Byte);
  2618. begin
  2619.   if (Quality > 100) or (Quality < 1) then FSaveQuality:=25 else
  2620.    FSaveQuality:=Quality;
  2621. end;
  2622. {------------------------------------------------------------------------}
  2623.  
  2624. function TDBMultiMedia.GetDither : Byte;
  2625. begin
  2626.   GetDither:=Fdither
  2627. end;
  2628. {------------------------------------------------------------------------}
  2629.  
  2630. procedure TDBMultiMedia.SetDither(dith : Byte);
  2631. begin
  2632.   Fdither:=4;
  2633.   case dith of
  2634.             0..4 :Fdither:=dith;
  2635.   end;
  2636. end;
  2637. {------------------------------------------------------------------------}
  2638.  
  2639. function TDBMultiMedia.GetRes : Byte;
  2640. begin
  2641.   GetRes:=FResolution;
  2642. end;
  2643. {------------------------------------------------------------------------}
  2644.  
  2645. function TDBMultiMedia.GetTempPath : String;
  2646. begin
  2647.   GetTempPath:=FTempFilePath;
  2648. end;
  2649. {------------------------------------------------------------------------}
  2650.  
  2651. procedure TDBMultiMedia.SetTempPath(temppath : string);
  2652. var
  2653.  temp, OldDir : string;
  2654. begin
  2655.   temp:=AddBackSlash(TempPath);
  2656.   GetDir(0,OldDir);
  2657.  
  2658.   {$I-}
  2659.    ChDir(temp);
  2660.    if IOResult <> 0 then temp:='C:\';
  2661.   {$I+}
  2662.  
  2663.   (*try ChDir(temp); except temp:='C:\'; end;*)
  2664.   ChDir(OldDir);
  2665.   FTempFilePath:=temp;
  2666. end;
  2667. {------------------------------------------------------------------------}
  2668.  
  2669. procedure TDBMultiMedia.SetRes(res : Byte);
  2670. begin
  2671.   FResolution:=8;
  2672.   case res of
  2673.             4 :FResolution:=res;
  2674.             8 :FResolution:=res;
  2675.             24:FResolution:=res;
  2676.   end;
  2677. end;
  2678. {------------------------------------------------------------------------}
  2679.  
  2680. function TDBMultiMedia.GetMediaPlayer: TDBMediaPlayer;
  2681. begin
  2682.  Result:=FMediaPlayer;
  2683. end;
  2684. {------------------------------------------------------------------------}
  2685.  
  2686. procedure TDBMultiMedia.SetMediaPlayer(Value: TDBMediaPlayer);
  2687. begin
  2688.   FMediaPlayer:=Value;
  2689. end;
  2690. {------------------------------------------------------------------------}
  2691.  
  2692. function TDBMultiMedia.AddBackSlash(DirName : string) : string;
  2693. const
  2694.   DosDelimSet : set of Char = ['\', ':', #0];
  2695.   begin
  2696.     if DirName[Length(DirName)] in DosDelimSet then
  2697.       AddBackSlash := DirName
  2698.     else
  2699.       AddBackSlash := DirName+'\';
  2700.   end;
  2701. {------------------------------------------------------------------------}
  2702.  
  2703. function TDBMultiMedia.IsValidMultiMedia(Name : PChar) : boolean;
  2704.  var
  2705.   temp : Array[0..25] of char;
  2706. begin
  2707.    Result:=ValidMultiMedia(Name);
  2708. end;
  2709. {------------------------------------------------------------------------}
  2710.  
  2711. function TDBMultiMedia.GetMultiMediaExtensions : String;
  2712. var
  2713.   temp : string;
  2714. begin
  2715.   temp:='All MultiMedia|*.bmp;*.gif;*.pcx;*.jpg;*.scm;';
  2716.  
  2717.   if IsValidMultiMedia('wav') then
  2718.     temp:=temp+'*.wav;';
  2719.   if IsValidMultiMedia('mid') then
  2720.     temp:=temp+'*.mid;';
  2721.   if IsValidMultiMedia('rmi') then
  2722.     temp:=temp+'*.rmi;';
  2723.   if IsValidMultiMedia('avi') then
  2724.     temp:=temp+'*.avi;';
  2725.   if IsValidMultiMedia('mov') then
  2726.     temp:=temp+'*.mov;';
  2727.  {if IsValidMultiMedia('mgp') then
  2728.     temp:=temp+'*.mpg;';}
  2729.  
  2730.   temp:=temp+'|BMP Files|*.bmp';
  2731.   temp:=temp+'|GIF Files|*.gif';
  2732.   temp:=temp+'|JPG Files|*.jpg';
  2733.   temp:=temp+'|PCX Files|*.pcx';
  2734.   temp:=temp+'|SCM Files|*.scm';
  2735.  
  2736.   if IsValidMultiMedia('wav') then
  2737.     temp:=temp+'|Wave Files|*.wav';
  2738.   if IsValidMultiMedia('mid') then
  2739.     temp:=temp+'|Midi Files|*.mid';
  2740.   if IsValidMultiMedia('rmi') then
  2741.     temp:=temp+'|RMI Files|*.rmi';
  2742.   if IsValidMultiMedia('avi') then
  2743.     temp:=temp+'|AVI Files|*.avi';
  2744.   if IsValidMultiMedia('mov') then
  2745.     temp:=temp+'|Movie Files|*.mov';
  2746.   {if IsValidMultiMedia('mgp') then
  2747.    temp:=temp+'|Mpeg Files|*.mpg';}
  2748.  
  2749.   Result:=temp;
  2750. end;
  2751. {------------------------------------------------------------------------}
  2752.  
  2753. procedure TDBMultiMedia.TimerNotify(var Message: TMessage);
  2754. var
  2755.   MPosition : integer;
  2756. begin
  2757.  if FMediaPlayer = nil then exit;
  2758.  
  2759.  if not AutoRePlayMultiMedia then
  2760.    if FMediaPlayer.Mode <> MpPlaying then exit;
  2761.  
  2762.   MPosition:=Round(FMediaPlayer.Position * (100 / FMediaPlayer.length));
  2763.  
  2764.   if @TDBMultiMediaCallBack <> nil then
  2765.    TDBMultiMediaCallBack(MPosition);
  2766.  
  2767.   if (FAutoRePlayMM) and (MPosition >= 100) and (FMediaPlayer.FileName <> '') then
  2768.    FMediaPlayer.Play;
  2769.  
  2770. end;
  2771. {------------------------------------------------------------------------
  2772.  scrolling message stuff
  2773. ------------------------------------------------------------------------}
  2774.  
  2775. procedure TDBMultiMedia.LoadMessageFromStream(MessageStream : TStream);
  2776. var
  2777.   Msg      : TLabel;
  2778. begin
  2779.   FreeMsg;
  2780.   ScreenWd:=Width;
  2781.   ScreenHt:=Height;
  2782.   Msg := TLabel.Create(Self);
  2783.   readmessagefromstream(MessageStream, MsgFont, MsgSpeed, MsgBkGrnd, MsgText);
  2784.   Refresh;
  2785.   if MsgText[Length(MsgText)] <> ' ' then MsgText:=MsgText+' ';
  2786.   Msg.Parent :=Self;
  2787.   Msg.Visible := False;
  2788.   Msg.Font := MsgFont;
  2789.   Msg.Caption := MsgText;
  2790.   BitWidth:=Msg.Width;
  2791.   SMessageLeft := ScreenWd;
  2792.   SMessageRight := ScreenWd + Msg.Width;
  2793.   SMessageTop := (ScreenHt - Msg.Height) Div 2;
  2794.   BitMsg.Width := Msg.Width;
  2795.   BitMsg.Height := Msg.Height;
  2796.   OldColor:=Color;
  2797.   Color:=MsgBkGrnd;
  2798.  
  2799.   with BitMsg.Canvas do begin
  2800.     Brush.Color := MsgBkGrnd;
  2801.     Font := Msg.Font;
  2802.     TextOut(0,0,Msg.Caption);
  2803.   end;
  2804.  
  2805.    Msg.Free;
  2806.    Msg := nil;
  2807.    MessageRunning:=True;
  2808. end;
  2809. {------------------------------------------------------------------------}
  2810.  
  2811. procedure TDBMultiMedia.NewMessage;
  2812. var
  2813.   Msg      : TLabel;
  2814. begin
  2815.   FreeMsg;
  2816.   if MsgText = '' then exit;
  2817.   if MsgText[Length(MsgText)] <> ' ' then MsgText:=MsgText+' ';
  2818.   ScreenWd:=Width;
  2819.   ScreenHt:=Height;
  2820.   Msg := TLabel.Create(Self);
  2821.   Refresh;
  2822.   Msg.Parent :=Self;
  2823.   Msg.Visible := False;
  2824.   Msg.Font := MsgFont;
  2825.   Msg.Caption := MsgText;
  2826.   BitWidth:=Msg.Width;
  2827.   SMessageLeft := ScreenWd;
  2828.   SMessageRight := ScreenWd + Msg.Width;
  2829.   SMessageTop := (ScreenHt - Msg.Height) Div 2;
  2830.   BitMsg.Width := Msg.Width;
  2831.   BitMsg.Height := Msg.Height;
  2832.   OldColor:=Color;
  2833.   Color:=MsgBkGrnd;
  2834.  
  2835.   with BitMsg.Canvas do begin
  2836.     Brush.Color := MsgBkGrnd;
  2837.     Font := Msg.Font;
  2838.     TextOut(0,0,Msg.Caption);
  2839.   end;
  2840.  
  2841.    Msg.Free;
  2842.    Msg := nil;
  2843.    MessageRunning:=True;
  2844. end;
  2845. {------------------------------------------------------------------------}
  2846.  
  2847. Function TDBMultiMedia.CreateMessage : Boolean;
  2848. begin
  2849.  Result:=False;
  2850.  
  2851.  Application.CreateForm(TSetupMsg, SetupMsg );
  2852.  
  2853.  SetupMsg.ShowModal;
  2854.  
  2855.  if SetupMsg.ModalResult = mrOK then begin
  2856.   Result:=SaveMessageToStream(SetupMsg.MessageFont,
  2857.                               SetupMsg.MessageSpeed,
  2858.                               SetupMsg.MessageColor,
  2859.                               SetupMsg.MessageMsg);
  2860.  end;
  2861.  SetupMsg.destroy;
  2862.  SetupMsg:=Nil;
  2863. end;
  2864. {------------------------------------------------------------------------}
  2865.  
  2866. Procedure TDBMultiMedia.FreeMsg;
  2867. Begin
  2868.   Picture.Assign(nil);
  2869.   if MessageRunning then
  2870.   Color:=OldColor;
  2871.   MessageRunning:=False;
  2872. end;
  2873. {------------------------------------------------------------------------}
  2874.  
  2875. Function TDBMultiMedia.Delay(Ms : Integer) : boolean;
  2876. Begin
  2877.  Inc(DelayCounter);
  2878.  if DelayCounter > MS then begin
  2879.   DelayCounter:=0;
  2880.   Result:=true;
  2881.  end else
  2882.   Result:=false;
  2883. end;
  2884. {------------------------------------------------------------------------}
  2885.  
  2886. Procedure TDBMultiMedia.MoveMsg(Var WinMsg : TMessage);
  2887. Begin
  2888.   if Not MessageRunning then exit;
  2889.   if Not Delay(MsgSpeed)then exit;
  2890.   Dec(SMessageLeft,1);
  2891.   Dec(SMessageRight,1);
  2892.   Inc(MmsgCount,1);
  2893.   if SMessageRight < 0 then begin
  2894.     SMessageLeft := ScreenWd;
  2895.     SMessageRight := SMessageLeft + BitWidth;
  2896.   end;
  2897.     with Canvas do
  2898.        Draw(SMessageLeft,SMessageTop,BitMsg);
  2899. end;
  2900. {------------------------------------------------------------------------}
  2901.  
  2902. Procedure TDBMultiMedia.Trigger;
  2903. Begin
  2904.   if SetupMsg <> nil then SetupMsg.Trigger;
  2905.   if (visible) and (enabled) then
  2906.    PostMessage(Handle, WM_Trigger, 0, 0);
  2907. End;
  2908. {------------------------------------------------------------------------}
  2909.  
  2910. Function TDBMultiMedia.SaveMessageToStream(MFont  : Tfont;
  2911.                                            Mspeed : integer;
  2912.                                            MColor : Tcolor;
  2913.                                            MMsg   : String) : Boolean;
  2914. var
  2915.    Stream       :  TMemoryStream;
  2916.    Cursor       :  hCursor;
  2917.    Usize        :  longInt;
  2918.    P            :  Array[0..1602] of char;
  2919. begin
  2920.   Result:=True;
  2921.   if FDataLink.Field is TBlobField then begin
  2922.      If Length(MMsg) < 1 then
  2923.       begin
  2924.         Result:=False;
  2925.         exit;
  2926.        end;
  2927.  
  2928.       Usize:=WriteMessageToStream(MFont, MSpeed, MColor, MMsg, P);
  2929.  
  2930.       If Usize < 1 then
  2931.        begin
  2932.         Result:=False;
  2933.         exit;
  2934.        end;
  2935.  
  2936.       Stream:=TMemoryStream.Create;
  2937.       Stream.Write(P,Usize+1);
  2938.  
  2939.       try
  2940.         TBlobField(FDataLink.Field).LoadFromStream(Stream);
  2941.       finally
  2942.         Stream.Free;
  2943.       end;
  2944.      GetInfoAndType;
  2945.    end;
  2946. end;
  2947.  
  2948. {------------------------------------------------------------------------
  2949. Printing Stuff
  2950. ------------------------------------------------------------------------}
  2951.  
  2952. procedure TDBMultiMedia.PrintMultiImage(X, Y, pWidth, pHeight: Integer);
  2953. begin
  2954.  if Picture.Graphic.Empty then exit;
  2955.  
  2956.  if (BFiletype = 'ICO') or (BFiletype = 'WMF') then
  2957.    PrintICOWMF(X, Y, pWidth, pHeight)
  2958.  else
  2959.    PrintBitMap(X, Y, pWidth, pHeight)
  2960. end;
  2961. {---------------------------------------------------------------------}
  2962.  
  2963. procedure TDBMultiMedia.PrintBitMap(X, Y, pWidth, pHeight: Integer);
  2964. var
  2965.   Info     : PBitmapInfo;
  2966.   InfoSize : Integer;
  2967.   Image    : Pointer;
  2968.   ImageSize: Longint;
  2969. begin
  2970.    if (pWidth < 1) or (pHeight < 1) then begin
  2971.       pWidth:=Picture.Bitmap.Width;
  2972.       pHeight:=Picture.Bitmap.Height;
  2973.    end;
  2974.  
  2975.    Printer.Begindoc;
  2976.  
  2977.     with Picture.Bitmap do begin
  2978.       GetDIBSizes(Handle, InfoSize, ImageSize);
  2979.       Info := MemAlloc(InfoSize);
  2980.       try
  2981.         Image := MemAlloc(ImageSize);
  2982.         try
  2983.           GetDIB(Handle, Palette, Info^, Image^);
  2984.           with Info^.bmiHeader do
  2985.            StretchDIBits(Printer.Canvas.Handle, X, Y, pWidth,
  2986.             pHeight, 0, 0, biWidth, biHeight, Image, Info^,
  2987.             DIB_RGB_COLORS, SRCCOPY)
  2988.          finally
  2989.           FreeMem(Image, ImageSize);
  2990.          end;
  2991.       finally
  2992.        FreeMem(Info, InfoSize);
  2993.       end;
  2994.     end;
  2995.     Printer.Enddoc;
  2996.   end;
  2997. {---------------------------------------------------------------------}
  2998.  
  2999. procedure TDBMultiMedia.PrintICOWMF(X, Y, pWidth, pHeight: Integer);
  3000. begin
  3001.    if (pWidth < 1) or (pHeight < 1) then begin
  3002.     pWidth:=Picture.Graphic.Width;
  3003.     pHeight:=Picture.Graphic.Height;
  3004.    end;
  3005.  
  3006.    Printer.Begindoc;
  3007.  
  3008.    Printer.Canvas.StretchDraw(Rect(X, Y, pWidth, pHeight), Picture.Graphic);
  3009.  
  3010.    Printer.Enddoc;
  3011. end;
  3012.  
  3013. {------------------------------------------------------------------------}
  3014.  
  3015. {------------------------------------------------------------------------}
  3016.  
  3017.  
  3018.  
  3019. begin
  3020.  TDBMultiImageCallBack:=nil;
  3021.  TDBMultiMediaCallBack:=nil;
  3022. end.
  3023.  
  3024.  
  3025.