}

Delphi.int.ru — Портал программистов

Вход Регистрация | Забыли пароль?

Просмотр кода

Идентификатор: 5981d7d0 Описание: EClasses.pas Код загружен: 1 августа 2011, 16:20 (mirt.steelwater)

  1. unit EClasses;
  2.  
  3. interface
  4.  
  5. uses
  6. Windows, SysUtils, TypInfo,
  7. VarRecs;
  8.  
  9. type
  10. {$M+}
  11. EClass = class (Exception)
  12. private
  13. f_EGUID: String; { уникальный идентификатор исключения }
  14.   protected
  15.  
  16. protected
  17. procedure SetEGUID (const aValue: String);
  18. public
  19. constructor Create (anArgs: array of const;
  20. const anEGUID: String = ''); overload;
  21. constructor Create (anArgs: array of const;
  22. anEGUID: array of const); overload;
  23. property EGUID: String read f_EGUID write SetEGUID;
  24. end;
  25. {tionMessage (const aValue: TVarRec) : String;
  26.  
  27. function RaiseErrorInClass (doRaise: Boolean;
  28.   anArgs: array of const;
  29.   const anEGUID: String = '') : String;
  30.  
  31. implementation
  32.  
  33. function toExceptionMessage (const aValue: TVarRec) : String;
  34. begin
  35.   Result := '';
  36.   with aValue do
  37.   try
  38.   case VType of
  39.   vtObject: if VObject.InheritsFrom (Exception) then
  40.   Result := Exception (VObject).Message
  41.   else
  42.   Result := VObject.ClassName;
  43.   else Result := toString (aValue);
  44.   end;
  45.   except
  46.   Result := 'Unknown Error';
  47.   end;
  48. end;
  49.  
  50. function RaiseErrorInClass (doRaise: Boolean;
  51.   anArgs: array of const;
  52.   const anEGUID: String = '') : String;
  53. var
  54.   I : Integer;
  55.  
  56.   { функция определения исполняемого модуля приложения }
  57.   function GetClassPackageName (aClass: TClass) : St
  58. function GetClassPackageName (aClass: TClass) : String;
  59. var
  60. M : TMemoryBasicInformation;
  61. begin
  62. {M, SizeOf (M) );
  63.   SetLength (Result,MAX_PATH+1);
  64.   { если это не главная программа }
  65.   if ( hModule (M.AllocationBase) <> hInstance ) then
  66.   begin
  67.   GetModuleFil
  68. if ( hModule (M.AllocationBase) <> hInstance ) then
  69. begin
  70. GetModuleFileName ( hModule (M.AllocationBase), PChar (Result), MAX_PATH );
  71. SetLength ( Result, StrLen ( PChar (Result) ) );
  72. Result := ExtractFileName (Result);
  73. end
  74. else
  75. Result := ExtractFileName ( ParamStr (0) );
  76. end;
  77.  
  78. {r;
  79.   begin
  80.   Result := 'Unknown';
  81.   C := aClass.ClassInfo;
  82.   if Assigned (C) then
  83.   Result := GetTypeData (C).UnitName;
  84.   end;
  85.  
  86. begin
  87.   Result := '';
  88.   for I := Low (anArgs) to High (anArgs) do
  89.   with anArgs [I] do
  90.   begin
  91.   { первый параметр - класс, в котором возникло исключение }
  92.   if ( I = 0 ) then
  93.   begin
  94.   case VType of
  95.   vtClass: Result := Format( '%s::%s::%s',[ GetClassPackageName (VClass),
  96.  
  97. if ( I = 0 ) then
  98. begin
  99. case VType of
  100. vtClass: Result := Format( '%s::%s::%s',[ GetClassPackageName (VClass),
  101. GetClassUnitName (VClass),
  102. VClass.ClassName ] );
  103. vtObject: if VObject.InheritsFrom (Exception) then
  104. Result := Exception (VObject).Message
  105. else
  106. Result := Format( '%s::%s::%s',[ GetClassPackageName (VObject.ClassType),
  107. GetClassUnitName (VObject.ClassType),
  108. VObject.ClassName ] );
  109. else Result := toExceptionMessage (anArgs [I]);
  110. end;
  111. end
  112. {Char]);
  113.   vtString: Result := Format ('%s.%s',[Result,VString^]);
  114.   vtPChar: Result := Format ( '%s.%s',[ Result, StrPas (VPChar) ] );
  115.   vtAnsiString: Result := Format ( '%s.%s',[ Result, String (VAnsiString) ] );
  116.   vtWideChar: Result := Format ( '%s.%s',[ Result, Char (VWideChar) ] );
  117.   vtPWideChar: Result := Format ( '%s.%s',[ Result, WideCharToString (VPWideChar) ] );
  118.   vtWideString: Result := Format ( '%s.%s',[ Result, WideCharToString (VWideString) ] );
  119.   vtVariant: Result := Format ('%s.%s',[Result,VVariant^]);
  120.   else Result := Format ( '%s : '#13#10'%s',[ Result, toExceptionMessage (anArgs [I]) ] );
  121.   end;
  122.   end
  123.   { остальные параметры - текстовые сообщения или экземпляры класса исключения }
  124.   else
  125.   Result := Format ( '%s : '#13#10'%s',[ Result, toExceptionMessage (anArgs [I]) ] );
  126.   end;
  127.   { уникальный идентификатор исключения }
  128.   if ( anEGUID <> '' ) then
  129.   Result := Format ('%s'#13#10'%s',[anEGUID,Result]);
  130.   if doRaise then
  131.  
  132. else
  133. Result := Format ( '%s : '#13#10'%s',[ Result, toExceptionMessage (anArgs [I]) ] );
  134. end;
  135. {_CASE}
  136.   f_EGUID := UpperCase (aValue);
  137.   {$ELSE}
  138.   f_EGUID := LowerCase (aValue);
  139.   {$ENDIF HEX_UPPER_CASE}
  140. end;
  141.  
  142. constructor EClass.Create (anArgs: array of const;
  143.   const anEGUID: String = '');
  144. begin
  145.   EGUID := anEGUID;
  146.   inherited Create
  147. f_EGUID := UpperCase (aValue);
  148. {) );
  149. end;
  150.  
  151. constructor EClass.Create (anArgs: array of const;
  152.   anEGUID: array of const);
  153. var
  154.   I : Integer;
  155. begin
  156.   EGUID := '';
  157.   for I := Low (anEGUID) to High (anEGUID) do
  158.   EGUID := Format ('%s%s',[ EGUID, toString (anEGUID [I]) ]);
  159.   inherited Create ( RaiseErrorInClass (FALSE,anArgs,EGUID) );
  160. end;
  161.  
  162. end.</code>

Ссылка на данный код:

На главную страницу сервиса обмена кодом »