(* HLINKA-SOFT, (c) August 2000 *)
(* only for Delphi 3 and C++ Builder 3 and later*)
unit Transl;

{ Example of using:

 In your main unit:

uses ... Transl;

type
  TMainForm = class(TForm)
    MainMenu1: TMainMenu;
    ...
    Language1: TMenuItem; //example: Language1.Caption:='Language'
    ...
  protected
    procedure LangBefore(Sender: TObject; var Continue: Boolean);
    procedure LangAfter(Sender: TObject);
  end;

procedure TMainForm.FormCreate(Sender: TObject);
begin
  ...
  TranslatesAdd(Language1, LangBefore, LangAfter);
// or, for example,  TranslatesAdd(Language1, nil, nil);
end;

// Your custom initialize functions for treatment any events
// Example:
procedure TMainForm.LangAfter(Sender: TObject);
var
  Ini: TIniFile;
begin
  Ini := TIniFile.Create(OwnerPath + 'Localize.ini');
  Left := Ini.ReadInteger('MainForm', 'Left', Left);
  Top := Ini.ReadInteger('MainForm', 'Top', Top);
  Width := Ini.ReadInteger('MainForm', 'Width', Width);
  Height := Ini.ReadInteger('MainForm', 'Height', Height);
  Ini.Free;
end;

procedure TMainForm.LangBefore(Sender: TObject; var Continue: Boolean);
var
  Ini: TIniFile;
begin
  Ini := TIniFile.Create(OwnerPath + 'Localize.ini');
  Ini.WriteInteger('MainForm', 'Left', Left);
  Ini.WriteInteger('MainForm', 'Top', Top);
  Ini.WriteInteger('MainForm', 'Width', Width);
  Ini.WriteInteger('MainForm', 'Height', Height);
  Ini.Free;
end;

If user click to [default], then program next load localization
by your Windows national set, if existing, or original set of
program.
}


{$IFDEF VER80}        {Delphi 1.0}
 {$DEFINE BADVER}
{$ENDIF}
{$IFDEF VER90}        {Delphi 2.0}
 {$DEFINE BADVER}
{$ENDIF}
{$IFDEF VER93}        {BCB 1.0}
 {$DEFINE BADVER}
{$ENDIF}

{$IFNDEF VER80}       {Delphi 1.0}
 {$IFNDEF VER90}      {Delphi 2.0}
  {$IFNDEF VER93}     {BCB 1.0}
   {$DEFINE DVER3}    {Delphi 3.0 or BCB 3.0}
   {$UNDEF BADVER}
  {$ENDIF}
 {$ENDIF}
{$ENDIF}

{$IFDEF DVER3}
 {$IFNDEF VER100}     {Delphi 3}
  {$IFNDEF VER110}    {BCB 3}
   {$DEFINE DVER4}    {Delphi 4.0 or higher}
   {$UNDEF DVER3}
  {$ENDIF}
 {$ENDIF}
{$ENDIF}

{$IFDEF DVER4}
 {$IFNDEF VER120}     {Delphi 4}
  {$IFNDEF VER125}    {BCB 4}
   {$DEFINE DVER5}    {Delphi 5.0 or higher}
  {$ENDIF}
 {$ENDIF}
{$ENDIF}

interface

uses
  Windows, SysUtils, Classes, Controls, Forms, Dialogs, Messages,
  Menus, Registry;

const
{ In your D4+ programs you can switch languages without restarting of program.
  But, opened form return to the default setting. You can treat every form
  by following messages. This is similar as OnBeforeTrans and OnAfterTrans.
  Example:

type
  TMyForm = class(TForm)
    procedure WMBeforeReinitialize(var Msg: TMessage); message WM_BEFOREREINITIALIZE;
    procedure WMAfterReinitialize(var Msg: TMessage); message WM_AFTERREINITIALIZE;
    ...
procedure TMyForm.WMBeforeReinitialize(var Msg: TMessage);
begin
  // see LangBefore above
end;

procedure TMyForm.WMAfterReinitialize(var Msg: TMessage);
begin
  // see LangAfter above
end;
}
  WM_BEFOREREINITIALIZE = WM_USER + $7000;
  WM_AFTERREINITIALIZE = WM_USER + $7001;

  DfltName = 'Dflt'; // do not localize
{$IFDEF BADVER}
  LocaleOverrideKey = '';
{$ENDIF}
{$IFDEF DVER4}
  LocaleOverrideKey = 'Software\Borland\Locales'; // do not localize
{$ELSE}
{$IFDEF DVER3}
  LocaleOverrideKey = 'Software\Borland\Delphi\Locales'; // do not localize
{$ENDIF}
{$ENDIF}
     //see LocaleOverrideKey from System.pas
     //and System.LoadResourceModule

type
  TLoadInit = procedure of object;
  TAfterEvent = procedure(Sender: TObject) of object;
  TBeforeEvent = procedure(Sender: TObject; var Continue: Boolean) of object;

{ Return current language loaded into program. Call only at starting of program,
  in FormCreate event for example. }
function GetCurrentLanguage: string;
function LoadNewResourceModule(Locale: string): LongWord;
procedure ReinitializeForms;
procedure TranslatesAdd(Menu: TMenuItem; BeforeEvent: TBeforeEvent; AfterEvent: TAfterEvent;
  ShowCloseMessage: boolean {$IFDEF DVER4} = false {$ENDIF});

implementation

resourcestring
  RestartProgram = 'Restart this program';
  Dflt = '[default]';

type
  TClickObj = class
  private
    FOnAfterTrans: TAfterEvent;
    FOnBeforeTrans: TBeforeEvent;
  protected
    FLoadInit: TLoadInit;
    FCloseMessage: boolean;
    function BeforeEvent(Sender: TObject): Boolean;
  public
    procedure Click(Sender: TObject);
    property OnAfterTrans : TAfterEvent read FOnAfterTrans write FOnAfterTrans;
    property OnBeforeTrans : TBeforeEvent read FOnBeforeTrans write FOnBeforeTrans;
  end;

var
  Click: TClickObj;

{$IFDEF DVER4}
type
  TAsInheritedReader = class(TReader)
  public
    procedure ReadPrefix(var Flags: TFilerFlags; var AChildPos: Integer); override;
  end;

procedure TAsInheritedReader.ReadPrefix(var Flags: TFilerFlags; var AChildPos: Integer);
begin
  inherited ReadPrefix(Flags, AChildPos);
  Include(Flags, ffInherited);
end;

function GetCurrentLanguage: string;
var
  Key: HKey;
  FileName: array[0..260] of Char;
  Size: Integer;
  LocaleName, LocaleOverride: array[0..4] of Char;
  P: PChar;
begin
  GetModuleFileName(HInstance, FileName, SizeOf(FileName)); // Get host appliation name
  LocaleOverride[0] := #0;
  if RegOpenKeyEx(HKEY_CURRENT_USER, LocaleOverrideKey, 0, KEY_ALL_ACCESS, Key) = 0 then
  try
    Size := SizeOf(LocaleOverride);
    if RegQueryValueEx(Key, FileName, nil, nil, PByte(@LocaleOverride), @Size) <> 0 then
      RegQueryValueEx(Key, '', nil, nil, PByte(@LocaleOverride), @Size);
  finally
    RegCloseKey(Key);
  end;
  GetLocaleInfo(GetThreadLocale, LOCALE_SABBREVLANGNAME, LocaleName, SizeOf(LocaleName));
  Result := '';
  if (FileName[0] <> #0) and ((LocaleName[0] <> #0) or (LocaleOverride[0] <> #0)) then
  begin
    P := PChar(@FileName) + lstrlen(FileName);
    while (P^ <> '.') and (P <> @FileName) do Dec(P);
    if P <> @FileName then
    begin
      Inc(P);
      // First look for a locale registry override
      if LocaleOverride[0] <> #0 then
      begin
        lstrcpy(P, LocaleOverride);
        if FileExists(FileName) then Result := LocaleOverride;
      end;
      if (Result = '') and (LocaleName[0] <> #0) then
      begin
        // Then look for a potential language/country translation
        lstrcpy(P, LocaleName);
        if FileExists(FileName) then Result := LocaleName;
        if Result = '' then
        begin
          // Finally look for a language only translation
          LocaleName[2] := #0;
          lstrcpy(P, LocaleName);
          if FileExists(FileName) then Result := LocaleName;
        end;
      end;
    end;
  end;
end;

function SetResourceHInstance(NewInstance: LongWord): LongWord;
var
  CurModule: PLibModule;
begin
  CurModule := LibModuleList;
  Result := 0;
  while CurModule <> nil do
  begin
    if CurModule.Instance = HInstance then
    begin
      if CurModule.ResInstance <> CurModule.Instance then
        FreeLibrary(CurModule.ResInstance);
      CurModule.ResInstance := NewInstance;
      Result := NewInstance;
      Exit;
    end;
    CurModule := CurModule.Next;
  end;
end;

function LoadNewResourceModule(Locale: string): LongWord;
var
  NewInst: HModule;
begin
  Result := 0;
  NewInst := LoadLibraryEx(PChar(Locale), 0, LOAD_LIBRARY_AS_DATAFILE);
  if NewInst <> 0 then
    Result := SetResourceHInstance(NewInst);
end;

function InternalReloadComponentRes(const ResName: string; HInst: THandle; var Instance: TComponent): Boolean;
var
  HRsrc: THandle;
  ResStream: TResourceStream;
  AsInheritedReader: TAsInheritedReader;
begin                   { avoid possible EResNotFound exception }
  if HInst = 0 then HInst := HInstance;
  HRsrc := FindResource(HInst, PChar(ResName), RT_RCDATA);
  Result := HRsrc <> 0;
  if not Result then Exit;
  ResStream := TResourceStream.Create(HInst, ResName, RT_RCDATA);
  try
    AsInheritedReader := TAsInheritedReader.Create(ResStream, 4096);
    try
      Instance := AsInheritedReader.ReadRootComponent(Instance);
    finally
      AsInheritedReader.Free;
    end;
  finally
    ResStream.Free;
  end;
  Result := True;
end;

function ReloadInheritedComponent(Instance: TComponent; RootAncestor: TClass): Boolean;

  function InitComponent(ClassType: TClass): Boolean;
  begin
    Result := False;
    if (ClassType = TComponent) or (ClassType = RootAncestor) then Exit;
    Result := InitComponent(ClassType.ClassParent);
    Result := InternalReloadComponentRes(ClassType.ClassName, FindResourceHInstance(
      FindClassHInstance(ClassType)), Instance) or Result;
  end;

begin
  Result := InitComponent(Instance.ClassType);
end;

procedure ReinitializeForms;
var
  Count: Integer;
  I: Integer;
  Form: TForm;
  Module: TDataModule;
begin
  Count := Screen.FormCount;
  for I := 0 to Count - 1 do
  begin
    Form := Screen.Forms[I];
    SendMessage(Form.Handle, WM_BEFOREREINITIALIZE, 0, 0);
    ReloadInheritedComponent(Form, TForm);
    SendMessage(Form.Handle, WM_AFTERREINITIALIZE, 0, 0);
  end;
  Count := Screen.DataModuleCount;
  for I := 0 to Count - 1 do
  begin
    Module := Screen.DataModules[I];
    ReloadInheritedComponent(Module, TDataModule);
  end;
end;

{$ENDIF}

procedure SaveLangToRegister(FileName, LangLocal: string);
var
  Reg: TRegIniFile;
  P: PChar;
  Extension: string;
begin
  P := PChar(FileName) + Length(FileName);
  while (P^ <> '.') and (P <> PChar(FileName)) do Dec(P);
  if P^ = '.' then Inc(P);
  Extension := string(P);
  if UpperCase(LangLocal) = 'EXE' then LangLocal := Extension;
  Reg := TRegIniFile.Create('');
  Reg.RootKey := HKEY_CURRENT_USER;
  Reg.WriteString(LocaleOverrideKey, FileName, LangLocal);
  Reg.Free;
end;

function TClickObj.BeforeEvent(Sender: TObject): Boolean;
begin
  Result := true;
  if Assigned(FOnBeforeTrans) then
     FOnBeforeTrans(Sender, Result);
end;

procedure TClickObj.Click(Sender: TObject);
var
//  Reg: TRegIniFile;
  s: string;
begin
  if not BeforeEvent(Sender) then Exit;
  with (Sender as TMenuItem) do
  begin
    s := System.Copy(Name, 1, Length(Name) - 1);
    if s = DfltName then
{$IFDEF DVER4}
     s := 'exe';
{$ELSE}
{$IFDEF DVER3}
     s := '';
{$ENDIF}
{$ENDIF}
    SaveLangToRegister(Application.ExeName, s);
{$IFDEF DVER4}
    if FCloseMessage then ShowMessage(RestartProgram) else
    if LoadNewResourceModule(ChangeFileExt(Application.ExeName, '.' + s)) <> 0 then
     ReinitializeForms;
{$ELSE}
{$IFDEF DVER3}
    ShowMessage(RestartProgram);
{$ENDIF}
{$ENDIF}
  end;
  if Assigned(FOnAfterTrans) then FOnAfterTrans(Sender);
end;

procedure TranslatesAdd(Menu: TMenuItem; BeforeEvent: TBeforeEvent; AfterEvent: TAfterEvent;
  ShowCloseMessage: boolean);
var
  i, j, k, Sub: integer;
  c: array[0..255] of char;
  s, s1: string;
  ExeFile: string;
  List: TStringList;
begin
{$IFDEF BADVER}
  Exit;
{$ENDIF}
  Click.OnBeforeTrans := BeforeEvent;
  Click.OnAfterTrans := AfterEvent;
  Click.FCloseMessage := ShowCloseMessage;
  ExeFile := Application.ExeName;
  while ExeFile[Length(ExeFile)] <> '.' do
   System.Delete(ExeFile, Length(ExeFile), 1);
  List := TStringList.Create;
  for i := 1 to $7F do
  begin
    Sub := 0;
    j := GetLocaleInfo(i, LOCALE_SABBREVLANGNAME, c, SizeOf(c));
    while j > 0 do
    begin
      if Sub = 0 then c[2] := #0;
      s := c;
      if FileExists(ExeFile + s) and (List.IndexOf(s) = -1) then
      begin
        List.Add(s);
        GetLocaleInfo(i, LOCALE_SLANGUAGE, c, SizeOf(c));
        s1 := c;
        k := Pos('(', s1);
        if k > 0 then System.Delete(s1, k, Length(s1));
        s1 := Trim(s1);
        if Sub > 0 then
        begin
          GetLocaleInfo((Sub shl 10) + i, LOCALE_SCOUNTRY, c, SizeOf(c));
          s1 := s1 + ' (' + c + ')';
        end;
        Menu.Add(NewItem(s1, 0, false, true, Click.Click, 0, s + '1'));
      end;
      Inc(Sub);
      j := GetLocaleInfo((Sub shl 10) + i, LOCALE_SABBREVLANGNAME, c, SizeOf(c));
    end;
  end;
  if List.Count = 0 then Menu.Enabled := false;
{ TODO : unremove as soon as will be repair bug in System.LoadResourceModule }
//   else Menu.Insert(0, NewItem(Dflt, 0, false, true, Click.Click, 0, DfltName + '1'));
  List.Free;
end;

initialization
  Click := TClickObj.Create;

finalization
  Click.Free;

end.
