cvarutil.inc 6.0 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240
  1. {
  2. $Id$
  3. This file is part of the Free Pascal run time library.
  4. Copyright (c) 2000,2001 by the Free Pascal development team
  5. Interface and OS-dependent part of variant support
  6. See the file COPYING.FPC, included in this distribution,
  7. for details about the copyright.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  11. **********************************************************************}
  12. {$ifdef HASVARIANT}
  13. Resourcestring
  14. SNoWidestrings = 'No widestrings supported';
  15. SNoInterfaces = 'No interfaces supported';
  16. Procedure NoWidestrings;
  17. begin
  18. Raise Exception.Create(SNoWideStrings);
  19. end;
  20. Procedure NoInterfaces;
  21. begin
  22. Raise Exception.Create(SNoInterfaces);
  23. end;
  24. Constructor EVariantError.CreateCode (Code : longint);
  25. begin
  26. ErrCode:=Code;
  27. end;
  28. Procedure VariantTypeMismatch;
  29. begin
  30. Raise EVariantError.CreateCode(VAR_TYPEMISMATCH);
  31. end;
  32. Function ExceptionToVariantError (E : Exception): HResult;
  33. begin
  34. If E is EoutOfMemory then
  35. Result:=VAR_OUTOFMEMORY
  36. else
  37. Result:=VAR_EXCEPTION;
  38. end;
  39. { ---------------------------------------------------------------------
  40. OS-independent functions not present in Windows
  41. ---------------------------------------------------------------------}
  42. Function VariantToSmallInt(Const VargSrc : TVarData) : SmallInt;
  43. begin
  44. With VargSrc do
  45. Case (VType and VarTypeMask) of
  46. VarSmallInt: Result:=VSmallInt;
  47. VarInteger : Result:=VInteger;
  48. VarSingle : Result:=Round(VSingle);
  49. VarDouble : Result:=Round(VDouble);
  50. VarCurrency: Result:=Round(VCurrency);
  51. VarDate : Result:=Round(VDate);
  52. VarOleStr : NoWideStrings;
  53. VarBoolean : Result:=SmallInt(VBoolean);
  54. VarByte : Result:=VByte;
  55. else
  56. VariantTypeMismatch;
  57. end;
  58. end;
  59. Function VariantToLongint(Const VargSrc : TVarData) : Longint;
  60. begin
  61. With VargSrc do
  62. Case (VType and VarTypeMask) of
  63. VarSmallInt: Result:=VSmallInt;
  64. VarInteger : Result:=VInteger;
  65. VarSingle : Result:=Round(VSingle);
  66. VarDouble : Result:=Round(VDouble);
  67. VarCurrency: Result:=Round(VCurrency);
  68. VarDate : Result:=Round(VDate);
  69. VarOleStr : NoWideStrings;
  70. VarBoolean : Result:=Longint(VBoolean);
  71. VarByte : Result:=VByte;
  72. else
  73. VariantTypeMismatch;
  74. end;
  75. end;
  76. Function VariantToSingle(Const VargSrc : TVarData) : Single;
  77. begin
  78. With VargSrc do
  79. Case (VType and VarTypeMask) of
  80. VarSmallInt: Result:=VSmallInt;
  81. VarInteger : Result:=VInteger;
  82. VarSingle : Result:=VSingle;
  83. VarDouble : Result:=VDouble;
  84. VarCurrency: Result:=VCurrency;
  85. VarDate : Result:=VDate;
  86. VarOleStr : NoWideStrings;
  87. VarBoolean : Result:=Longint(VBoolean);
  88. VarByte : Result:=VByte;
  89. else
  90. VariantTypeMismatch;
  91. end;
  92. end;
  93. Function VariantToDouble(Const VargSrc : TVarData) : Double;
  94. begin
  95. With VargSrc do
  96. Case (VType and VarTypeMask) of
  97. VarSmallInt: Result:=VSmallInt;
  98. VarInteger : Result:=VInteger;
  99. VarSingle : Result:=VSingle;
  100. VarDouble : Result:=VDouble;
  101. VarCurrency: Result:=VCurrency;
  102. VarDate : Result:=VDate;
  103. VarOleStr : NoWideStrings;
  104. VarBoolean : Result:=Longint(VBoolean);
  105. VarByte : Result:=VByte;
  106. else
  107. VariantTypeMismatch;
  108. end;
  109. end;
  110. Function VariantToCurrency(Const VargSrc : TVarData) : Currency;
  111. begin
  112. Try
  113. With VargSrc do
  114. Case (VType and VarTypeMask) of
  115. VarSmallInt: Result:=VSmallInt;
  116. VarInteger : Result:=VInteger;
  117. VarSingle : Result:=FloatToCurr(VSingle);
  118. VarDouble : Result:=FloatToCurr(VDouble);
  119. VarCurrency: Result:=VCurrency;
  120. VarDate : Result:=FloatToCurr(VDate);
  121. VarOleStr : NoWideStrings;
  122. VarBoolean : Result:=Longint(VBoolean);
  123. VarByte : Result:=VByte;
  124. else
  125. VariantTypeMismatch;
  126. end;
  127. except
  128. On EConvertError do
  129. VariantTypeMismatch;
  130. else
  131. Raise;
  132. end;
  133. end;
  134. Function VariantToDate(Const VargSrc : TVarData) : TDateTime;
  135. begin
  136. Try
  137. With VargSrc do
  138. Case (VType and VarTypeMask) of
  139. VarSmallInt: Result:=FloatToDateTime(VSmallInt);
  140. VarInteger : Result:=FloatToDateTime(VInteger);
  141. VarSingle : Result:=FloatToDateTime(VSingle);
  142. VarDouble : Result:=FloatToDateTime(VDouble);
  143. VarCurrency: Result:=FloatToDateTime(VCurrency);
  144. VarDate : Result:=VDate;
  145. VarOleStr : NoWideStrings;
  146. VarBoolean : Result:=FloatToDateTime(Longint(VBoolean));
  147. VarByte : Result:=FloatToDateTime(VByte);
  148. else
  149. VariantTypeMismatch;
  150. end;
  151. except
  152. On EConvertError do
  153. VariantTypeMismatch;
  154. else
  155. Raise;
  156. end;
  157. end;
  158. Function VariantToBoolean(Const VargSrc : TVarData) : Boolean;
  159. begin
  160. With VargSrc do
  161. Case (VType and VarTypeMask) of
  162. VarSmallInt: Result:=VSmallInt<>0;
  163. VarInteger : Result:=VInteger<>0;
  164. VarSingle : Result:=VSingle<>0;
  165. VarDouble : Result:=VDouble<>0;
  166. VarCurrency: Result:=VCurrency<>0;
  167. VarDate : Result:=VDate<>0;
  168. VarOleStr : NoWideStrings;
  169. VarBoolean : Result:=VBoolean;
  170. VarByte : Result:=VByte<>0;
  171. else
  172. VariantTypeMismatch;
  173. end;
  174. end;
  175. Function VariantToByte(Const VargSrc : TVarData) : Byte;
  176. begin
  177. Try
  178. With VargSrc do
  179. Case (VType and VarTypeMask) of
  180. VarSmallInt: Result:=VSmallInt;
  181. VarInteger : Result:=VInteger;
  182. VarSingle : Result:=Round(VSingle);
  183. VarDouble : Result:=Round(VDouble);
  184. VarCurrency: Result:=Round(VCurrency);
  185. VarDate : Result:=Round(VDate);
  186. VarOleStr : NoWideStrings;
  187. VarBoolean : Result:=Longint(VBoolean);
  188. VarByte : Result:=VByte;
  189. else
  190. VariantTypeMismatch;
  191. end;
  192. except
  193. On EConvertError do
  194. VariantTypeMismatch;
  195. else
  196. Raise;
  197. end;
  198. end;
  199. {$endif HASVARIANT}
  200. {
  201. $Log$
  202. Revision 1.2 2001-08-19 21:02:02 florian
  203. * fixed and added a lot of stuff to get the Jedi DX( headers
  204. compiled
  205. }