home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 1997 May / Pcwk0597.iso / delphi / imagelib / umail.pa_ / umail.pa
Text File  |  1995-10-01  |  8KB  |  289 lines
  1. {Part of Imagelib VCL/DLL Library.
  2. Written by Jan Dekkers and Kevin Adams (c) 1995. If you are a non
  3. registered client, you may use or alter this demo only for evaluation
  4. purposes.
  5.  
  6. Uses ImageLib 3.0
  7.  
  8. Changed callback in version 2.21 to a function with cdecl.
  9. using the C calling convention.
  10.  
  11.  
  12. scrolling text images
  13. Cut, Copy and Paste to/from the clipboard
  14. Printing bitmaps}
  15.  
  16. unit Umail;
  17.  
  18. interface
  19.  
  20. uses
  21.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  22.   Forms, Dialogs, ExtCtrls, DBCtrls, MPlayer, StdCtrls, DB,
  23.   DBTables, Gauges, Mask, Buttons, Spin, Tdmultip;
  24.  
  25. type
  26.   TMailOrderForm = class(TForm)
  27.     DataSource1: TDataSource;
  28.     Table1: TTable;
  29.     DBMultiImage1: TPDBMultiImage;
  30.     DBMultiMedia1: TPDBMultiMedia;
  31.     DBMemo1: TDBMemo;
  32.     DBMultiImage2: TPDBMultiImage;
  33.     AddMM: TBitBtn;
  34.     AddImage: TBitBtn;
  35.     AddMsg: TBitBtn;
  36.     BitBtn6: TBitBtn;
  37.     DBEdit1: TDBEdit;
  38.     DBEdit2: TDBEdit;
  39.     Gauge1: TGauge;
  40.     Gauge2: TGauge;
  41.     OpenDialog1: TOpenDialog;
  42.     DBMediaPlayer1: TPDBMediaPlayer;
  43.     SpinButton1: TSpinButton;
  44.     DBNavigator1: TDBNavigator;
  45.     BitBtn1: TBitBtn;
  46.     procedure FormCreate(Sender: TObject);
  47.     procedure AddImageClick(Sender: TObject);
  48.     procedure AddMMClick(Sender: TObject);
  49.     procedure DataSource1DataChange(Sender: TObject; Field: TField);
  50.     procedure AddMsgClick(Sender: TObject);
  51.     procedure SpinButton1DownClick(Sender: TObject);
  52.     procedure SpinButton1UpClick(Sender: TObject);
  53.     procedure BitBtn1Click(Sender: TObject);
  54.     procedure FormDestroy(Sender: TObject);
  55.   private
  56.     { Private declarations }
  57.     function JustPathname(PathName : string) : string;
  58.     Procedure Trigger(Sender : TObject; Var Done : Boolean);
  59.   public
  60.     { Public declarations }
  61.   end;
  62.  
  63. var
  64.   MailOrderForm: TMailOrderForm;
  65.  
  66. implementation
  67.  
  68. {$R *.DFM}
  69.  
  70.  
  71. {IMPORTANT}
  72. {Changed in version 2.21 from a procedure to a function with cdecl.
  73.  To cancel return a 0 else return a 1}
  74.  
  75. Function MMCalledBack ( i : integer) : integer; cdecl; export;
  76.  
  77. {Callback function from the dll, CDECL and EXPORT ARE REQUIRED}
  78. begin
  79.  
  80.   if Application.Terminated then
  81.  
  82.    {User wants to terminate the program. Pass a 0 to the dll}
  83.    Result:=0
  84.  
  85.   else begin
  86.    {Process Progress bar}
  87.    if MailOrderForm <> Nil then
  88.     MailOrderForm.Gauge1.Progress:=i;
  89.  
  90.    {Live in peace with others}
  91.    Application.ProcessMessages;
  92.  
  93.    {tell the dll that everything is OK}
  94.    Result:=1;
  95.    end;
  96. end;
  97. {---------------------------------------------------------------------}
  98.  
  99. {IMPORTANT}
  100. {Changed in version 2.21 from a procedure to a function with cdecl.
  101.  To cancel return a 0 else return a 1}
  102.  
  103. Function MICalledBack ( i : integer) : integer; cdecl; export;
  104.  
  105. {Callback function from the dll, CDECL and EXPORT ARE REQUIRED}
  106. begin
  107.  
  108.   if Application.Terminated then
  109.  
  110.    {User wants to terminate the program. Pass a 0 to the dll}
  111.    Result:=0
  112.  
  113.   else begin
  114.    {Process Progress bar}
  115.    if MailOrderForm <> Nil then
  116.      MailOrderForm.Gauge2.Progress:=i;
  117.  
  118.    {Live in peace with others}
  119.    Application.ProcessMessages;
  120.  
  121.    {tell the dll that everything is OK}
  122.    Result:=1;
  123.    end;
  124. end;
  125. {---------------------------------------------------------------------}
  126.  
  127.  
  128. function TMailOrderForm.JustPathname(PathName : string) : string;
  129.     {-Return just the drive:directory portion of a pathname}
  130.   var
  131.     I : Word;
  132.   const
  133.      DosDelimSet : set of Char = ['\', ':', #0];
  134.   begin
  135.     I := Succ(Word(Length(PathName)));
  136.     repeat
  137.       Dec(I);
  138.     until (PathName[I] in DosDelimSet) or (I = 0);
  139.  
  140.     if I = 0 then
  141.       {Had no drive or directory name}
  142.       JustPathname[0] := #0
  143.     else if I = 1 then
  144.       {Either the root directory of default drive or invalid pathname}
  145.       JustPathname := PathName[1]
  146.     else if (PathName[I] = '\') then begin
  147.       if PathName[Pred(I)] = ':' then
  148.         {Root directory of a drive, leave trailing backslash}
  149.         JustPathname := Copy(PathName, 1, I)
  150.       else
  151.         {Subdirectory, remove the trailing backslash}
  152.         JustPathname := Copy(PathName, 1, Pred(I));
  153.     end else
  154.       {Either the default directory of a drive or invalid pathname}
  155.       JustPathname := Copy(PathName, 1, I);
  156.   end;
  157. {---------------------------------------------------------------------}
  158.  
  159.  
  160.  
  161. Procedure TMailOrderForm.Trigger(Sender : TObject; Var Done : Boolean);
  162. begin
  163.     {IMPORTANT}
  164.    {This function is called when your app is idle. Subdivide the
  165.     trigger event to your TDBMultiMedia objects who may need one.
  166.     If no Message is active it will not take up significant time}
  167.     DBMultiMedia1.Trigger;
  168.     DBMultiImage1.Trigger;
  169.     DBMultiImage2.Trigger;
  170. end;
  171. {---------------------------------------------------------------------}
  172.  
  173.  
  174. procedure TMailOrderForm.FormCreate(Sender: TObject);
  175. begin
  176.     {Register the callback Fuctions to the VCL}
  177.     TPDBMultiMediaCallBack:=MMCalledBack;
  178.     TPDBMultiImageCallBack:=MICalledBack;
  179.  
  180.     If FileExists(ExtractFilePath(Application.ExeName)+'MAIL_ORD.DB') then begin
  181.        {if the table exists open it on creation}
  182.        Table1.DataBaseName:=JustPathName(Application.ExeName);
  183.        Table1.TableName:='MAIL_ORD.DB';
  184.        Table1.Active:=True;
  185.      end;
  186.  
  187.    {IMPORTANT}
  188.     {This is the moving engine for all the messages. Since an applcation
  189.     can have only one OnIdle Trigger, this trigger needs to be subdivided
  190.     by all your moving and animated objects. In this particular case the
  191.     function is called TRIGGER but you can name it as you want as long
  192.     you have a procedure named the same.}
  193.     Application.OnIdle:=Trigger;
  194.  end;
  195.  
  196.  
  197. procedure TMailOrderForm.AddImageClick(Sender: TObject);
  198. begin
  199.   OpenDialog1.filter:='All Images|*.png;*.jpg;*.bmp;*.gif;*.pcx|Png|*.png|Jpeg|*.jpg|BitMap|*.bmp|Gif|*.gif|Pcx|*.pcx';
  200.   {Execute the open dialog box}
  201.   if OpenDialog1.Execute then begin
  202.  
  203.     Table1.Edit;
  204.  
  205.     {Load the Multimedia into the Blob}
  206.     DBMultiImage2.LoadfromFile(OpenDialog1.FileName);
  207.  
  208.     {Post that thing}
  209.     Table1.Post;
  210.   end;
  211. end;
  212.  
  213.  
  214.  
  215. procedure TMailOrderForm.AddMMClick(Sender: TObject);
  216. begin
  217.   {fill the OpenDialog filter with the MM extensions as found in the win.ini
  218.    (This means that the appropriate drivers are installed)}
  219.   OpenDialog1.filter:=DBMultiMedia1.GetMultiMediaExtensions;
  220.  
  221.   {Execute the open dialog box}
  222.   if OpenDialog1.Execute then begin
  223.  
  224.     Table1.Edit;
  225.  
  226.     {Load the Multimedia into the Blob}
  227.     DBMultiMedia1.LoadfromFile(OpenDialog1.FileName);
  228.  
  229.     {Post that thing}
  230.     Table1.Post;
  231.   end;
  232. end;
  233.  
  234. procedure TMailOrderForm.DataSource1DataChange(Sender: TObject; Field: TField);
  235. begin
  236.     {Set the Video display rectangle to the rectangle of the blob window}
  237.     DBMediaPlayer1.DisplayRect:=Rect(0,0,DBMultiMedia1.Width,DBMultiMedia1.Height);
  238.  
  239.     {Set the Video display to the the display of the blob window}
  240.     DBMediaPlayer1.Display:=DBMultiMedia1;
  241.  
  242. end;
  243.  
  244. procedure TMailOrderForm.AddMsgClick(Sender: TObject);
  245. begin
  246.     Table1.Edit;
  247.     {Create a New Message}
  248.     If DBMultiImage1.CreateMessage then
  249.     {Post or cancel that thing}
  250.        Table1.Post
  251.     else
  252.        Table1.Cancel;
  253. end;
  254.  
  255.  
  256. procedure TMailOrderForm.SpinButton1DownClick(Sender: TObject);
  257. begin
  258.   if DBMultiImage1.MsgSpeed <10 then Inc(DBMultiImage1.MsgSpeed)
  259. end;
  260.  
  261. procedure TMailOrderForm.SpinButton1UpClick(Sender: TObject);
  262. begin
  263.   if DBMultiImage1.MsgSpeed >0 then Dec(DBMultiImage1.MsgSpeed)
  264. end;
  265.  
  266. procedure TMailOrderForm.BitBtn1Click(Sender: TObject);
  267. begin
  268.     {Place the Database in Edit mode}
  269.     Table1.Edit;
  270.     {Create a New Credit Message}
  271.     If DBMultiMedia1.CreateCreditMessage then
  272.     {Post or cancel that thing}
  273.       Table1.Post
  274.     else
  275.       Table1.Cancel;
  276. end;
  277.  
  278. procedure TMailOrderForm.FormDestroy(Sender: TObject);
  279. begin
  280.     Application.OnIdle:=Nil;
  281.     {UNRegister the callback Fuctions to the VCL}
  282.     TPDBMultiMediaCallBack:=Nil;
  283.     TPDBMultiImageCallBack:=Nil;
  284.  
  285.     MailOrderForm:=Nil;
  286. end;
  287.  
  288. end.
  289.