home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 December / Chip_2001-12_cd1.bin / zkuste / delphi / kompon / d23456 / CAJSCRTP.ZIP / libraries / ifpslib / ifpsdate.pas next >
Encoding:
Pascal/Delphi Source File  |  2001-09-26  |  6.0 KB  |  138 lines
  1. unit ifpsdate;
  2. {
  3.   Innerfuse Pascal Script Library
  4.   For license see Innerfuse Pascal Script license file
  5.  
  6. }
  7. interface
  8. uses
  9.   ifspas, ifs_utl, ifs_var;
  10.  
  11. procedure RegisterDateTimeLib(ScriptEngine: TIFPasScript);
  12. {
  13.   Registers:
  14.  
  15. type
  16.   TDateTime = double;
  17.  
  18. function EncodeDate(Year, Month, Day: Word): TDateTime;
  19. function EncodeTime(Hour, Min, Sec, MSec: Word): TDateTime;
  20. procedure DecodeDate(const DateTime: TDateTime; var Year, Month, Day: Word);
  21. procedure DecodeTime(const DateTime: TDateTime; var Hour, Min, Sec, MSec: Word);
  22. function Date: TDateTime;
  23. function Time: TDateTime;
  24. function Now: TDateTime;
  25. function DateToStr(DateTime: TDateTime): string;
  26. function TimeToStr(DateTime: TDateTime): string;
  27. function DateTimeToStr(DateTime: TDateTime): string;
  28. function StrToDate(S: string): TDateTime;
  29. function StrToDateDef(S: string; Default: TDateTime): TDateTime;
  30. function StrToTime(S: string): TDateTime;
  31. function StrToTimeDef(S: string; Default: TDateTime): TDateTime;
  32. function StrToDateTime(S: string): TDateTime;
  33. function StrToDateTimeDef(S: string; Default: TDateTime): TDateTime;
  34. }
  35. implementation
  36. uses
  37.   Sysutils;
  38.  
  39. function DProc(Sender, ScriptID: Pointer; Proc: PProcedure; Params: PVariableManager; res: PIfVariant): TIfPasScriptError;
  40. begin
  41.   Result := ENoError;
  42.   if Proc^.Name = 'ENCODEDATE' then begin
  43.     try
  44.     TDateTime(res^.CV_Double) := EncodeDate(vm_get(params, 0)^.CV_UInt16, vm_get(params, 1)^.CV_UInt16, vm_get(params, 2)^.CV_UInt16);
  45.     except
  46.       TIFPasScript(Sender).RunError2(Sender, ECustomError, 'Invalid date');
  47.       Result := ECustomError;
  48.     end;
  49.   end else if Proc^.Name = 'ENCODETIME' then begin
  50.     try
  51.       TDateTime(res^.CV_Double) := EncodeTime(vm_get(params, 0)^.CV_UInt16, vm_get(params, 1)^.CV_UInt16, vm_get(params, 2)^.CV_UInt16, vm_get(params, 3)^.CV_UInt16);
  52.     except
  53.       TIFPasScript(Sender).RunError2(Sender, ECustomError, 'Invalid date');
  54.       Result := ECustomError;
  55.     end;
  56.   end else if Proc^.Name = 'DECODEDATE' then begin
  57.     DecodeDate(VM_Get(Params, 0)^.CV_Double, VM_Get(Params, 1)^.Cv_UInt16, VM_Get(Params, 2)^.Cv_UInt16, VM_Get(Params, 3)^.Cv_UInt16);
  58.   end else if Proc^.Name = 'DECODETIME' then begin
  59.     DecodeTime(VM_Get(Params, 0)^.CV_Double, VM_Get(Params, 1)^.Cv_UInt16, VM_Get(Params, 2)^.Cv_UInt16, VM_Get(Params, 3)^.Cv_UInt16, VM_Get(Params, 4)^.Cv_UInt16);
  60.   end else if Proc^.Name = 'DATE' then begin
  61.     Res^.CV_Double := Date;
  62.   end else if Proc^.Name = 'TIME' then begin
  63.     Res^.CV_Double := Time;
  64.   end else if Proc^.Name = 'NOW' then begin
  65.     Res^.CV_Double := Now;
  66.   end else if Proc^.Name = 'DATETOSTR' then begin
  67.     Res^.CV_Str := DateToStr(VM_Get(Params, 0)^.CV_Double);
  68.   end else if Proc^.Name = 'TIMETOSTR' then begin
  69.     Res^.CV_Str := TimeToStr(VM_Get(Params, 0)^.CV_Double);
  70.   end else if Proc^.Name = 'DATETIMETOSTR' then begin
  71.     Res^.CV_Str := DateTimeToStr(VM_Get(Params, 0)^.CV_Double);
  72.   end else if Proc^.Name = 'STRTODATE' then begin
  73.     Try
  74.       TDateTime(Res^.CV_Double) := StrToDate(VM_Get(Params, 0)^.CV_Str);
  75.     except
  76.       TIFPasScript(Sender).RunError2(Sender, ECustomError, 'Invalid date');
  77.       Result := ECustomError;
  78.     end;
  79.  
  80.   end else if Proc^.Name = 'STRTODATEDEF' then begin
  81.     try
  82.       Res^.cv_double := strToDate(VM_Get(Params, 0)^.CV_Str);
  83.     except
  84.       Res^.cv_double := VM_Get(Params, 1)^.CV_Double;
  85.     end;
  86.   end else if Proc^.Name = 'STRTOTIME' then begin
  87.     try
  88.       TDateTime(Res^.CV_Double) := STrToTime(VM_Get(Params, 0)^.CV_Str);
  89.     except
  90.       TIFPasScript(Sender).RunError2(Sender, ECustomError, 'Invalid date');
  91.       Result := ECustomError;
  92.     end;
  93.   end else if Proc^.Name = 'STRTOTIMEDEF' then begin
  94.     try
  95.     Res^.cv_double := strToTime(VM_Get(Params, 0)^.CV_Str);
  96.     except
  97.       Res^.CV_Double := VM_Get(Params, 1)^.CV_Double;
  98.     end;
  99.   end else if Proc^.Name = 'STRTODATETIME' then begin
  100.     try
  101.     TDateTime(Res^.CV_Double) := StrToDateTime(VM_Get(Params, 0)^.CV_Str);
  102.     except
  103.       TIFPasScript(Sender).RunError2(Sender, ECustomError, 'Invalid date');
  104.       Result := ECustomError;
  105.     end;
  106.   end else if Proc^.Name = 'STRTODATETIMEDEF' then begin
  107.     try
  108.     Res^.cv_double := strToDateTime(VM_Get(Params, 0)^.CV_Str);
  109.     except
  110.       res^.CV_Double := VM_Get(Params, 1)^.CV_Double;
  111.     end;
  112.   end else result := EUnknownIdentifier;
  113. end;
  114.  
  115. procedure RegisterDateTimeLib(ScriptEngine: TIFPasScript);
  116. begin
  117.   ScriptEngine.AddType('TDateTime', 'Double');
  118.   ScriptEngine.AddFunction(@dproc, 'function EncodeDate(Year, Month, Day: Word): TDateTime;', nil);
  119.   ScriptEngine.AddFunction(@dproc, 'function EncodeTime(Hour, Min, Sec, MSec: Word): TDateTime;', nil);
  120.   ScriptEngine.AddFunction(@dproc, 'procedure DecodeDate(DateTime: TDateTime; var Year, Month, Day: Word);', nil);
  121.   ScriptEngine.AddFunction(@dproc, 'procedure DecodeTime(DateTime: TDateTime; var Hour, Min, Sec, MSec: Word);', nil);
  122.   ScriptEngine.AddFunction(@dproc, 'function Date: TDateTime;', nil);
  123.   ScriptEngine.AddFunction(@dproc, 'function Time: TDateTime;', nil);
  124.   ScriptEngine.AddFunction(@dproc, 'function Now: TDateTime;', nil);
  125.   ScriptEngine.AddFunction(@dproc, 'function DateToStr(DateTime: TDateTime): string;', nil);
  126.   ScriptEngine.AddFunction(@dproc, 'function TimeToStr(DateTime: TDateTime): string;', nil);
  127.   ScriptEngine.AddFunction(@dproc, 'function DateTimeToStr(DateTime: TDateTime): string;', nil);
  128.   ScriptEngine.AddFunction(@dproc, 'function StrToDate(S: string): TDateTime;', nil);
  129.   ScriptEngine.AddFunction(@dproc, 'function StrToDateDef(S: string; Default: TDateTime): TDateTime;', nil);
  130.   ScriptEngine.AddFunction(@dproc, 'function StrToTime(S: string): TDateTime;', nil);
  131.   ScriptEngine.AddFunction(@dproc, 'function StrToTimeDef(S: string; Default: TDateTime): TDateTime;', nil);
  132.   ScriptEngine.AddFunction(@dproc, 'function StrToDateTime(S: string): TDateTime;', nil);
  133.   ScriptEngine.AddFunction(@dproc, 'function StrToDateTimeDef(S: string; Default: TDateTime): TDateTime;', nil);
  134. end;
  135.  
  136.  
  137. end.
  138.