frxres.pas

报表控件。FastReport 是非常强大的报表控件

{******************************************}
{                                          }
{             FastReport v3.0              }
{      Language resources management       }
{                                          }
{         Copyright (c) 1998-2006          }
{         by Alexander Tzyganenko,         }
{            Fast Reports Inc.             }
{                                          }
{******************************************}

unit frxRes;

interface

{$I frx.inc}

uses
  Windows, SysUtils, Classes, Controls, Graphics, Forms, ImgList, TypInfo
{$IFDEF Delphi6}
, Variants
{$ENDIF}
{$IFDEF FR_COM}
//, VCLCom
, ComObj
//, ComServ
, FastReport_TLB
{$ENDIF};


type
{$IFDEF FR_COM}
  TfrxResources = class(TComponent, IfrxResources)
{$ELSE}
  TfrxResources = class(TObject)
{$ENDIF}
  private
    FDisabledButtonImages: TImageList;
    FMainButtonImages: TImageList;
    FNames: TStringList;
    FObjectImages: TImageList;
    FPreviewButtonImages: TImageList;
    FValues: TStringList;
    FLanguages: TStringList;
    FHelpFile: String;
    function GetMainButtonImages: TImageList;
    function GetObjectImages: TImageList;
    procedure BuildLanguagesList;
    function GetPreviewButtonImages: TImageList;
  public
{$IFNDEF FR_COM}
    constructor Create;
{$ELSE}
    constructor Create(AOwner: TComponent); override;
{$ENDIF}
    destructor Destroy; override;
    function Get(const StrName: String): String;
    procedure Add(const Ref, Str: String);
    procedure AddStrings(const Str: String);
    procedure Clear;
    procedure LoadFromFile(const FileName: String);
    procedure LoadFromStream(Stream: TStream);
    procedure SetButtonImages(Images: TBitmap; Clear: Boolean = False);
    procedure SetObjectImages(Images: TBitmap; Clear: Boolean = False);
    procedure SetPreviewButtonImages(Images: TBitmap; Clear: Boolean = False);
    procedure UpdateFSResources;
    procedure Help(Sender: TObject); overload;
    property DisabledButtonImages: TImageList read FDisabledButtonImages;
    property MainButtonImages: TImageList read GetMainButtonImages;
    property PreviewButtonImages: TImageList read GetPreviewButtonImages;
    property ObjectImages: TImageList read GetObjectImages;
    property Languages: TStringList read FLanguages;
    property HelpFile: String read FHelpFile write FHelpFile;
{$IFDEF FR_COM}
    function Get_HelpFile(out Value: WideString): HResult; stdcall;
    function Set_HelpFile(const Value: WideString): HResult; stdcall;
    function Help: HResult; overload; stdcall;
    function GetResourceString(const ID: WideString; out Value: WideString): HResult; stdcall;
    function LoadLanguageResourcesFromFile(const FileName: WideString): HResult; stdcall;
{$ENDIF}
  end;

function frxResources: TfrxResources;
function frxGet(ID: Integer): String;


implementation

uses frxUtils, frxChm, fs_iconst;

var
  FResources: TfrxResources = nil;


{ TfrxResources }

constructor TfrxResources.Create;
begin
  inherited;
  FDisabledButtonImages := TImageList.Create(nil);
  FDisabledButtonImages.Width := 16;
  FDisabledButtonImages.Height := 16;
  FMainButtonImages := TImageList.Create(nil);
  FMainButtonImages.Width := 16;
  FMainButtonImages.Height := 16;
  FObjectImages := TImageList.Create(nil);
  FObjectImages.Width := 22;
  FObjectImages.Height := 22;
  FPreviewButtonImages := TImageList.Create(nil);
  FPreviewButtonImages.Width := 16;
  FPreviewButtonImages.Height := 16;
  FNames := TStringList.Create;
  FValues := TStringList.Create;
  FNames.Sorted := True;
  FLanguages := TStringList.Create;
  HelpFile := 'FRUser.chm';
  BuildLanguagesList;
end;

destructor TfrxResources.Destroy;
begin
  FLanguages.Free;
  FDisabledButtonImages.Free;
  FMainButtonImages.Free;
  FObjectImages.Free;
  FPreviewButtonImages.Free;
  FNames.Free;
  FValues.Free;
  inherited;
end;

procedure TfrxResources.Add(const Ref, Str: String);
var
  i: Integer;
begin
  i := FNames.IndexOf(Ref);
  if i = -1 then
  begin
    FNames.AddObject(Ref, Pointer(FValues.Count));
    FValues.Add(Str);
  end
  else
    FValues[Integer(FNames.Objects[i])] := Str;
end;

procedure TfrxResources.AddStrings(const Str: String);
var
  i: Integer;
  sl: TStringList;
  nm, vl: String;
begin
  sl := TStringList.Create;
  sl.Text := Str;
  for i := 0 to sl.Count - 1 do
  begin
    nm := sl[i];
    vl := Copy(nm, Pos('=', nm) + 1, MaxInt);
    nm := Copy(nm, 1, Pos('=', nm) - 1);
    if (nm <> '') and (vl <> '') then
      Add(nm, vl);
  end;
  sl.Free;
end;

procedure TfrxResources.Clear;
begin
  FNames.Clear;
  FValues.Clear;
end;

function TfrxResources.Get(const StrName: String): String;
var
  i: Integer;
begin
  i := FNames.IndexOf(StrName);
  if i <> -1 then
    Result := FValues[Integer(FNames.Objects[i])] else
    Result := StrName;
end;

function TfrxResources.GetMainButtonImages: TImageList;
var
  Images: TBitmap;
begin
  if FMainButtonImages.Count = 0 then
  begin
    Images := TBitmap.Create;
    try
      Images.LoadFromResourceName(hInstance, 'frxBUTTONS');
      SetButtonImages(Images);
    finally
      Images.Free;
    end;
  end;

  Result := FMainButtonImages;
end;

function TfrxResources.GetPreviewButtonImages: TImageList;
var
  Images: TBitmap;
begin
  if FPreviewButtonImages.Count = 0 then
  begin
    Images := TBitmap.Create;
    try
      Images.LoadFromResourceName(hInstance, 'PREVIEWBUTTONS');
      SetPreviewButtonImages(Images);
    finally
      Images.Free;
    end;
  end;

  Result := FPreviewButtonImages;
end;

function TfrxResources.GetObjectImages: TImageList;
var
  Images: TBitmap;
begin
  if FObjectImages.Count = 0 then
  begin
    Images := TBitmap.Create;
    try
      Images.LoadFromResourceName(hInstance, 'frxOBJECTS');
      SetObjectImages(Images);
    finally
      Images.Free;
    end;
  end;

  Result := FObjectImages;
end;

procedure TfrxResources.SetButtonImages(Images: TBitmap; Clear: Boolean = False);
begin
  if Clear then
  begin
    FMainButtonImages.Clear;
    FDisabledButtonImages.Clear;
  end;
  frxAssignImages(Images, 16, 16, FMainButtonImages, FDisabledButtonImages);
end;

procedure TfrxResources.SetObjectImages(Images: TBitmap; Clear: Boolean = False);
begin
  if Clear then
    FObjectImages.Clear;
  frxAssignImages(Images, 22, 22, FObjectImages);
end;

procedure TfrxResources.SetPreviewButtonImages(Images: TBitmap; Clear: Boolean = False);
begin
  if Clear then
    FPreviewButtonImages.Clear;
  frxAssignImages(Images, 16, 16, FPreviewButtonImages);
end;

procedure TfrxResources.LoadFromFile(const FileName: String);
var
  f: TFileStream;
begin
  if FileExists(FileName) then
  begin
    f := TFileStream.Create(FileName, fmOpenRead);
    try
      LoadFromStream(f);
    finally
      f.Free;
    end;
  end;
end;

procedure TfrxResources.LoadFromStream(Stream: TStream);
var
  sl: TStringList;
  i: Integer;
  nm, vl: String;
begin
  sl := TStringList.Create;
  try
    sl.LoadFromStream(Stream);
    Clear;
    for i := 0 to sl.Count - 1 do
    begin
      nm := sl[i];
      vl := Copy(nm, Pos('=', nm) + 1, MaxInt);
      nm := Copy(nm, 1, Pos('=', nm) - 1);
      if (nm <> '') and (vl <> '') then
        Add(nm, vl);
    end;
  finally
    sl.Free;
  end;
  UpdateFSResources;
end;

procedure TfrxResources.UpdateFSResources;
begin
  SLangNotFound := Get('SLangNotFound');
  SInvalidLanguage := Get('SInvalidLanguage');
  SIdRedeclared := Get('SIdRedeclared');
  SUnknownType := Get('SUnknownType');
  SIncompatibleTypes := Get('SIncompatibleTypes');
  SIdUndeclared := Get('SIdUndeclared');
  SClassRequired := Get('SClassRequired');
  SIndexRequired := Get('SIndexRequired');
  SStringError := Get('SStringError');
  SClassError := Get('SClassError');
  SArrayRequired := Get('SArrayRequired');
  SVarRequired := Get('SVarRequired');
  SNotEnoughParams := Get('SNotEnoughParams');
  STooManyParams := Get('STooManyParams');
  SLeftCantAssigned := Get('SLeftCantAssigned');
  SForError := Get('SForError');
  SEventError := Get('SEventError');
end;

type
  THelpTopic = record
    Sender: String;
    Topic: String;
  end;

const
  helpTopicsCount = 17;
  helpTopics: array[0..helpTopicsCount - 1] of THelpTopic =
   ((Sender: 'TfrxDesignerForm'; Topic: 'Designer/Designer.htm'),
    (Sender: 'TfrxOptionsEditor'; Topic: 'Designer/Designer options.htm'),
    (Sender: 'TfrxReportEditorForm'; Topic: 'Designer/Report settings.htm'),
    (Sender: 'TfrxPageEditorForm'; Topic: 'Designer/Page options.htm'),
    (Sender: 'TfrxCrossEditorForm'; Topic: 'Cross-tab reports/Cross-tab reports.htm'),
    (Sender: 'TfrxChartEditorForm'; Topic: 'Diagrams/Diagrams.htm'),
    (Sender: 'TfrxSyntaxMemo'; Topic: 'Script/Script.htm'),
    (Sender: 'TfrxDialogPage'; Topic: 'Dialogue forms/Dialogue forms.htm'),
    (Sender: 'TfrxDialogComponent'; Topic: 'Data access components/Data access components.htm'),
    (Sender: 'TfrxVarEditorForm'; Topic: 'Creating reports/Variables.htm'),
    (Sender: 'TfrxHighlightEditorForm'; Topic: 'Creating reports/Conditional highlighting.htm'),
    (Sender: 'TfrxSysMemoEditorForm'; Topic: 'Creating reports/Inserting aggregate function.htm'),
    (Sender: 'TfrxFormatEditorForm'; Topic: 'Creating reports/Values formatting.htm'),
    (Sender: 'TfrxGroupEditorForm'; Topic: 'Creating reports/Report with groups.htm'),
    (Sender: 'TfrxPictureEditorForm'; Topic: 'Creating reports/''Picture'' object.htm'),
    (Sender: 'TfrxMemoEditorForm'; Topic: 'Creating reports/The ''Text'' object.htm'),
    (Sender: 'TfrxSQLEditorForm'; Topic: 'Data access components/TfrxADOQuery.htm')
   );




procedure TfrxResources.Help(Sender: TObject);
var
  i: Integer;
  topic: String;
begin
  topic := '';
  if Sender <> nil then
    for i := 0 to helpTopicsCount - 1 do
      if CompareText(helpTopics[i].Sender, Sender.ClassName) = 0 then
        topic := '::/' + helpTopics[i].Topic;
  frxDisplayHHTopic(Application.Handle, FHelpFile + topic);
end;

procedure TfrxResources.BuildLanguagesList;
var
  i: Integer;
  SRec: TSearchRec;
  Dir: String;
  s: String;
begin
  Dir := GetAppPath;
  FLanguages.Clear;
  i := FindFirst(Dir + '*.frc', faAnyFile, SRec);
  try
    while i = 0 do
    begin
      s := LowerCase(SRec.Name);
      s := UpperCase(Copy(s, 1, 1)) + Copy(s, 2, Length(s) - 1);
      s := StringReplace(s, '.frc', '', []);
      FLanguages.Add(s);
      i := FindNext(SRec);
    end;
    FLanguages.Sort;
  finally
    FindClose(Srec);
  end;
end;


function frxResources: TfrxResources;
begin
  if FResources = nil then
{$IFNDEF FR_COM}
    FResources := TfrxResources.Create;
{$ELSE}
    FResources := TfrxResources.Create(nil);
{$ENDIF}
  Result := FResources;
end;

function frxGet(ID: Integer): String;
begin
  Result := frxResources.Get(IntToStr(ID));
end;

{$IFDEF FR_COM}
function TfrxResources.Get_HelpFile(out Value: WideString): HResult; stdcall;
begin
  Value := HelpFile;
  Result := S_OK;
end;

function TfrxResources.Set_HelpFile(const Value: WideString): HResult; stdcall;
begin
  HelpFile := Value;
  Result := S_OK;
end;

function TfrxResources.Help: HResult; stdcall;
begin
  Help(nil);
  Result := S_OK;
end;

function TfrxResources.GetResourceString(const ID: WideString; out Value: WideString): HResult; stdcall;
begin
  Value := Get(ID);
  Result := S_OK;
end;

function TfrxResources.LoadLanguageResourcesFromFile(const FileName: WideString): HResult; stdcall;
begin
  try
    LoadFromFile(FileName);
    Result := S_OK;
  except
    Result := E_FAIL;
  end;
end;
{$ENDIF}


initialization

finalization
  if FResources <> nil then
    FResources.Free;
  FResources := nil;

end.


//<censored>