oleerrors.pas

是一个delphi的流程制作软件

//--- Ole Errors ---------------------------------------------------------------
//
// Provides handling of Ole and OleUI errors by raising
// exceptions with (somewhat) readable text messages and error codes.
//
// Grahame Marsh
// Freeware for UNDU - you get it for free I make no promises
// [e-mail]
//==============================================================================

{$INCLUDE OLE.INC}

unit OleErrors;

interface

uses
  Windows, SysUtils, OleDlg;

//--- Exceptions and error handling --------------------------------------------

type
  OleException = Exception;

function OleErrorMsg (ACode : HRESULT; const Name : string = '') : string;
procedure OleError (ACode : HRESULT; const Name : string = '');
function OleCheck (ACode : HRESULT; const Name : string = '') : HRESULT;

type
  TOleUIType = (otBusy, otPasteSpecial, otPromptUser, otChangeIcon,
    otInsertObject, otObjectProps, otEditLinks, otConvert, otChangeSource);
  OleUIException = Exception;

function OleUIErrorMsg (ACode : UINT; OleUIType : TOleUIType; SCode : HRESULT = 0) : string;
procedure OleUIError (ACode : UINT; OleUIType : TOleUIType; SCode : HRESULT = 0);
function OleUICheck (ACode : UINT; OleUIType : TOleUIType; SCode : HRESULT = 0) : UINT;

// Additional error codes
const
  STG_E_BASE              = $C0008000;                  // base errors, has bit $40000000 set
  STG_E_STORAGECANTBENIL  = HRESULT (STG_E_BASE +  1);  // Operation fails on nil storage
  STG_E_NOTWHENOPEN       = HRESULT (STG_E_BASE +  2);  // Not on an open storage
  STG_E_NO2INIT           = HRESULT (STG_E_BASE +  3);  // Cannot initialize %s twice
  STG_E_CANTDELETEROOT    = HRESULT (STG_E_BASE +  4);  // Cannot delete root storage
  STG_E_NOTSTORAGEFILE    = HRESULT (STG_E_BASE +  5);  // %s is not a storage file
  STG_E_NOROOTINTERFACE   = HRESULT (STG_E_BASE +  6);  // Cannot obtain IRootStorage interface

implementation

uses
  OleConsts;

//=== Storage Error Code Translation ===========================================

type
  TErrorMsg = record
    Msg  : string;
    Code : HRESULT
  end;

const
  ErrorMsgs : array [1..6] of TErrorMsg = (
// Local (Application) errors:
    (Msg : 'Storage cannot be nil';
     Code : STG_E_STORAGECANTBENIL), // $C0008001
    (Msg : 'Not when storage is open';
     Code : STG_E_NOTWHENOPEN),      // $C0008002
    (Msg : 'Cannot initialize "%s" twice';
     Code : STG_E_NO2INIT),          // $C0008003
    (Msg : 'Cannot delete root storage';
     Code : STG_E_CANTDELETEROOT),   // $C0008004
    (Msg : '%s is not a storage file';
     Code : STG_E_NOTSTORAGEFILE),   // $C0008005
    (Msg : 'Cannot obtain IRootStorage interface';
     Code : STG_E_NOROOTINTERFACE)); // $C0008006

function OleErrorMsg (ACode : HRESULT; const Name : string = '') : string;
var
  Loop : integer;
begin
// Test to see if it is a locally defined error message
  if ACode and $40000000 <> 0 then
  begin
    for Loop := low (ErrorMsgs) to high (ErrorMsgs) do
      with ErrorMsgs [Loop] do
        if ACode = Code then
        begin
          Result := Format ('Application OLE error ($%8x): ' + Msg, [Code, Name]);
          exit
        end;
  end else begin
// Test for system error messages
    Result := SysErrorMessage (integer(ACode));
    if length (Result) > 0 then
    begin
      for Loop := 1 to length (Result) do
        if Result [Loop] = '%' then
          Result [succ(Loop)] := 's';
      Result := Format ('System OLE error ($%8x): ' + Result, [ACode, Name]);
      exit
    end
  end;
// generic error message
  Result := Format ('Undefined OLE error ($%8x): File: "%s"', [ACode, Name])
end;

procedure OleError (ACode : HRESULT; const Name : string = '');
begin
  raise OleException.Create (OleErrorMsg (ACode, Name))
end;

function OleCheck (ACode : HRESULT; const Name : string = '') : HRESULT;
begin
  Result := ACode;  // for pass-through of information (non-error) messages
  if Failed (ACode) then
    OleError (ACode, Name)
end;

//--- OleUI Errors -------------------------------------------------------------

function OleUIErrorMsg (ACode : UINT; OleUIType : TOleUIType; SCode : HRESULT = 0) : string;
const
  OleUITypeName : array [TOleUIType] of string =
    ('Busy', 'PasteSpecial', 'PromptUser', 'ChangeIcon', 'InsertObject', 'ObjectProperties',
     'EditLinks', 'Convert', 'ChangeSource');
begin
// Errors common to all dialogs lie in the range OLEUI_ERR_STANDARDMIN to
// OLEUI_ERR_STANDARDMAX. This value allows the application to test for
// standard messages in order to display error messages to the user.
  case ACode of
    OLEUI_ERR_STRUCTURENULL :    Result := 'The pointer to an OLEUIXXX structure passed into the function was NULL';
    OLEUI_ERR_STRUCTUREINVALID : Result := 'Insufficient permissions for read or write access to an OLEUIXXX structure.';
    OLEUI_ERR_CBSTRUCTINCORRECT : Result := 'The cbstruct value is incorrect.';
    OLEUI_ERR_HWNDOWNERINVALID : Result := 'The hWndOwner value is invalid.';
    OLEUI_ERR_LPSZCAPTIONINVALID : Result := 'The lpszCaption value is invalid.';
    OLEUI_ERR_LPFNHOOKINVALID : Result := 'The lpfnHook value is invalid.';
    OLEUI_ERR_HINSTANCEINVALID : Result := 'The hInstance value is invalid.';
    OLEUI_ERR_LPSZTEMPLATEINVALID : Result := 'The lpszTemplate value is invalid.';
    OLEUI_ERR_HRESOURCEINVALID : Result := 'The hResource value is invalid.';
// Initialization Errors
    OLEUI_ERR_FINDTEMPLATEFAILURE : Result := 'Unable to find the dialog template.';
    OLEUI_ERR_LOADTEMPLATEFAILURE : Result := 'Unable to load the dialog template.';
    OLEUI_ERR_DIALOGFAILURE : Result := 'Dialog initialization failed.';
    OLEUI_ERR_LOCALMEMALLOC : Result := 'A call to LocalAlloc or the standard IMalloc allocator failed.';
    OLEUI_ERR_GLOBALMEMALLOC : Result := 'A call to GlobalAlloc or the standard IMalloc allocator failed.';
    OLEUI_ERR_LOADSTRING : Result := 'Unable to LoadString localized resources from the library.';
    OLEUI_ERR_OLEMEMALLOC : Result := 'A call to the standard IMalloc allocator failed.';
  else
// Function Specific Errors
// Errors common to all dialogs lie in the range OLEUI_ERR_STANDARDMIN to OLEUI_ERR_STANDARDMAX.
// This value allows the application to test for standard messages in order to display
// error messages to the user.
    case OleUIType of

      otPasteSpecial :
        case ACode of
          OLEUI_IOERR_SRCDATAOBJECTINVALID : Result := 'The lpSrcDataObject field of OLEUIPASTESPECIAL is invalid.';
          OLEUI_IOERR_ARRPASTEENTRIESINVALID : Result := 'The arrPasteEntries field of OLEUIPASTESPECIAL is invalid.';
          OLEUI_IOERR_ARRLINKTYPESINVALID : Result := 'The arrLinkTypes field of OLEUIPASTESPECIAL is invalid.';
          OLEUI_PSERR_CLIPBOARDCHANGED : Result := 'The clipboard contents changed while the dialog was displayed.';
          OLEUI_PSERR_GETCLIPBOARDFAILED : Result := 'The lpSrcDataObj member is incorrect.';
        else
          Result := Format ('Unknown OleUIPasteSpecial Error (%d)', [ACode]);
          exit
        end;

      otBusy :
        case ACode of
          OLEUI_BZERR_HTASKINVALID : Result := 'The hTask member is invalid.';
        else
          Result := Format ('Unknown OleUIBusy Error (%d)', [ACode]);
          exit
        end;

      otPromptUser:
        begin
          Result := Format ('Unknown OleUIPromptUser Error (%d)', [ACode]);
          exit
        end;

      otChangeIcon :
        case ACode of
          OLEUI_CIERR_MUSTHAVECLSID : Result := 'The clsid member was not the current CLSID.';
          OLEUI_CIERR_MUSTHAVECURRENTMETAFILE : Result := 'The hMetaPict member was not the current metafile.';
          OLEUI_CIERR_SZICONEXEINVALID : Result := 'The szIconExe value was invalid.';
        else
          Result := Format ('Unknown OleUIChangeIcon Error (%d)', [ACode]);
          exit
        end;

      otInsertObject :
        case ACode of
          OLEUI_IOERR_LPSZFILEINVALID : Result := 'The lpszFile value is invalid or user has insufficient write access permissions.. This lpszFile member points to the name of the file linked to or inserted.';
          OLEUI_IOERR_LPFORMATETCINVALID : Result := 'The lpFormatEtc value is invalid. This member identifies the desired format.';
          OLEUI_IOERR_PPVOBJINVALID : Result := 'The ppvOjb value is invalid. This member points to the location where the pointer for the object is returned.';
          OLEUI_IOERR_LPIOLECLIENTSITEINVALID : Result := 'The lpIOleClientSite value is invalid. This member points to the client site for the object.';
          OLEUI_IOERR_LPISTORAGEINVALID : Result := 'The lpIStorage value is invalid. This member points to the storage to be used for the object.';
          OLEUI_IOERR_SCODEHASERROR : Result := Format ('The sc member of lpIO has additional error information:- %s', [OleErrorMsg(SCode)]);
          OLEUI_IOERR_LPCLSIDEXCLUDEINVALID : Result := 'The lpClsidExclude value is invalid. This member contains the list of CLSIDs to exclude.';
          OLEUI_IOERR_CCHFILEINVALID : Result := 'The cchFile or lpszFile value is invalid. The cchFile member specifies the size of the lpszFile buffer. The lpszFile member points to the name of the file linked to or inserted.';
        else
          Result := Format ('Unknown OleUIInsertObject Error (%d)', [ACode]);
          exit
        end;

      otObjectProps :
        case ACode of
          OLEUI_OPERR_SUBPROPNULL : Result := 'lpGP or lpVP is NULL, or dwFlags and OPF_OBJECTISLINK and lpLP are NULL.';
          OLEUI_OPERR_SUBPROPINVALID : Result := 'Insufficient write-access permissions for the structures pointed to by lpGP, lpVP, or lpLP.';
          OLEUI_OPERR_PROPSHEETNULL : Result := 'The lpLP value is NULL.';
          OLEUI_OPERR_PROPSHEETINVALID : Result := 'Insufficient write-access for one or more of the structures used by OLEUIOBJECTPROPS.';
          OLEUI_OPERR_SUPPROP : Result := 'The sub-link property pointer, lpLP, is NULL.';
          OLEUI_OPERR_PROPSINVALID : Result := 'Insufficient write access for the sub-link property pointer, lpLP.';
          OLEUI_OPERR_PAGESINCORRECT : Result := 'Some sub-link properties of the lpPS member are incorrect.';
          OLEUI_OPERR_INVALIDPAGES : Result := 'Some sub-link properties of the lpPS member are incorrect.';
          OLEUI_OPERR_NOTSUPPORTED : Result := 'A sub-link property of the lpPS member is incorrect.';
          OLEUI_OPERR_DLGPROCNOTNULL : Result := 'A sub-link property of the lpPS member is incorrect.';
          OLEUI_OPERR_LPARAMNOTZERO : Result := 'A sub-link property of the lpPS member is incorrect.';
          OLEUI_GPERR_STRINGINVALID : Result := 'A string value (for example, lplpszLabel or lplpszType) is invalid.';
          OLEUI_GPERR_CLASSIDINVALID : Result := 'The clsid value is invalid.';
          OLEUI_GPERR_LPCLSIDEXCLUDEINVALID : Result := 'The ClsidExcluded value is invalid.';
          OLEUI_GPERR_CBFORMATINVALID : Result := 'The wFormat value is invalid.';
          OLEUI_VPERR_METAPICTINVALID : Result := 'The hMetaPict value is invalid.';
          OLEUI_VPERR_DVASPECTINVALID : Result := 'The dvAspect value is invalid.';
          OLEUI_OPERR_PROPERTYSHEET : Result := 'The lpPS value is incorrect.';
          OLEUI_OPERR_OBJINFOINVALID : Result := 'The lpObjInfo value is NULL or the calling process doesn''t have read access.';
          OLEUI_OPERR_LINKINFOINVALID : Result := 'The lpLinkInfo value is NULL or the calling process doesn''t have read access.';
        else
          Result := Format ('Unknown OleUIObjectProperties Error (%d)', [ACode]);
          exit
        end;

      otEditLinks:
        begin
          Result := Format ('Unknown OleUIEditLinks Error (%d)', [ACode]);
          exit
        end;

      otConvert :
        case ACode of
          OLEUI_CTERR_CLASSIDINVALID : Result := 'A clsid value was invalid.';
          OLEUI_CTERR_DVASPECTINVALID : Result := 'The dvAspect value was invalid. This member specifies the aspect of the object.';
          OLEUI_CTERR_CBFORMATINVALID : Result := 'The wFormat value was invalid. This member specifies the data format of the object.';
          OLEUI_CTERR_HMETAPICTINVALID : Result := 'The hMetaPict value is invalid.';
          OLEUI_CTERR_STRINGINVALID : Result := 'A string value (for example, lpszUserType or lpszDefLabel) was invalid.';
        else
          Result := Format ('Unknown OleUIConvert Error (%d)', [ACode]);
          exit
        end;

      otChangeSource :
        case ACode of
          OLEUI_CSERR_LINKCNTRNULL : Result := 'The lpOleUILinkContainer value is NULL.';
          OLEUI_CSERR_LINKCNTRINVALID : Result := 'The lpOleUILinkContainer value is invalid.';
          OLEUI_CSERR_FROMNOTNULL : Result := 'The lpszFrom value is not NULL.';
          OLEUI_CSERR_TONOTNULL : Result := 'The lpszTo value is not NULL.';
          OLEUI_CSERR_SOURCEINVALID : Result := 'The lpszDisplayName or nFileLength value is invalid, or cannot retrieve the link source.';
          OLEUI_CSERR_SOURCEPARSEERROR : Result := 'The nFilename value is wrong.';
        else
          Result := Format ('Unknown OleUIChangeSource Error (%d)', [ACode]);
          exit
        end;

    else
      Result := Format ('Unknown OleUIXxxxx Error (%d)', [ACode]);
      exit
    end
  end;
  Result := Format ('OleUI%sDialog error (%d) - ', [OleUITypeName [OleUIType], ACode]) + Result
end;

procedure OleUIError (ACode : UINT; OleUIType : TOleUIType; SCode : HRESULT = 0);
begin
  raise OleUIException.Create (OleUIErrorMsg (ACode, OleUIType, SCode))
end;

function OleUICheck (ACode : UINT; OleUIType : TOleUIType; SCode : HRESULT = 0) : UINT;
begin
  Result := ACode;
// general successful codes
  if ACode in [OLEUI_FALSE, OLEUI_SUCCESS, OLEUI_CANCEL] then
    exit;
// specific OleUIBusy dialog success codes in the error code range
  if (OleUIType = otBusy) and (ACode in [OLEUI_BZ_SWITCHTOSELECTED, OLEUI_BZ_RETRYSELECTED, OLEUI_BZ_CALLUNBLOCKED]) then
    exit;

// error
  OleUIError (ACode, OleUIType, SCode)
end;



end.