unit U_GUID;

interface
uses SysUtils;

type
  EGUIDerror = class(Exception)
  private
    FErrorCode: HRESULT;
  public
    constructor Create(const AErrorCode: HRESULT);
    property ErrorCode: HRESULT read FErrorCode write FErrorCode;
  end;

function Get_GUID: string;

implementation
uses
  Windows;

type
  TCLSID = TGUID;

{$EXTERNALSYM CoCreateGuid}
function CoCreateGuid(var guid: TGUID): HResult; stdcall; forward;
{$EXTERNALSYM CoTaskMemFree}
procedure CoTaskMemFree(pv: Pointer); stdcall; forward;
{$EXTERNALSYM StringFromCLSID}
function StringFromCLSID(const clsid: TCLSID; var psz: PWideChar): HResult; stdcall; forward;

function CoCreateGuid;    external 'ole32.dll' name 'CoCreateGuid';
procedure CoTaskMemFree;  external 'ole32.dll' name 'CoTaskMemFree';
function StringFromCLSID; external 'ole32.dll' name 'StringFromCLSID';

ResourceString
  SError = 'GUID error %.8x';
  
constructor EGUIDError.Create(const AErrorCode: HRESULT);
var
  S: string;
begin
  S := SysErrorMessage(AErrorCode);
  if S = '' then FmtStr(S, SError, [AErrorCode]);
  inherited Create(S);
  FErrorCode := AErrorCode;
end;

function GUIDToString(const ClassID: TGUID): string;
var
  P: PWideChar;
  Res: HResult
begin
  Res := StringFromCLSID(ClassID, P);
  if not Succeeded(Res) then begin
    raise EGUIDError.Create(Res);
  end;
  Result := P;
  CoTaskMemFree(P);
end;


function Get_GUID: string;
var
  MyGUID: TGUID;
begin
  if CoCreateGUID(MyGUID) = s_Ok then begin
    Result := GUIDToString(MyGUID);
    if copy(Result, 1, 1) = '{' then begin
      Delete(Result, Length(Result), 1);
      Delete(Result, 1, 1);
    end;
  end
  else Result := 'Error';
end;

end.