home *** CD-ROM | disk | FTP | other *** search
/ Delphi Programmer's Power Pack / Delphi Volume 1.iso / e_to_l / fbuilder / delphi / demos / extfunc.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-09-15  |  11.6 KB  |  355 lines
  1. { FormulaBuilder                }
  2. { YGB Software, Inc.            }
  3. { Copyright 1995 Clayton Collie }
  4. { All rights reserved           }
  5.  
  6.  
  7. {*
  8.  * External Function Module for
  9.  * FormulaBuilder 1.00 Main Demo
  10.  * Copyright 1995 Clayton Collie
  11.  * All Rights Reserved
  12. *}
  13. {$F+,V-}
  14. unit extfunc;
  15. interface
  16.  
  17. Procedure RegisterFunctions;
  18. Procedure UnregisterFunctions;
  19.  
  20. implementation
  21. uses sysutils,controls,forms,messages,
  22.      dialogs,
  23.      Fbcalc,
  24.      winprocs,wintypes;
  25.  
  26. const
  27.   installed : boolean = false;
  28.   constinstalled : boolean = false;
  29.  
  30. var
  31.   fnCopy, fnRename, fnExec,
  32.   fnExecWait, fnDelete,
  33.   fnErrorMsg, fnMsgBox,
  34.   fnBeep, fnYesNo,
  35.   fnYesNoCancel, fnInputstring : integer;
  36.  
  37.  
  38.  
  39. (* Thanks to stidolph@magnet.com (David Stidolph) for the following *)
  40.  
  41. function FileCopy(source,dest: String): Boolean;
  42. var
  43.   fSrc,fDst,len: Integer;
  44.   size: Longint;
  45.   buffer: packed array [0..2047] of Byte;
  46. begin
  47.   Result := False; { Assume that it WONT work }
  48.   if source <> dest then begin
  49.     fSrc := FileOpen(source,fmOpenRead);
  50.     if fSrc >= 0 then begin
  51.       size := FileSeek(fSrc,0,2);
  52.       FileSeek(fSrc,0,0);
  53.       fDst := FileCreate(dest);
  54.       if fDst >= 0 then begin
  55.         while size > 0 do begin
  56.           len := FileRead(fSrc,buffer,sizeof(buffer));
  57.           FileWrite(fDst,buffer,len);
  58.           size := size - len;
  59.         end;
  60.         FileSetDate(fDst,FileGetDate(fSrc));
  61.         FileClose(fDst);
  62.         FileSetAttr(dest,FileGetAttr(source));
  63.         Result := True;
  64.       end;
  65.       FileClose(fSrc);
  66.     end;
  67.   end;
  68. end;
  69.  
  70.  
  71. {----------------------------------------------------
  72.        Name: WinExecAndWait function
  73. Declaration: WinExecAndWait(Path : Pchar; Visibility : word) : word;
  74.        Unit: UtilBox
  75.        Code: S
  76.        Date: 02/05/95
  77. Description: Execute a Windows or DOS program and wait until it
  78.              returns. In the meantime, continue to process
  79.              Window messages. ( Thanks to Lar Mader. )
  80. -----------------------------------------------------}
  81.  
  82. function WinExecAndWait(Path : Pchar; Visibility : word) : word;
  83. var
  84.   InstanceID : THandle;
  85.   Msg : TMSg;
  86. begin
  87.   InstanceID := WinExec(Path,Visibility);
  88.   if InstanceID < 32 then { a value less than 32 indicates an Exec error }
  89.      WinExecAndWait := InstanceID
  90.   else
  91.     repeat
  92.       while PeekMessage(Msg,0,0,0,PM_REMOVE) do begin
  93.         if Msg.Message = WM_QUIT then
  94.            halt(Msg.wParam);
  95.         TranslateMessage(Msg);
  96.         DispatchMessage(Msg);
  97.       end;
  98.     until GetModuleUsage(InstanceID) = 0;
  99. end;
  100.  
  101.  
  102.   Procedure CopyFileProc(paramcount        : byte;
  103.                          Const params      : TActParamList;
  104.                          var   RetValue    : TValueRec;
  105.                          var   nErrorCode  : integer;
  106.                                exprData    : longint); export;
  107.   begin
  108.     retvalue.vBoolean := FileCopy(params[0].vpString^,params[1].vpString^);
  109.   end;
  110.  
  111.  
  112.   Procedure RenFileProc(bParamcount       : byte;
  113.                         Const params      : TActParamList;
  114.                         var   RetValue    : TValueRec;
  115.                         var   nErrorCode  : integer;
  116.                               exprdata    : longint); export;
  117.   begin
  118.     retvalue.vBoolean := RenameFile(params[0].vpString^,params[1].vpString^);
  119.   end;
  120.  
  121.  
  122.   Procedure RunFileProc(bParamcount       : byte;
  123.                         Const params      : TActParamList;
  124.                         var   RetValue    : TValueRec;
  125.                         var   nErrorCode  : integer;
  126.                               exprdata    : longint); export;
  127.   var visibility : word;
  128.       s          : string[90];
  129.   begin
  130.     if (bParamcount = 1) then
  131.        visibility := SW_MAXIMIZE
  132.     else
  133.        if params[0].vInteger < 0 then
  134.           nErrorCode := EXPR_DOMAIN_ERROR
  135.        else
  136.          begin
  137.             visibility := params[0].vInteger;
  138.             s := params[0].vpString^ + #0;
  139.             retvalue.vInteger := WinExec(@s[1],visibility);
  140.          end;
  141.   end;
  142.  
  143.  
  144.  
  145.   Procedure ExecWaitProc(bParamcount       : byte;
  146.                          Const params      : TActParamList;
  147.                          var   RetValue    : TValueRec;
  148.                          var   nErrorCode  : integer;
  149.                                exprdata    : longint); export;
  150.   var visibility : word;
  151.       s          : string[90];
  152.   begin
  153.     if (bParamcount = 1) then
  154.        visibility := SW_MAXIMIZE
  155.     else
  156.        if params[0].vInteger < 0 then
  157.           nErrorCode := EXPR_DOMAIN_ERROR
  158.        else
  159.          begin
  160.             visibility := params[0].vInteger;
  161.             s := params[0].vpString^ + #0;
  162.             retvalue.vInteger := WinExecAndWait(@s[1],visibility);
  163.          end;
  164.   end;
  165.  
  166.  
  167.   {* Delete a file *}
  168.   Procedure DeleteFileProc(bParamcount       : byte;
  169.                            Const params      : TActParamList;
  170.                            var   RetValue    : TValueRec;
  171.                            var   nErrorCode  : integer;
  172.                                  exprdata    : longint); export;
  173.   begin
  174.     retvalue.vBoolean := DeleteFile(params[0].vpString^);
  175.   end;
  176.  
  177.  
  178.   {* Show an error message dialog box *}
  179.   Procedure DispErrorProc(paramcount        : byte;
  180.                           const params      : TActParamList;
  181.                           var   retvalue    : TValueRec;
  182.                           var   nErrorCode  : integer;
  183.                                 exprdata    : longint); export;
  184.   begin
  185.     MessageDlg(params[0].vpString^,mtError, [mbOk], 0);
  186.   end;
  187.  
  188.  
  189.   Procedure MessageBoxProc(paramcount        : byte;
  190.                            const params      : TActParamList;
  191.                            var   retvalue    : TValueRec;
  192.                            var   nErrorCode  : integer;
  193.                                  exprdata    : longint); export;
  194.   begin
  195.     MessageDlg(params[0].vpString^,mtInformation, [mbOk], 0);
  196.   end;
  197.  
  198.  
  199.   Procedure BeepProc(paramcount        : byte;
  200.                      const params      : TActParamList;
  201.                      var   RetValue    : TValueRec;
  202.                      var   nErrorCode  : integer;
  203.                            exprdata    : longint);
  204.   begin
  205.     if paramcount = 0 then
  206.        MessageBeep(mb_iconhand)
  207.     else
  208.        MessageBeep(params[0].vInteger);
  209.   end;
  210.  
  211.  
  212.   procedure YesNoProc(paramcount        : byte;
  213.                       const Params      : TActParamlist;
  214.                       var   Retvalue    : TValueRec;
  215.                       var   iErrcode    : integer;
  216.                             exprdata    : longint); export;
  217.   begin
  218.     Retvalue.vBoolean :=  MessageDlg(params[0].vpString^,
  219.                                      mtConfirmation,
  220.                                      [mbYes, mbNo], 0) = mrYes;
  221.   end;
  222.  
  223.  
  224.   procedure YesNoCancelProc(paramcount        : byte;
  225.                             const Params      : TActParamlist;
  226.                             var   Retvalue    : TValueRec;
  227.                             var   iErrcode    : integer;
  228.                                   exprdata    : longint); export;
  229.   var tmp : integer;
  230.   begin
  231.    case MessageDlg(params[0].vpString^,mtConfirmation,[mbYes,mbNo,mbCancel],0)of
  232.       mrYes    : retvalue.vInteger := 1;
  233.       mrNo     : retvalue.vInteger := 2;
  234.       mrCancel : retvalue.vInteger := 3;
  235.    end;
  236.   end;
  237.  
  238.  
  239.   procedure InputStringProc(paramcount        : byte;
  240.                             const Params      : TActParamlist;
  241.                             var   Retvalue    : TValueRec;
  242.                             var   iErrcode    : integer;
  243.                                   exprdata    : longint); export;
  244.   var tmpstr : string;
  245.   begin
  246.     tmpstr := params[2].vpString^;
  247.     if InputQuery( Params[0].vpString^, params[1].vpString^, tmpstr ) then
  248.     begin
  249.       tmpstr := tmpstr + #0;
  250.       retvalue.vpString := FBCreateString(@tmpstr[1]);
  251.     end;
  252.   end;
  253.  
  254.  
  255.  
  256.  
  257.  
  258.  
  259. {* Install some standard Windows.h constants *}
  260. Procedure RegisterConstants;
  261. begin
  262.   if constInstalled then exit;
  263.   FBAddNumericConstant('SW_HIDE',SW_HIDE);
  264.   FBAddNumericConstant('SW_SHOWNORMAL',SW_SHOWNORMAL);
  265.   FBAddNumericConstant('SW_NORMAL',SW_NORMAL);
  266.   FBAddNumericConstant('SW_SHOWMINIMIZED',SW_SHOWMINIMIZED);
  267.   FBAddNumericConstant('SW_SHOWMAXIMIZED',SW_SHOWMAXIMIZED);
  268.   FBAddNumericConstant('SW_MAXIMIZE',SW_MAXIMIZE);
  269.   FBAddNumericConstant('SW_SHOWNOACTIVATE',SW_SHOWNOACTIVATE);
  270.   FBAddNumericConstant('SW_SHOW',SW_SHOW);
  271.   FBAddNumericConstant('SW_MINIMIZE',SW_MINIMIZE);
  272. {  FBAddNumericConstant('SW_SHOWMINNOACTIVE',SW_MINNOACTIVE); }
  273.   FBAddNumericConstant('SW_SHOWNA',SW_SHOWNA);
  274.   FBAddNumericConstant('SW_RESTORE',SW_RESTORE);
  275.  
  276.   FBAddNumericConstant('MB_OK',$0000);
  277.   FBAddNumericConstant('MB_OKCANCEL',$0001);
  278.   FBAddNumericConstant('MB_ABORTRETRYIGNORE',$0002);
  279.   FBAddNumericConstant('MB_YESNOCANCEL',$0003);
  280.   FBAddNumericConstant('MB_YESNO',$0004);
  281.   FBAddNumericConstant('MB_RETRYCANCEL',$0005);
  282.   FBAddNumericConstant('MB_TYPEMASK',$000F);
  283.   FBAddNumericConstant('MB_ICONHAND',$0010);
  284.   FBAddNumericConstant('MB_ICONQUESTION',$0020);
  285.   FBAddNumericConstant('MB_ICONEXCLAMATION',$0030);
  286.   FBAddNumericConstant('MB_ICONASTERISK',$0040);
  287.   FBAddNumericConstant('MB_ICONMASK',$00F0);
  288.  
  289.   FBAddNumericConstant('MB_ICONINFORMATION',MB_ICONASTERISK);
  290.   FBAddNumericConstant('MB_ICONSTOP',MB_ICONHAND);
  291.  
  292.   FBAddNumericConstant('MB_DEFBUTTON1',$0000);
  293.   FBAddNumericConstant('MB_DEFBUTTON2',$0100);
  294.   FBAddNumericConstant('MB_DEFBUTTON3',$0200);
  295.   FBAddNumericConstant('MB_DEFMASK',$0F00);
  296.  
  297.   FBAddNumericConstant('MB_APPLMODAL',$0000);
  298.   FBAddNumericConstant('MB_SYSTEMMODAL',$1000);
  299.   FBAddNumericConstant('MB_TASKMODAL',$2000);
  300.  
  301.   FBAddNumericConstant('MB_NOFOCUS',$8000);
  302.  
  303. {* Standard dialog button IDs *}
  304.    FBAddNumericConstant('IDOK',IDOK);
  305.    FBAddNumericConstant('IDCANCEL',IDCANCEL);
  306.    FBAddNumericConstant('IDABORT',IDABORT);
  307.    FBAddNumericConstant('IDRETRY',IDRETRY);
  308.    FBAddNumericConstant('IDIGNORE',IDIGNORE);
  309.    FBAddNumericConstant('IDYES',IDYES);
  310.    FBAddNumericConstant('IDNO',IDNO);
  311.    constinstalled := true;
  312. end;
  313.  
  314.  
  315.   Procedure RegisterFunctions;
  316.   begin
  317.     if installed then exit;
  318.     InitFBuilder;
  319.     fnCopy     := FBRegisterFunction('copy',vtBOOLEAN,'ss',2,CopyfileProc);
  320.     fnRename   := FBRegisterFunction('rename',vtBOOLEAN,'ss',2,RenFileProc);
  321.     fnExec     := FBRegisterFunction('exec',vtInteger,'si',1,RunFileProc);
  322.     fnExecWait := FBRegisterFunction('execwait',vtInteger,'si',1,ExecWaitProc);
  323.     fnDelete   := FBRegisterFunction('delete',vtBOOLEAN,'s',1,DeleteFileProc);
  324.     fnErrorMsg := FBRegisterFunction('errormsg',vtInteger,'s',1,DispErrorProc);
  325.     fnMsgBox   := FBRegisterFunction('msgbox',vtInteger,'s',1,MessageBoxProc);
  326.     fnBeep     := FBRegisterFunction('beep',vtInteger,'i',1,BeepProc);
  327.     fnYesNo    := FBRegisterFunction('yesno',vtInteger,'s',1,YesNoProc);
  328.     fnYesNoCancel := FBRegisterFunction('yesnocancel',vtInteger,'s',1,YesNoCancelProc);
  329.     fnInputString := FBRegisterFunction('inputstring',vtString,'sss',3,InputstringProc);
  330.     RegisterConstants;
  331.     installed := true;
  332.   end;
  333.  
  334.  
  335.   Procedure UnregisterFunctions;
  336.   begin
  337.     If not FBLoaded then exit;
  338.     FBUnRegisterFunction(fnCopy);
  339.     FBUnRegisterFunction(fnRename);
  340.     FBUnRegisterFunction(fnExec);
  341.     FBUnRegisterFunction(fnExecWait);
  342.     FBUnRegisterFunction(fnDelete);
  343.     FBUnRegisterFunction(fnErrorMsg);
  344.     FBUnRegisterFunction(fnMsgBox);
  345.     FBUnRegisterFunction(fnBeep);
  346.     FBUnRegisterFunction(fnYesNo);
  347.     FBUnRegisterFunction(fnYesNoCancel);
  348.     FBUnRegisterFunction(fnInputstring);
  349.     FreeFBuilder;
  350.     Installed := False;
  351.   end;
  352.  
  353.  
  354. END.
  355.