cxclasses.pas

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

function TcxComponentCollection.GetItem(AIndex: Integer): TcxComponentCollectionItem;
begin
  Result := TcxComponentCollectionItem(FItems[AIndex]);
end;

function TcxComponentCollection.GetOwner: TPersistent;
begin
  Result := ParentComponent;
end;

procedure TcxComponentCollection.Notify(AItem: TcxComponentCollectionItem;
  AAction: TcxComponentCollectionNotification);
begin
end;

procedure TcxComponentCollection.SetItem(AIndex: Integer; Value: TcxComponentCollectionItem);
begin
  Items[AIndex].Assign(Value);
end;

procedure TcxComponentCollection.SetItemName(AItem: TcxComponentCollectionItem);
begin

end;

procedure TcxComponentCollection.Update(AItem: TcxComponentCollectionItem;
  AAction: TcxComponentCollectionNotification);
begin
  if Assigned(OnChange) then
    OnChange(Self, AItem, AAction);
end;

function TcxComponentCollection.GetCount: Integer;
begin
  Result := FItems.Count;
end;

{ functions }

procedure CallNotify(ANotifyEvent: TNotifyEvent; ASender: TObject);
begin
  if Assigned(ANotifyEvent) then
    ANotifyEvent(ASender);
end;

function ClassInheritsFrom(AClass: TClass; const AParentClassName: string): Boolean;
var
  AParentClass: TClass;
begin
  AParentClass := AClass;
  repeat
    Result := AParentClass.ClassName = AParentClassName;
    if Result then Break;
    AParentClass := AParentClass.ClassParent;
  until AParentClass = nil;
end;

procedure CopyList(ASource, ADestination: TList);
begin
  ADestination.Count := ASource.Count;
  Move(ASource.List^, ADestination.List^, ASource.Count * SizeOf(Pointer));
end;

function EqualMethods(const AMethod1, AMethod2: TMethod): Boolean;
begin
  Result := (AMethod1.Code = AMethod2.Code) and (AMethod1.Data = AMethod2.Data);
end;

procedure FillStringsWithEnumTypeValues(AStrings: TStrings; ATypeInfo: PTypeInfo;
  AGetTypeItemCaption: TcxGetCaptionForIntegerItemFunc);
var
  ATypeData: PTypeData;
  I: Integer;
  S: string;
begin
  ATypeData := GetTypeData(ATypeInfo);
  AStrings.BeginUpdate;
  try
    for I := ATypeData.MinValue to ATypeData.MaxValue do
    begin
      S := AGetTypeItemCaption(I);
      if S <> '' then
        AStrings.AddObject(S, TObject(I));
    end;
  finally
    AStrings.EndUpdate;
  end;
end;

function GetPersistentOwner(APersistent: TPersistent): TPersistent;
begin
  Result := TPersistentAccess(APersistent).GetOwner;
end;

function GetSubobjectName(AObject, ASubobject: TPersistent): string;
var
  APropList: PPropList;
  I: Integer;
begin
  Result := '';
  I := GetPropList(AObject.ClassInfo, [tkClass], nil);
  GetMem(APropList, I * SizeOf(PPropInfo));
  GetPropList(AObject.ClassInfo, [tkClass], APropList);
  try
    for I := 0 to I - 1 do
      if APropList[I].PropType^ = ASubobject.ClassInfo then
      begin
        Result := APropList[I].Name;
        Break;
      end;
  finally
    FreeMem(APropList);
  end;
end;

function GetValidName(AComponent: TComponent; const AName: string;
  AIsBaseName: Boolean = False): string;
var
  AOwner: TComponent;
  I: Integer;

  function GetNextName: string;
  begin
    Result := AName + IntToStr(I);
    Inc(I);
  end;

begin
  Result := AName;
  AOwner := AComponent.Owner;
  if AOwner = nil then Exit;
  I := 1;
  if AIsBaseName then Result := GetNextName;
  while AOwner.FindComponent(Result) <> nil do
    Result := GetNextName;
end;

function HexToByte(const AHex: string): Byte;

  function CharToByte(C: Char): Byte;
  begin
    if C <= '9' then
      Result := Ord(C) - Ord('0')
    else
      Result := 10 + Ord(Upcase(C)) - Ord('A');
  end;

begin
  Result := 16 * CharToByte(AHex[1]) + CharToByte(AHex[2]);
end;

procedure RenameComponents(ACaller, AOwner: TComponent;
  ANewName, AOldName: TComponentName;
  AComponentCount: Integer; AGetComponent: TcxGetComponent);
var
  I: Integer;
  AComponent: TComponent;
  AComponentName, ANamePrefix: TComponentName;
begin
  // Components introduced in an ancestor will be renamed by IDE.
  // We cannot rename components introduced in a successor because
  // IDE will not refresh source code in a successor.
  if csAncestor in ACaller.ComponentState then Exit;
  for I := 0 to AComponentCount - 1 do
  begin
    AComponent := AGetComponent(ACaller, I);
    if (AComponent.Owner = AOwner) {and not (csAncestor in AComponent.ComponentState)} then
    begin
      AComponentName := AComponent.Name;
      if Length(AComponentName) > Length(AOldName) then
      begin
        ANamePrefix := Copy(AComponentName, 1, Length(AOldName));
        if CompareText(AOldName, ANamePrefix) = 0 then
        begin
          Delete(AComponentName, 1, Length(AOldName));
          Insert(ANewName, AComponentName, 1);
          try
            AComponent.Name := AComponentName;
          except
            on EComponentError do { Ignore rename errors };
          end;
        end;
      end;
    end;
  end;
end;

function RoundDiv(I1, I2: Integer): Integer;
begin
  Result := I1 div I2 + Ord(I1 mod I2 <> 0);
end;

function Size(cx, cy: Longint): TSize;
begin
  Result.cx := cx;
  Result.cy := cy;
end;

procedure SwapIntegers(var I1, I2: Integer);
var
  I: Integer;
begin
  I := I1;
  I1 := I2;
  I2 := I;
end;

function GetRangeCenter(ABound1, ABound2: Integer): Integer;
begin
  if ABound1 + ABound2 > 0 then
    Result := (ABound1 + ABound2) div 2
  else
    Result := (ABound1 + ABound2 - 1) div 2;
end;

function StreamsEqual(AStream1, AStream2: TMemoryStream): Boolean;
begin
  Result := (AStream1.Size = AStream2.Size) and
    CompareMem(AStream1.Memory, AStream2.Memory, AStream1.Size);
end;

procedure OpenWebPage(const AWebAddress: string);
begin
  ShellExecute(0, 'OPEN', PChar(string(AWebAddress)), nil, nil, SW_SHOWMAXIMIZED);
end;

function GetCorrectPath(const S: string): string;
var
  I: Integer;
begin
  Result := S;
  for I := 1 to Length(Result) do
    if Result[I] = '/' then
      Result[I] := {$IFDEF DELPHI6}PathDelim{$ELSE}'\'{$ENDIF};
end;

type
  TcxResourceStringsModificationMode = (rmmByResStringValue, rmmByResStringID, rmmUndefined);

  TcxResOriginalStrings = class(TStringList)
  public
  {$IFNDEF DELPHI6}
    function IndexOf(const S: string): Integer; override;
  {$ELSE}
    constructor Create;
  {$ENDIF}
  end;

{$IFNDEF DELPHI6}
function TcxResOriginalStrings.IndexOf(const S: string): Integer;
var
  I: Integer;
begin
  Result := -1;
  for I := 0 to Count - 1 do
    if AnsiCompareStr(Get(I), S) = 0 then
    begin
      Result := I;
      Break;
    end;
end;
{$ELSE}
constructor TcxResOriginalStrings.Create;
begin
  inherited Create;
  CaseSensitive := True;
end;
{$ENDIF}

var
  FResOriginalStrings: TcxResOriginalStrings;
  FResStrings: TStringList;
  FResStringsModificationMode: TcxResourceStringsModificationMode = rmmUndefined;

procedure CreateResStringLists(
  AResStringsModificationMode: TcxResourceStringsModificationMode);
begin
  if AResStringsModificationMode = rmmUndefined then
    raise Exception.Create('');
  if (FResStringsModificationMode <> rmmUndefined) and
    (AResStringsModificationMode <> FResStringsModificationMode) then
      raise Exception.Create('You cannot mix cxSetResourceString and cxSetResourceStringNet calls');

  if FResStringsModificationMode = rmmUndefined then
  begin
    FResStringsModificationMode := AResStringsModificationMode;
    FResOriginalStrings := TcxResOriginalStrings.Create;
    FResStrings := TStringList.Create;
  end;
end;

procedure DestroyResStringLists;
begin
  FResStringsModificationMode := rmmUndefined;
  FreeAndNil(FResOriginalStrings);
  FreeAndNil(FResStrings);
end;

function GetResOriginalStringIndex(AResString: TcxResourceStringID): Integer;
begin
  case FResStringsModificationMode of
    rmmByResStringValue:
      Result := FResOriginalStrings.IndexOf(LoadResString(AResString));
    rmmByResStringID:
      Result := FResOriginalStrings.IndexOfObject(TObject(AResString));
  else
    Result := -1;
  end;
end;

function cxGetResourceString(AResString: TcxResourceStringID): string;
var
  AIndex: Integer;
begin
  AIndex := GetResOriginalStringIndex(AResString);
  if AIndex <> -1 then
    Result := FResStrings[AIndex]
  else
    Result := LoadResString(AResString);
end;

procedure cxSetResourceString(AResString: TcxResourceStringID;
  const Value: string);
var
  AIndex: Integer;
begin
  CreateResStringLists(rmmByResStringID);
  AIndex := GetResOriginalStringIndex(AResString);
  if AIndex <> -1 then
    FResStrings[AIndex] := Value
  else
  begin
    FResOriginalStrings.AddObject(LoadResString(AResString), TObject(AResString));
    FResStrings.Add(Value);
  end;
end;

function cxGetResourceString(const AResString: string): string;{$IFDEF DELPHI6} deprecated;{$ENDIF}
begin
  Result := cxGetResourceStringNet(AResString);
end;

function cxGetResourceStringNet(const AResString: string): string;{$IFDEF DELPHI6} deprecated;{$ENDIF}
var
  AIndex: Integer;
begin
  Result := AResString;
  if FResOriginalStrings <> nil then
  begin
    AIndex := FResOriginalStrings.IndexOf(AResString);
    if AIndex <> -1 then
      Result := FResStrings[AIndex];
  end
end;

procedure cxSetResourceStringNet(const AResString, Value: string);{$IFDEF DELPHI6} deprecated;{$ENDIF}
var
  AIndex: Integer;
begin
  CreateResStringLists(rmmByResStringValue);
  AIndex := FResOriginalStrings.IndexOf(AResString);
  if AIndex <> -1 then
    FResStrings[AIndex] := Value
  else
  begin
    FResOriginalStrings.Add(AResString);
    FResStrings.Add(Value);
  end;
end;

function CreateUniqueName(AOwnerForm, AOwnerComponent, AComponent: TComponent;
  const APrefixName, ASuffixName: string): string;
var
  I, J: Integer;

  function GenerateName(AOwnerComponent: TComponent;
    const AClassName, APrefixName, ASuffixName: string; ANumber: Integer): string;
  var
    S: string;

    procedure CheckName(var AName: string);
    var
      I: Integer;
    begin
      I := 1;
      while I <= Length(AName) do
        if AName[I] in ['A'..'Z','a'..'z','_','0'..'9'] then
          Inc(I)
        else
          if AName[I] in LeadBytes then
            Delete(AName, I, 2)
          else
            Delete(AName, I, 1);
    end;

  begin
    S := ASuffixName;
    CheckName(S);
    if ((S = '') or (S[1] in ['0'..'9'])) and (AClassName <> '') then
      if (APrefixName <> '') and
        (CompareText(APrefixName, Copy(AClassName, 1, Length(APrefixName))) = 0) then
        S := Copy(AClassName, Length(APrefixName) + 1, Length(AClassName)) + S
      else
      begin
        S := AClassName + S;
        if S[1] = 'T' then Delete(S, 1, 1);
      end;
    if AOwnerComponent <> nil then
      Result := AOwnerComponent.Name + S
    else
      Result := S;
    if ANumber > 0 then
      Result := Result + IntToStr(ANumber);
  end;

  function IsUnique(const AName: string): Boolean;
  var
    I: Integer;
  begin
    Result := True;
    with AOwnerForm do
      for I := 0 to ComponentCount - 1 do
        if (Components[I] <> AComponent) and
          (CompareText(Components[I].Name, AName) = 0) then
        begin
          Result := False;
          Break;
        end;
  end;

begin
  if ASuffixName <> '' then
    J := 0
  else
    J := 1;
  for I := J to MaxInt do
  begin
    Result := GenerateName(AOwnerComponent, AComponent.ClassName,
      APrefixName, ASuffixName, I);
    if IsUnique(Result) then
      Break;
  end;
end;

procedure cxZeroMemory(ADestination: Pointer; ACount: Integer);
begin
  ZeroMemory(ADestination, ACount);
end;

function cxAllocMem(Size: Cardinal): Pointer;
begin
  GetMem(Result, Size);
  cxZeroMemory(Result, Size);
end;

procedure cxFreeMem(P: Pointer);
begin
  FreeMem(P);
end;

procedure cxCopyData(Source, Dest: Pointer; Count: Integer);
begin
  Move(Source^, Dest^, Count);
end;

procedure cxCopyData(Source, Dest: Pointer; ASourceOffSet, ADestOffSet, Count: Integer); overload;
begin
  if ASourceOffSet > 0 then
    Source := Pointer(Integer(Source) + ASourceOffSet);
  if ADestOffSet > 0 then
    Dest := Pointer(Integer(Dest) + ADestOffSet);
  cxCopyData(Source, Dest, Count);
end;

function ReadBoolean(ASource: Pointer; AOffset: Integer = 0): WordBool;
b