cxclasses.pas

来自「胜天进销存源码,国产优秀的进销存」· PAS 代码 · 共 2,401 行 · 第 1/5 页

    function Insert(AIndex: Integer): TcxComponentCollectionItem;
    procedure Remove(AItem: TcxComponentCollectionItem);

    property Count: Integer read GetCount;
    property ParentComponent: TComponent read FParentComponent;
    property Items[AIndex: Integer]: TcxComponentCollectionItem read GetItem write SetItem; default;
    property OnChange: TcxComponentCollectionChangeEvent read FOnChange write FOnChange;
  end;

  { TcxDialogMetricsInfo }

  IcxDialogMetricsInfoData = interface
    ['{DBFB3040-4677-4C9D-913C-45A1EE41E35A}']
    function GetInfoData: Pointer;
    function GetInfoDataSize: Integer;
    procedure SetInfoData(AData: Pointer);
  end;

  TcxDialogMetricsInfo = class
  private
    FClientHeight: Integer;
    FClientWidth: Integer;
    FData: Pointer;
    FDialogClass: TClass;
    FLeft: Integer;
    FTop: Integer;
    FMaximized: Boolean;
    procedure FreeCustomData;
  protected
    procedure Restore(AForm: TForm);
    procedure Store(AForm: TForm);
  public
    constructor Create(AForm: TForm);
    destructor Destroy; override;
    property ClientHeight: Integer read FClientHeight;
    property ClientWidth: Integer read FClientWidth;
    property Data: Pointer read FData;
    property DialogClass: TClass read FDialogClass;
    property Left: Integer read FLeft;
    property Maximized: Boolean read FMaximized;
    property Top: Integer read FTop;
  end;

  { TcxDialogsMetricsStore }

  TcxDialogsMetricsStore = class
  private
    FDefaultPosition: TPosition;
    FMetrics: TcxObjectList;
  protected
    function CreateMetrics(AForm: TForm): TcxDialogMetricsInfo;
    function FindMetrics(AForm: TForm): Integer;
    property Metrics: TcxObjectList read FMetrics;
  public
    constructor Create; virtual;
    destructor Destroy; override;
    procedure InitDialog(AForm: TForm);
    procedure StoreMetrics(AForm: TForm);

    property DefaultPosition: TPosition read FDefaultPosition write FDefaultPosition default poMainFormCenter;
  end;

  { TcxThread }

  TcxThread = class(TThread)
  private
    FException: Exception;
    procedure DoHandleException;
  protected
    procedure HandleException; virtual;
    procedure ResetException;
  end;

  TcxNotifyProcedure = procedure(Sender: TObject);

// component dialogs metrics storage
function cxDialogsMetricsStore: TcxDialogsMetricsStore;

function cxAddObjectLink(AObject: TObject): TcxObjectLink;
procedure cxRemoveObjectLink(ALink: TcxObjectLink);
procedure cxClearObjectLinks(AObject: TObject);

procedure CallNotify(ANotifyEvent: TNotifyEvent; ASender: TObject);
function ClassInheritsFrom(AClass: TClass; const AParentClassName: string): Boolean;
procedure CopyList(ASource, ADestination: TList);
function EqualMethods(const AMethod1, AMethod2: TMethod): Boolean;
procedure FillStringsWithEnumTypeValues(AStrings: TStrings; ATypeInfo: PTypeInfo;
  AGetTypeItemCaption: TcxGetCaptionForIntegerItemFunc);
function GetPersistentOwner(APersistent: TPersistent): TPersistent;
function GetSubobjectName(AObject, ASubobject: TPersistent): string;
function GetValidName(AComponent: TComponent; const AName: string;
  AIsBaseName: Boolean = False): string;
function HexToByte(const AHex: string): Byte;
procedure RenameComponents(ACaller, AOwner: TComponent;
  ANewName, AOldName: TComponentName;
  AComponentCount: Integer; AGetComponent: TcxGetComponent);
function RoundDiv(I1, I2: Integer): Integer;
function Size(cx, cy: Longint): TSize;
procedure SwapIntegers(var I1, I2: Integer);
function GetRangeCenter(ABound1, ABound2: Integer): Integer;
function StreamsEqual(AStream1, AStream2: TMemoryStream): Boolean;
procedure OpenWebPage(const AWebAddress: string);
function GetCorrectPath(const S: string): string;

{$IFNDEF DELPHI6}
function IfThen(AValue: Boolean; ATrue: Integer; AFalse: Integer = 0): Integer;
function InRange(AValue, AMin, AMax: Integer): Boolean;
function Supports(const Instance: TObject; const IID: TGUID): Boolean; overload;
{$IFNDEF DELPHI5}
function Supports(const Instance: IUnknown; const Intf: TGUID; out Inst): Boolean; overload;
function Supports(Instance: TObject; const Intf: TGUID; out Inst): Boolean; overload;
procedure FreeAndNil(var Obj);
{$ENDIF}
{$ENDIF}

function cxGetLocaleInfo(ALocale, ALocaleType: Integer; const ADefaultValue: string): string;
function cxStrCharLength(const AStr: string; AIndex: Integer = 1): Integer;
function cxNextCharPos(const AStr: string; AIndex: Integer): Integer;
function cxPrevCharPos(const AStr: string; AIndex: Integer): Integer;

function cxGetResourceString(AResString: TcxResourceStringID): string; overload;
procedure cxSetResourceString(AResString: TcxResourceStringID; const Value: string);
function cxGetResourceString(const AResString: string): string; overload;{$IFDEF DELPHI6} deprecated;{$ENDIF}
function cxGetResourceStringNet(const AResString: string): string;{$IFDEF DELPHI6} deprecated;{$ENDIF}
procedure cxSetResourceStringNet(const AResString, Value: string);{$IFDEF DELPHI6} deprecated;{$ENDIF}

function CreateUniqueName(AOwnerForm, AOwnerComponent, AComponent: TComponent;
  const APrefixName, ASuffixName: string): string;

procedure cxZeroMemory(ADestination: Pointer; ACount: Integer);
function cxAllocMem(Size: Cardinal): Pointer;
procedure cxFreeMem(P: Pointer);

procedure cxCopyData(Source, Dest: Pointer; Count: Integer); overload;
procedure cxCopyData(Source, Dest: Pointer; ASourceOffSet, ADestOffSet, Count: Integer); overload;
function ReadBoolean(ASource: Pointer; AOffset: Integer = 0): WordBool;
function ReadByte(ASource: Pointer; AOffset: Integer = 0): Byte;
function ReadInteger(ASource: Pointer; AOffset: Integer = 0): Integer;
function ReadWord(ASource: Pointer; AOffset: Integer = 0): Word;
procedure WriteBoolean(ADest: Pointer; AValue: WordBool; AOffset: Integer = 0);
procedure WriteByte(ADest: Pointer; AValue: Byte; AOffset: Integer = 0);
procedure WriteInteger(ADest: Pointer; AValue: Integer; AOffset: Integer = 0);
procedure WriteWord(ADest: Pointer; AValue: Word; AOffset: Integer = 0);

function cxSign(const AValue: Double): Integer;

procedure SetHook(var AHook: HHook; AHookId: Integer; AHookProc: TFNHookProc);
procedure ReleaseHook(var AHook: HHOOK);

implementation

uses
  Math, Graphics, Controls;

type
  TPersistentAccess = class(TPersistent);

var
  FObjectLinkController: TcxObjectLinkController;
  FObjectLinkControllerRefCount: Integer;
  FDialogsMetrics: TcxDialogsMetricsStore;

function GetShortHint(const Hint: string): string;
var
  I: Integer;
begin
  I := AnsiPos('|', Hint);
  if I = 0 then
    Result := Hint else
    Result := Copy(Hint, 1, I - 1);
end;

function GetLongHint(const Hint: string): string;
var
  I: Integer;
begin
  I := AnsiPos('|', Hint);
  if I = 0 then
    Result := Hint else
    Result := Copy(Hint, I + 1, Maxint);
end;

{$IFNDEF DELPHI6}
function IfThen(AValue: Boolean; ATrue, AFalse: Integer): Integer;
begin
  if AValue then
    Result := ATrue
  else
    Result := AFalse;
end;

function InRange(AValue, AMin, AMax: Integer): Boolean;
begin
  Result := (AValue <= AMax) and (AValue >= AMin);
end;

function Supports(const Instance: TObject; const IID: TGUID): Boolean;
var
  Temp: IUnknown;
begin
  Result := Supports(Instance, IID, Temp);
end;
{$IFNDEF DELPHI5}
function Supports(const Instance: IUnknown; const Intf: TGUID; out Inst): Boolean; overload;
begin
  Result := (Instance <> nil) and (Instance.QueryInterface(Intf, Inst) = 0);
end;

function Supports(Instance: TObject; const Intf: TGUID; out Inst): Boolean; overload;
var
  Unk: IUnknown;
begin
  Result := (Instance <> nil) and Instance.GetInterface(IUnknown, Unk) and
    Supports(Unk, Intf, Inst);
end;

procedure FreeAndNil(var Obj);
var
  Temp: TObject;
begin
  Temp := TObject(Obj);
  Pointer(Obj) := nil;
  Temp.Free;
end;
{$ENDIF}
{$ENDIF}

function cxGetLocaleInfo(ALocale, ALocaleType: Integer; const ADefaultValue: string): string;
var
  ABuffer: string;
  ABufferSize: Integer;
begin
  ABufferSize := GetLocaleInfo(ALocale, ALocaleType, nil, 0);
  if ABufferSize = 0 then
    Result := ADefaultValue
  else
  begin
    SetLength(ABuffer, ABufferSize);
    GetLocaleInfo(ALocale, ALocaleType, PChar(ABuffer), ABufferSize);
    Result := Copy(ABuffer, 1, ABufferSize - 1)
  end;
end;

function GetPChar(const AStr: string; AIndex: Integer): PChar;
begin
  Result := PChar(AStr) + AIndex - 1;
end;

function cxStrCharLength(const AStr: string; AIndex: Integer = 1): Integer;
begin
  Result := Integer(CharNext(GetPChar(AStr, AIndex))) - Integer(GetPChar(AStr, AIndex));
end;

function cxNextCharPos(const AStr: string; AIndex: Integer): Integer;
begin
  Result := Integer(CharNext(GetPChar(AStr, AIndex))) - Integer(GetPChar(AStr, 1)) + 1;
end;

function cxPrevCharPos(const AStr: string; AIndex: Integer): Integer;
begin
  Result := Integer(CharPrev(GetPChar(AStr, 1), GetPChar(AStr, AIndex))) - Integer(GetPChar(AStr, 1)) + 1;
end;

{ TcxIUnknownObject }

function TcxIUnknownObject.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  if GetInterface(IID, Obj) then
    Result := S_OK
  else
    Result := E_NOINTERFACE;
end;

function TcxIUnknownObject._AddRef: Integer;
begin
  Result := -1;
end;

function TcxIUnknownObject._Release: Integer;
begin
  Result := -1;
end;

{ TcxInterfacedPersistent }

constructor TcxInterfacedPersistent.Create(AOwner: TPersistent);
begin
  inherited Create;
  FOwner := AOwner;
end;

function TcxInterfacedPersistent.GetOwner: TPersistent;
begin
  Result := FOwner;
end;

{$IFNDEF DELPHI6}

function TcxInterfacedPersistent._AddRef: Integer;
begin
  if FOwnerInterface <> nil then
    Result := FOwnerInterface._AddRef
  else
    Result := -1;
end;

function TcxInterfacedPersistent._Release: Integer;
begin
  if FOwnerInterface <> nil then
    Result := FOwnerInterface._Release
  else
    Result := -1;
end;

function TcxInterfacedPersistent.QueryInterface(const IID: TGUID; out Obj): HResult;
const
  E_NOINTERFACE = HResult($80004002);
begin
  if GetInterface(IID, Obj) then
    Result := 0
  else
    Result := E_NOINTERFACE;
end;

procedure TcxInterfacedPersistent.AfterConstruction;
begin
  inherited;
  if GetOwner <> nil then
    GetOwner.GetInterface(IUnknown, FOwnerInterface);
end;
{$ENDIF}

{ TcxOwnedPersistent }

constructor TcxOwnedPersistent.Create(AOwner: TPersistent);
begin
  inherited Create;
  FOwner := AOwner;
end;

function TcxOwnedPersistent.GetOwner: TPersistent;
begin
  Result := FOwner;
end;

{ TcxOwnedInterfacedPersistent }

function TcxOwnedInterfacedPersistent._AddRef: Integer;
begin
  Result := -1;
end;

function TcxOwnedInterfacedPersistent._Release: Integer;
begin
  Result := -1;
end;

function TcxOwnedInterfacedPersistent.QueryInterface(
  const IID: TGUID; out Obj): HResult;
begin
  if GetInterface(IID, Obj) then Result := 0 else Result := cxE_NOINTERFACE;
end;

{ TcxComponent }

destructor TcxComponent.Destroy;
begin
  cxClearObjectLinks(Self);
  inherited Destroy;
end;

procedure TcxComponent.Loaded;
begin
  inherited Loaded;
  UpdateFakeLinks;
end;

procedure TcxComponent.BeforeDestruction;
begin
  if not IsDestroying then Destroying;
end;

procedure TcxComponent.GetFakeComponentLinks(AList: TList);
begin
end;

procedure TcxComponent.UpdateFakeLinks;
var
  I: Integer;
  AList: TList;
begin
  if not IsDesigning or IsDestroying or (Owner = nil) then Exit;
  AList := TList.Create;
  try
    GetFakeComponentLinks(AList);
    for I := 0 to GetFakeComponentLinkCount - 1 do
      if I < AList.Count then
        SetFakeComponentLink(I, TComponent(AList[I]))
      else
        SetFakeComponentLink(I, nil);
  finally
    AList.Free;
  end;
end;

function TcxComponent.GetFakeComponentLinkCount: Integer;
begin
  Result := 3;
end;

function TcxComponent.GetIsDesigning: Boolean;
begin
  Result := csDesigning in ComponentState;
end;

function TcxComponent.GetIsDestroying: Boolean;
begin
  Result := csDestroying in ComponentState;
end;

procedure TcxComponent.SetFakeComponentLink(Index: Integer; Value: TComponent);
begin
  case Index of
    0: FFakeComponentLink1 := Value;
    1: FFakeComponentLink2 := Value;
    2: FFakeComponentLink3 := Value;
  end;
end;

{ TcxCollection }

procedure TcxCollection.Assign(Source: TPersistent);
var
  I: Integer;
  AItem: TCollectionItem;
begin
  if Source is TCollection then
  begin
    if (Count = 0) and (TCollection(Source).Count = 0) then Exit;
    BeginUpdate;
    try
      for I := 0 to TCollection(Source).Count - 1 do
      begin
        if I > Count - 1 then
          AItem := Add
        else
          AItem := Items[I];
        AItem.Assign(TCollection(Source).Items[I]);
      end;
      for I := Count - 1 downto TCollection(Source).Count do
        Delete(I);
    finally
      EndUpdate;
    end;
  end
  else
    inherited;
end;

{$IFNDEF DELPHI6}
function TcxCollection.Owner: TPersistent;
begin
  Result := GetOwner;
end;
{$ENDIF}

{ TcxObjectList }

procedure TcxObjectList.Clear;
var
  I: Integer;
begin
  for I := 0 to Count - 1 do
    Items[I].Free;
  inherited Clear;
end;

function TcxObjectList.GetItem(Index: Integer): TObject;
begin
  Result := inherited Items[Index];
end;