Census Code

Brought to you by: kestrel_999, lasse_l
[r12]: / about.pas Maximize Restore History

492 lines (434 with data), 15.5 kB

{* ***** BEGIN LICENSE BLOCK *****                                            *}
{* Version: MPL 1.1                                                           *}
{*                                                                            *}
{* The contents of this file are subject to the Mozilla Public License        *}
{* Version 1.1 (the "License"); you may not use this file except in           *}
{* compliance with the License. You may obtain a copy of the License at       *}
{* http://www.mozilla.org/MPL/                                                *}
{*                                                                            *}
{* Software distributed under the License is distributed on an "AS IS" basis, *}
{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License   *}
{* for the specific language governing rights and limitations under the       *}
{* License.                                                                   *}
{*                                                                            *}
{* The Original Code is Census                                                *}
{*                                                                            *}
{* The Initial Developer of the Original Code is Justin Wilkins               *}
{*                                                                            *}
{* Portions created by Justin Wilkins are Copyright (C)2001-2011              *}
{* Justin Wilkins. All Rights Reserved.                                       *}
{*                                                                            *}
{* Contributor(s):                                                            *}
{*                                                                            *}
{* ***** END LICENSE BLOCK *****                                              *}

unit about;

interface

uses Windows, SysUtils, Classes, Graphics, Forms, Controls, StdCtrls, ShellAPI,
  Buttons, ExtCtrls, jpeg, ComCtrls, Registry, Brkapart, Dialogs,
  SHFolder;

type
  TAboutBox = class(TForm)
    OKButton: TButton;
    Label3: TLabel;
    Panel2: TPanel;
    ProgramIcon: TImage;
    Panel3: TPanel;
    lblLocale: TLabel;
    Panel4: TPanel;
    lblDate: TLabel;
    pnlVer: TPanel;
    brkUpp: TBrkApart;
    Panel5: TPanel;
    Panel6: TPanel;
    Panel7: TPanel;
    Label1: TLabel;
    pnlDisclaim: TPanel;
    Label2: TLabel;
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    function GetLocale: string;
    procedure FormCreate(Sender: TObject);
    function RunProg(Cmd, WorkDir: string): string;
    function BrkUp(brkStr: string; brkBase: string;
      brkInt: Integer): string;
    procedure lblPerlMouseEnter(Sender: TObject);
    procedure lblPerlMouseLeave(Sender: TObject);
    procedure lblPsNMouseEnter(Sender: TObject);
    procedure lblPsNMouseLeave(Sender: TObject);
    procedure lblRMouseLeave(Sender: TObject);
    procedure lblRMouseEnter(Sender: TObject);
    procedure lblXposeMouseEnter(Sender: TObject);
    procedure lblXposeMouseLeave(Sender: TObject);
    procedure lblRDblClick(Sender: TObject);
    procedure lblPsNDblClick(Sender: TObject);
    procedure lblPerlDblClick(Sender: TObject);
    procedure lblXposeDblClick(Sender: TObject);
    procedure ProgramIconDblClick(Sender: TObject);
    procedure lblRDCOMDblClick(Sender: TObject);
    procedure lblRDCOMMouseEnter(Sender: TObject);
    procedure lblRDCOMMouseLeave(Sender: TObject);
    function GetSpecialFolderPath(folder : integer) : string;
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  AboutBox: TAboutBox;

//const
  //CompileDateStr = '02/01/2008';
  //CompileTimeStr = 'Sometime';

implementation

{$R *.dfm}

//{$INCLUDE datetime.inc}
uses
  Project;

procedure TAboutBox.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Action := caFree;
  AboutBox := nil;
end;

function TAboutBox.GetLocale: string;
var
  Buffer: PChar;
  Size: integer;
begin
  Size := GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SLANGUAGE, nil,
    0);
  GetMem(Buffer, Size);
  try
    GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SLANGUAGE, Buffer,
      Size);
    Result := string(Buffer);
  finally
    FreeMem(Buffer);
  end;
end;

procedure TAboutBox.FormCreate(Sender: TObject);
var
  regIni: TRegIniFile;
  {strProg: string;
  strPerlVer, strPerlDir, strPsNDir, strPsNVer, strRDir, strRVer,
    strXposeVer, strXposeDate: string;
  blnPerl, blnPsN, blnR, blnRDCOM, blnXpose: Boolean;
  strPsN, strXpose: TStrings;
  n: Integer; }
begin
  {strProg := RunProg('perl -V:prefix -V:version', ExtractFilePath(Application.ExeName));
  regEx.RegEx := 'prefix=''.*'';';
  regEx.Subject := strProg;
  if RegEx.Match then
    blnPerl := True
  else
    blnPerl := False;  }

  {if blnPerl then
  begin
    strPerlVer := BrkUp('''', BrkUp(';', strProg, 1), 1);
    strPerlDir := BrkUp('''', BrkUp(';', strProg, 0), 1);
    if FileExists(strPerlDir + '\site\lib\PsN.pm') then
    begin
      blnPsN := True;
      strPsNDir := strPerlDir + '\site\lib';
      strPsN := TStringList.Create;
      strPsN.LoadFromFile(strPerlDir + '\site\lib\PsN.pm');
      for n := 0 to strPsN.Count - 1 do
        if Pos('$config_file', strPsN[n]) = 1 then
          strPsNVer := BrkUp('-', BrkUp('/', StringReplace(strPsN[n], '_', '-', [rfReplaceAll]), 1), 1);
      strPsN.Free;
    end
    else
    begin
      strPsNVer := 'NA';
      strPsNDir := '';
      blnPsN := False;
    end;
  end
  else
  begin
    strPerlVer := 'NA';
    strPerlDir := '';
    strPsNVer := 'NA';
    strPsNDir := '';
    blnPsN := False;
  end;    }

  regIni := TRegIniFile.Create('Software\Arrhythmia\Drumsticks');

  {RegIni.WriteString('Options', 'PerlVersion', strPerlVer);
  RegIni.WriteString('Options', 'PerlDirectory', strPerlDir);
  RegIni.WriteBool('Options', 'PerlInstalled', blnPerl);

  RegIni.WriteString('Options', 'PsNVersion', strPsNVer);
  RegIni.WriteString('Options', 'PsNDirectory', strPsNDir);
  RegIni.WriteBool('Options', 'PsNInstalled', blnPsN); }

  pnlVer.Caption := 'Version ' + regIni.ReadString('Options', 'Version', '0');

 { if regIni.ReadBool('Options', 'PerlInstalled', False) then
  begin
    lblPerl.Caption := 'Perl (' + strPerlDir + '): ' + strPerlVer;
    if blnPsN then
      lblPsN.Caption := 'PsN (' + strPsNDir + '): ' +
        strPsNVer
    else
    begin
      //lblPsN.Color := clRed;
      lblPsN.Font.Color := clREd;
      lblPsN.Caption := 'PsN: Not installed';
    end;
  end
  else
  begin
    lblPerl.Caption := 'Perl: Not installed';
    lblPsN.Caption := 'PsN: Not installed';
    lblPsN.Font.Color := clRed;
    lblPerl.Font.Color := clRed;
  end;

  // lblXpose.Caption := 'Xpose: v4.0 not yet released';

  with TRegistry.Create do
  try
    RootKey := HKEY_LOCAL_MACHINE;
    if OpenKey('\Software\R-core\R', False) then
    begin
      strRVer := ReadString('Current Version');
      strRDir := ReadString('InstallPath');
      CloseKey;
    end;
  except
    ;
  end;

  with TRegistry.Create do
  try
    RootKey := HKEY_CLASSES_ROOT;
    if OpenKey('\StatConnectorSrv.StatConnector\CLSID', False) then
    begin
      blnRDCOM := True;
      CloseKey;
    end
    else
      blnRDCOM := False;
  except
    ;
  end;

  if Length(strRDir) = 0 then
  begin
    strRDir := RegIni.ReadString('Options', 'XposeDir', '');
    if Length(strRDir) > 5 then
      strRVer := Copy(strRDir, Length(strRDir)-4, 200);
    if Pos('.', strRVer) = 1 then           // version 2.10 or greater
      strRVer := Copy(strRDir, Length(strRDir)-5, 200);
  end;  }

  {blnR := False;
  if (Length(strRVer) > 0) and
    (Length(strRDir) > 0) then
    blnR := True;

  if blnR then
    blnXpose := True;      }
    {if FileExists(strRDir + '\library\xpose4\DESCRIPTION') then
    begin
      blnXpose := True;
      strXpose := TStringList.Create;
      strXpose.LoadFromFile(strRDir + '\library\xpose4\DESCRIPTION');
      for n := 0 to strXpose.Count - 1 do
      begin
        if Pos('Version:', strXpose[n]) > 0 then
          strXposeVer := Copy(strXpose[n], 10, 100);
        if Pos('Date:', strXpose[n]) > 0 then
          strXposeDate := Copy(strXpose[n], 7, 100);
      end;
    end
    else
    begin
      if FileExists(GetSpecialFolderPath(CSIDL_PERSONAL) +
        '\R\win-library\' + Copy(strRVer, 1, Length(strRVer) - 2) + '\xpose4\DESCRIPTION') then
      begin
        blnXpose := True;
        strXpose := TStringList.Create;
        strXpose.LoadFromFile(GetSpecialFolderPath(CSIDL_PERSONAL) +
          '\R\win-library\' + Copy(strRVer, 1, Length(strRVer) - 2) + '\xpose4\DESCRIPTION');
        for n := 0 to strXpose.Count - 1 do
        begin
          if Pos('Version:', strXpose[n]) > 0 then
            strXposeVer := Copy(strXpose[n], 10, 100);
          if Pos('Date:', strXpose[n]) > 0 then
            strXposeDate := Copy(strXpose[n], 7, 100);
        end;
      end;
    end;  }

  {if blnXpose then
  begin
    if FileExists(strRDir + '\library\xpose4\DESCRIPTION') then
      lblXpose.Caption := 'Xpose 4 (' + strRDir + '\library\xpose4): ' +
      strXposeVer + ' (' + strXposeDate + ')';
    if FileExists(GetSpecialFolderPath(CSIDL_PERSONAL) +
      '\R\win-library\' + Copy(strRVer, 1, Length(strRVer) - 2) + '\xpose4\DESCRIPTION') then
      lblXpose.Caption := 'Xpose 4 (' + GetSpecialFolderPath(CSIDL_PERSONAL) +
        '\R\win-library\' + Copy(strRVer, 1, Length(strRVer) - 2) + '\xpose4): ' +
      strXposeVer + ' (' + strXposeDate + ')';
  end
  else
  begin
    lblXpose.Caption := 'Xpose 4: Not installed';
    lblXpose.Font.Color := clRed;
  end; }

  {if blnR then
    lblR.Caption := 'R (' + strRDir + '): ' + strRVer
  else
  begin
    lblR.Caption := 'R: Not installed';
    lblR.Font.Color := clRed;
  end; }

//  if blnRDCOM then
//    lblRDCOM.Caption := 'R(D)COM: Installed'
//  else
//  begin
//    lblRDCOM.Caption := 'R(D)COM: Not installed';
//    lblRDCOM.Font.Color := clRed;
//  end;

  regIni.Free;

  lblLocale.Caption := 'The default locale is set to ' + GetLocale + '.';
  lblDate.Caption := 'This build was created on ' + COMPILE_DATE + ' at ' +
    COMPILE_TIME + ' CEST.';    
end;

function TAboutBox.RunProg(Cmd, WorkDir: string): string;
var
  tsi: TStartupInfo;
  tpi: TProcessInformation;
  nRead: DWORD;
  aBuf: array[0..101] of char;
  sa: TSecurityAttributes;
  hOutputReadTmp, hOutputRead, hOutputWrite, hInputWriteTmp, hInputRead,
    hInputWrite, hErrorWrite: THandle;
  FOutput: string;
begin
  FOutput := '';

  sa.nLength := SizeOf(TSecurityAttributes);
  sa.lpSecurityDescriptor := nil;
  sa.bInheritHandle := True;

  CreatePipe(hOutputReadTmp, hOutputWrite, @sa, 0);
  DuplicateHandle(GetCurrentProcess(), hOutputWrite, GetCurrentProcess(),
    @hErrorWrite, 0, true, DUPLICATE_SAME_ACCESS);
  CreatePipe(hInputRead, hInputWriteTmp, @sa, 0);

 // Create new output read handle and the input write handle. Set
 // the inheritance properties to FALSE. Otherwise, the child inherits
 // the these handles; resulting in non-closeable handles to the pipes
 // being created.
  DuplicateHandle(GetCurrentProcess(), hOutputReadTmp, GetCurrentProcess(),
    @hOutputRead, 0, false, DUPLICATE_SAME_ACCESS);
  DuplicateHandle(GetCurrentProcess(), hInputWriteTmp, GetCurrentProcess(),
    @hInputWrite, 0, false, DUPLICATE_SAME_ACCESS);
  CloseHandle(hOutputReadTmp);
  CloseHandle(hInputWriteTmp);

  FillChar(tsi, SizeOf(TStartupInfo), 0);
  tsi.cb := SizeOf(TStartupInfo);
  tsi.dwFlags := STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;
  tsi.hStdInput := hInputRead;
  tsi.hStdOutput := hOutputWrite;
  tsi.hStdError := hErrorWrite;

  CreateProcess(nil, PChar(Cmd), @sa, @sa, true, 0, nil, PChar(WorkDir),
    tsi, tpi);
  CloseHandle(hOutputWrite);
  CloseHandle(hInputRead);
  CloseHandle(hErrorWrite);
  Application.ProcessMessages;

  repeat
    if (not ReadFile(hOutputRead, aBuf, 16, nRead, nil)) or (nRead = 0) then
    begin
      if GetLastError = ERROR_BROKEN_PIPE then
        Break
      else
        MessageDlg('Pipe read error, could not execute file!', mtError, [mbOK], 0);
    end;
    aBuf[nRead] := #0;
    FOutput := FOutput + PChar(@aBuf[0]);
    Application.ProcessMessages;
  until False;

  Result := FOutput;
 //GetExitCodeProcess(tpi.hProcess, nRead) = True;
end;

function TAboutBox.BrkUp(brkStr: string; brkBase: string;
  brkInt: Integer): string;
begin
  brkUpp.StringList.Clear;
  brkUpp.BaseString := brkBase;
  brkUpp.BreakString := brkStr;
  brkUpp.BreakApart;
  //ShowMessage(Trim(brkUpp.StringList[brkInt]));
  Result := Trim(brkUpp.StringList[brkInt]);
end;

procedure TAboutBox.lblPerlMouseEnter(Sender: TObject);
begin
  //lblPerl.Font.Style := [fsUnderline];
end;

procedure TAboutBox.lblPerlMouseLeave(Sender: TObject);
begin
  //lblPerl.Font.Style := [];
end;

procedure TAboutBox.lblPsNMouseEnter(Sender: TObject);
begin
  //lblPsN.Font.Style := [fsUnderline];
end;

procedure TAboutBox.lblPsNMouseLeave(Sender: TObject);
begin
  //lblPsN.Font.Style := [];
end;

procedure TAboutBox.lblRMouseLeave(Sender: TObject);
begin
  //lblR.Font.Style := [];
end;

procedure TAboutBox.lblRMouseEnter(Sender: TObject);
begin
  //lblR.Font.Style := [fsUnderline];
end;

procedure TAboutBox.lblXposeMouseEnter(Sender: TObject);
begin
  //lblXpose.Font.Style := [fsUnderline];
end;

procedure TAboutBox.lblXposeMouseLeave(Sender: TObject);
begin
  //lblXpose.Font.Style := [];
end;

procedure TAboutBox.lblRDblClick(Sender: TObject);
begin
  //ShellExecute(self.WindowHandle,
  //  'open', 'http://www.r-project.org', nil, nil, SW_SHOWNORMAL);
end;

procedure TAboutBox.lblPsNDblClick(Sender: TObject);
begin
  //ShellExecute(self.WindowHandle,
  //  'open', 'http://psn.sourceforge.net', nil, nil, SW_SHOWNORMAL);
end;

procedure TAboutBox.lblPerlDblClick(Sender: TObject);
begin
  //ShellExecute(self.WindowHandle,
  //  'open', 'http://www.activestate.com/Products/ActivePerl/?mp=1', nil, nil, SW_SHOWNORMAL);
end;

procedure TAboutBox.lblXposeDblClick(Sender: TObject);
begin
  //ShellExecute(self.WindowHandle,
  //  'open', 'http://xpose.sourceforge.net', nil, nil, SW_SHOWNORMAL);
end;

procedure TAboutBox.ProgramIconDblClick(Sender: TObject);
begin
  //ShellExecute(self.WindowHandle,
  //  'open', 'http://www.farmbio.uu.se/upload/avd5/Census/', nil, nil, SW_SHOWNORMAL);
end;

procedure TAboutBox.lblRDCOMDblClick(Sender: TObject);
begin
  //ShellExecute(self.WindowHandle,
  //  'open', 'http://cran.r-project.org/contrib/extra/dcom', nil, nil, SW_SHOWNORMAL);
end;

procedure TAboutBox.lblRDCOMMouseEnter(Sender: TObject);
begin
  //lblRDCOM.Font.Style := [fsUnderline];
end;

procedure TAboutBox.lblRDCOMMouseLeave(Sender: TObject);
begin
  //lblRDCOM.Font.Style := [];
end;

function TAboutBox.GetSpecialFolderPath(folder : integer) : string;
const
  SHGFP_TYPE_CURRENT = 0;
var
  path: array [0..MAX_PATH] of char;
begin
  if SUCCEEDED(SHGetFolderPath(0,folder,0,SHGFP_TYPE_CURRENT,@path[0])) then
    Result := path
  else
    Result := '';
end;

end.