{-------------------------------------------------------------------------------
Name					:	SolutionsUnlimitedPathEd.pas
Author				: Robert Kozak
Date					: November 1, 1997

Copyright			: © 1997 Solutions Unlimited. All Rights Reserved.

Version 			: 1.0
Last Updated	:

Description		: This is an expert for managing the Paths in Delphi.

Notes:
-------------------------------------------------------------------------------}
unit SolutionsUnlimitedPathEd;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ComCtrls, Registry, StdCtrls, ExptIntf, ToolIntf, Placemnt,
  RzLstBox, RzChkLst, ExtCtrls, rkCommon, RzPanel, Menus,
	RzSelDir{, subclass};

const
  DELPHI_3_PATHHISTORY        = '\Software\Borland\Delphi\3.0\HistoryList\hiLibraryPath';
	DELPHI_3_PATH 							= '\Software\Borland\Delphi\3.0\Library\';
	DELPHI_3_FULLPATH						= '\Software\Borland\Delphi\3.0\Library\FULLPath\';
	DELPHI_3_KNOWN_PACKAGES 		= '\Software\Borland\Delphi\3.0\Known Packages';
	DELPHI_3_DISABLED_PACKAGES	= '\Software\Borland\Delphi\3.0\Disabled Packages';

  DELPHI_3_SOLUTIONS					= '\Software\Borland\Delphi\3.0\Solutions\';
	DELPHI_3_PATH_KEY						= 'SearchPath';

type
  TPathEdExpert = class(TIExpert)
  private
    fMenuItem: TIMenuItemIntf;
//    SubClasser : TSubClasser;
    procedure MenuClick(Sender: TIMenuItemIntf);
    procedure NewWndProc(var Msg : TMessage); virtual;
	protected
		procedure PreProcessMsg(Sender: TObject; var msg: TMessage; var bContinue: Boolean);
    procedure PostProcessMsg(Sender: TObject; var msg: TMessage; var bContinue: Boolean);
		procedure UpdateDelphiPath;
  public
		constructor Create;
    destructor Destroy; override;
    procedure Execute; override;
    function GetAuthor: string; override;
    function GetComment: string; override;
    function GetGlyph: HICON; override;
    function GetIDString: string; override;
    function GetMenuText: string; override;
    function GetName: string; override;
    function GetPage: string; override;
    function GetState: TExpertState; override;
    function GetStyle: TExpertStyle; override;
    property MenuItem: TIMenuItemIntf read fMenuItem;
  end;

  TfrmSetPath = class(TForm)
    Panel1: TPanel;
    btnDown: TButton;
    btnAdd: TButton;
    btnUp: TButton;
    btnRemove: TButton;
    StatusBar1: TStatusBar;
    FormStorage: TFormStorage;
    dlgGetDir: TRzSelDirDialog;
    pnlList: TPanel;
    TabControl1: TTabControl;
    lstPath: TRzCheckList;
    btnOptions: TButton;
    PopupMenu1: TPopupMenu;
    Sort1: TMenuItem;
    btnClose: TButton;
    procedure btnAddClick(Sender: TObject);
    procedure btnRemoveClick(Sender: TObject);
    procedure btnUpClick(Sender: TObject);
    procedure btnDownClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormCreate(Sender: TObject);
    procedure FormStorageRestorePlacement(Sender: TObject);
    procedure btnOptionsClick(Sender: TObject);
    procedure Sort1Click(Sender: TObject);
  private
    { Private declarations }
    FDisplayHistory : Boolean;
    FDisplayPackagePath: Boolean;
    FDisplayProject : Boolean;
    FSyncPackages : Boolean;
		OldList : TStringList;
    PackagePath : TStringList;
    procedure SaveList;
    procedure RestoreList;
    function ListSaved : Boolean;
    procedure ParsePath;
  	procedure WritePath;
  	procedure ReadPath;
    procedure SyncWithPackages;
  protected
    procedure SetDisplayPackagePath(Value : Boolean);
    procedure SetSyncPackages(Value : Boolean);
  public
    { Public declarations }
    property DisplayPackagePath: Boolean read FDisplayPackagePath write SetDisplayPackagePath;
    property SyncPackages : Boolean read FSyncPackages write SetSyncPackages;
  end;

	procedure Register;

var
  frmSetPath: TfrmSetPath;
	WindowHook : HHook;
  DoSubClass : Boolean;
	PathEdExpert : TPathEdExpert;
  Path : string;

implementation

uses
  SolutionsUnlimitedPathOptions;

resourcestring
  sName = 'Library Search Path Expert';
  sMenuText = 'Edit Library Search &Path...';
  sMenuName = 'EditLibrarySearchPathItem';

{$R *.DFM}

var
  NewWndProcPointer : TFarProc;
  OrgWndProcPointer : LongInt;
  WindowHandle : HWnd;

procedure TPathEdExpert.NewWndProc(var Msg : TMessage);
//function NewWndProc(Handle : HWND; Msg : UInt; wparam : WPARAM; lparam: LPARAM): LRESULT; stdcall;
var
	EnvDialog : TCustomForm;
  LibraryTab :  TTabSheet;

  PathCombo : TComboBox;
  temp : string;

begin
  case Msg.Msg of
    WM_WINDOWPOSCHANGING :
    begin
    	TWindowPos(pWindowPos(Msg.Lparam)^).cx := 0;
    	TWindowPos(pWindowPos(Msg.Lparam)^).cy := 0;
      Msg.Result := 0;
    end;

		CM_ACTIVATE:
  		if Application.FindComponent('EnvDialog') <> nil then
    	begin
	    	EnvDialog := TForm(Application.FindComponent('EnvDialog'));
      	EnvDialog.ModalResult := mrOK;
 	      PathCombo := TComboBox(EnvDialog.FindComponent('LibOptionsDlg2').FindComponent('ecLibraryPath'));
        PathCombo.Text := Path;
      	PostMessage(EnvDialog.Handle, CM_DEACTIVATE, 0, 0);
        Msg.Result := 0;
    	end;
		CM_DEACTIVATE:
  		if Application.FindComponent('EnvDialog') <> nil then
    	begin
      	EnvDialog := TForm(Application.FindComponent('EnvDialog'));
      	EnvDialog.ModalResult := mrOK;
        Msg.Result := 0;
    	end;          

//  else Result := CallWindowProc(Pointer(OrgWndProcPointer), Handle, Msg, wparam, lparam);
  else Dispatch(Msg);
  end;
end;

{------------------------------------------------------------------------------}

function Hook(Code : Integer; wparam :WPARAM; lParam : LPARAM): LResult; stdcall;
var
	aClassName : array [0..25] of char;
  i: integer;

begin
	with TCWPStruct(PCWPStruct(lparam)^) do
	  if (Message = WM_ParentNotify) and (LoWord(wparam) = WM_CREATE) then
		begin
 			WindowHandle := GetParent(lParam);
      GetClassName(WindowHandle, aClassName, 25);

      if (aClassName = 'TEnvDialog') and (DoSubClass) then
      begin
        FlashWindow(Application.MainForm.Handle, False);
        // PathEdExpert.Subclasser.SubClassHandle := WindowHandle;
        NewWndProcPointer := MakeObjectInstance(PathEdExpert.NewWndProc);
	  	  OrgWndProcPointer := LongInt(SetWindowLong(WindowHandle, gwl_WndProc, LongInt(NewWndProcPointer)));
      end;
  	end;

	Result := CallNextHookEx(WindowHook, Code, WParam, Lparam);
end;

{ TPathEdExpert ---------------------------------------------------------------}

constructor TPathEdExpert.Create;
var
	Index : integer;

begin
  inherited Create;

  with ToolServices.GetMainMenu.FindMenuItem('InstallPackagesItem') do
  begin
	  Index := GetIndex + 1;
		fMenuItem := GetParent.InsertItem(Index,sMenuText,sMenuName,'',0,0,0,[mfEnabled,mfVisible],MenuClick);
  end;

//  SubClasser := TSubClasser.Create(nil);
//  SubClasser.OnPreProcessMsg := PreProcessMsg;
//  SubClasser.OnPostProcessMsg := PostProcessMsg;

  WindowHook := SetWindowsHookEx(WH_CALLWNDPROC, @Hook, HInstance, GetCurrentThreadID);
end;

{------------------------------------------------------------------------------}

destructor TPathEdExpert.Destroy;
begin
  MenuItem.Free;

//  SubClasser.Free;
  SetWindowLong(WindowHandle, gwl_WndProc, OrgWndProcPointer);

	UnHookWindowsHookEx(WindowHook);
  inherited Destroy;
end;

{------------------------------------------------------------------------------}

procedure TPathEdExpert.MenuClick(Sender:
   TIMenuItemIntf);
begin
  Execute;
end;

{------------------------------------------------------------------------------}

function TPathEdExpert.GetStyle: TExpertStyle;
begin
  Result := esAddIn;
end;

{------------------------------------------------------------------------------}

function TPathEdExpert.GetName: string;
begin
  Result := sName;
end;

{------------------------------------------------------------------------------}

function TPathEdExpert.GetIDString: string;
begin
  Result := 'Solutions Unlimited.PathEditor';
end;

{------------------------------------------------------------------------------}

procedure TPathEdExpert.Execute;
begin
	with TfrmSetPath.Create(nil) do
  try
		ShowModal;
  finally
    Free;
  end;

  UpdateDelphiPath;
end;

{------------------------------------------------------------------------------}

procedure TPathEdExpert.PreProcessMsg(Sender: TObject;
  var msg: TMessage; var bContinue: Boolean);
begin
 	case msg.msg of
    WM_WINDOWPOSCHANGING :
    begin
    	TWindowPos(pWindowPos(Msg.Lparam)^).cx := 0;
    	TWindowPos(pWindowPos(Msg.Lparam)^).cy := 0;
    end;
  end;
end;

{------------------------------------------------------------------------------}

procedure TPathEdExpert.PostProcessMsg(Sender: TObject;
  var msg: TMessage; var bContinue: Boolean);
var
	EnvDialog : TCustomForm;
  LibraryTab :  TTabSheet;

  PathCombo : TComboBox;
  temp : string;

begin
  // Hard coding the Component Names for this release. Will create a wrapper Class
  // for Delphi in the next release.
	case Msg.Msg of
		CM_ACTIVATE:
  		if Application.FindComponent('EnvDialog') <> nil then
    	begin
	    	EnvDialog := TForm(Application.FindComponent('EnvDialog'));
      	EnvDialog.ModalResult := mrOK;
	      PathCombo := TComboBox(EnvDialog.FindComponent('LibOptionsDlg2').FindComponent('ecLibraryPath'));
        PathCombo.Text := Path;
      	PostMessage(EnvDialog.Handle, CM_DEACTIVATE, 0, 0);
    	end;
		CM_DEACTIVATE:
  		if Application.FindComponent('EnvDialog') <> nil then
    	begin
      	EnvDialog := TForm(Application.FindComponent('EnvDialog'));
      	EnvDialog.ModalResult := mrOK;
    	end;
	end;
end;

procedure TPathEdExpert.UpdateDelphiPath;
var
	ABuilder : TForm;
  EnvDialogItem : TMenuItem;

begin
	DoSubClass := True;
  if Assigned(Application.FindComponent('AppBuilder')) then
  begin
	  ABuilder := TForm(Application.FindComponent('AppBuilder'));
    if Assigned(ABuilder.FindComponent('ToolsOptionsItem')) then
    begin
		  EnvDialogItem := TMenuItem(ABuilder.FindComponent('ToolsOptionsItem'));
			EnvDialogItem.Click;
	    DoSubClass := False;
	  end;
	end;
end;

// These methods are not important for an AddIn expert;
{------------------------------------------------------------------------------}

function TPathEdExpert.GetAuthor: string;
begin
	Result := ''
end;

{------------------------------------------------------------------------------}

function TPathEdExpert.GetComment: string;
begin
	Result := ''
end;

{------------------------------------------------------------------------------}

function TPathEdExpert.GetGlyph: HICON;
begin
	Result := 0
end;

{------------------------------------------------------------------------------}

function TPathEdExpert.GetMenuText: string;
begin
	Result := '';
end;

{------------------------------------------------------------------------------}

function TPathEdExpert.GetPage: string;
begin
	Result := ''
end;

{------------------------------------------------------------------------------}

function TPathEdExpert.GetState: TExpertState;
begin
	Result := []
end;

{ TfrmSetPath -----------------------------------------------------------------}

procedure TfrmSetPath.SaveList;
var
 i : Integer;

begin
	OldList.Clear;
	for i := 0 to lstPath.Items.Count-1 do
  	OldList.AddObject(lstPath.Items[i],Pointer(Ord(lstPath.ItemState[i])));
end;

{------------------------------------------------------------------------------}

procedure TfrmSetPath.RestoreList;
var
 i : Integer;

begin
	lstPath.Clear;
	for i := 0 to OldList.Count-1 do
  begin
  	lstPath.Items.Add(OldList[i]);
    lstPath.ItemState[i] := TCheckBoxState(OldList.Objects[i]);
  end;
end;

{------------------------------------------------------------------------------}

function TfrmSetPath.ListSaved : Boolean;
begin
	Result := OldList.Count > 0;
end;

{------------------------------------------------------------------------------}

procedure TfrmSetPath.ParsePath;
var
	s, x : string;

begin
	s := '';
  x := '';

  with TRegistry.Create do
  try
  	RootKey := HKEY_CURRENT_USER;
    OpenKey(DELPHI_3_PATH, False);
		s := ReadString(DELPHI_3_PATH_KEY);

    while s <> '' do
    begin
      lstPath.Items.Add(strToken(s,';'));
      lstPath.ItemState[lstPath.Items.Count-1] := cbChecked
    end;
  finally
  	Free;
  end;
end;

{------------------------------------------------------------------------------}

procedure TfrmSetPath.WritePath;
var
  i : Integer;
  b : string;

begin
	Path := '';

	for i := 0 to lstPath.Items.Count-1 do
		if lstPath.ItemState[i] = cbChecked then Path := Path + lstPath.Items[i] + ';';

	Path := Copy(Path,1,Length(Path)-1);

  with TRegistry.Create do
  try
  	RootKey := HKEY_CURRENT_USER;
    if not OpenKey(DELPHI_3_PATH,False) then Exit;
    if not ValueExists(DELPHI_3_PATH_KEY) then Exit;

   	WriteString(DELPHI_3_PATH_KEY, Path);

    // Clear out the values. Then Add them in.
   	DeleteKey(DELPHI_3_FULLPATH);
   	OpenKey(DELPHI_3_FULLPATH, True);
		for i := 0 to lstPath.Items.Count-1 do
    begin
    	if lstPath.ItemState[i] = cbChecked
      then b := 'T'
      else b := 'F';

    	WriteString(IntToStr(i),lstPath.Items[i]+','+b);
    end;
  finally
  	Free;
  end;
end;

{------------------------------------------------------------------------------}

procedure TfrmSetPath.ReadPath;
var
	s : string;
  b: Boolean;
	i : Integer;
  KeyInfo : TRegKeyInfo;

begin
	lstPath.Clear;

  with TRegistry.Create do
  try
  	RootKey := HKEY_CURRENT_USER;
    if not OpenKey(DELPHI_3_FULLPATH,False) then
    begin
    	ParsePath;
    	Exit;
		end;

		GetKeyInfo(KeyInfo);

		for i := 0 to KeyInfo.NumValues-1 do
    begin
    	s := ReadString(IntToStr(i));
    	b := (Copy(s,Pos(',',s)+1,1) = 'T');
    	s := Copy(s,1,Pos(',',s)-1);
    	lstPath.Items.Add(s);
			if b then lstPath.ItemState[i] := cbChecked;
    end;
  finally
  	Free;
  end;
end;

{------------------------------------------------------------------------------}

procedure TfrmSetPath.SyncWithPackages;
var
  i : Integer;
	s : string;

begin
 	SaveList;

  PackagePath.Clear;
	with TRegistry.Create do
  try

  	RootKey := HKEY_CURRENT_USER;
    if not OpenKey(DELPHI_3_KNOWN_PACKAGES,False) then Exit;

    GetValueNames(PackagePath);

    if DisplayPackagePath then
  		for i := 0 to PackagePath.Count-1 do
        with PackagePath do
        begin
        	s := ExtractFilePath(PackagePath[i]);
          s := Copy(s,1,Length(s)-1);
    		  if lstPath.Items.IndexOf(s) = -1 then
          begin
        	  Add(s);
            lstPath.Items.Add(s);
					  lstPath.ItemState[lstPath.Items.Count-1] := cbChecked;
          end;
        end;
  finally
  	Free;
  end;
end;

{------------------------------------------------------------------------------}

procedure TfrmSetPath.SetDisplayPackagePath(Value : Boolean);
begin
  if FDisplayPackagePath <> Value then
  begin
    FDisplayPackagePath := Value;
  end;
end;

{------------------------------------------------------------------------------}

procedure TfrmSetPath.SetSyncPackages(Value : Boolean);
begin
  if FSyncPackages <> Value then
  begin
    FSyncPackages := Value;

    if FSyncPackages
    then SyncWithPackages
    else
      if ListSaved then RestoreList;
  end;
end;

{------------------------------------------------------------------------------}

procedure TfrmSetPath.btnAddClick(Sender: TObject);
var
	s : string;

begin
	if dlgGetDir.Execute then
		with lstPath do
  	begin
    	s := dlgGetDir.Directory;
    	if Items.IndexOf(s) = -1 then Items.Insert(0,s);
      ItemState[Items.IndexOf(s)] := cbChecked;
      ItemIndex := Items.IndexOf(s);
      SetFocus;
  	end;

  StatusBar1.SimpleText := 'Path has been updated.';
end;

{------------------------------------------------------------------------------}

procedure TfrmSetPath.btnRemoveClick(Sender: TObject);
begin
	with lstPath do
  begin
		if ItemIndex > -1 then Items.Delete(ItemIndex);

  	ItemIndex := Items.Count-1;
  end;

  StatusBar1.SimpleText := 'Path has been updated.';
end;

{------------------------------------------------------------------------------}

procedure TfrmSetPath.btnUpClick(Sender: TObject);
var
	s : string;

begin
	with lstPath do
		if ItemIndex > 0 then
    begin
    	s := Items[ItemIndex];
    	Items.Exchange(ItemIndex, ItemIndex-1);
      ItemIndex := Items.IndexOf(s);
      SetFocus;
    end;
end;

{------------------------------------------------------------------------------}

procedure TfrmSetPath.btnDownClick(Sender: TObject);
var
	s : string;

begin
	with lstPath do
		if ItemIndex < Items.Count-1 then
    begin
    	s := Items[ItemIndex];
    	Items.Exchange(ItemIndex, ItemIndex+1);
      ItemIndex := Items.IndexOf(s);
      SetFocus;
    end;
end;

{------------------------------------------------------------------------------}

procedure TfrmSetPath.FormClose(Sender: TObject; var Action: TCloseAction);
begin
	WritePath;
	OldList.Free;
  PackagePath.Free;
end;

{------------------------------------------------------------------------------}

procedure TfrmSetPath.FormCreate(Sender: TObject);
begin
	OldList := TStringList.Create;
  OldList.Clear;
	ReadPath;

  PackagePath := TStringList.Create;
end;

{------------------------------------------------------------------------------}

procedure TfrmSetPath.FormStorageRestorePlacement(Sender: TObject);
begin
  with TRegistry.Create do
  try
  	RootKey := HKEY_CURRENT_USER;
    if not OpenKey(FormStorage.IniFileName+'\'+FormStorage.IniSection,False) then
    begin
    	Exit;
		end;

    if ValueExists('cbxDisplayPackages_Checked') then
      FDisplayPackagePath := (ReadString('cbxDisplayPackages_Checked') = 'True');

    if ValueExists('cbxSync_Checked') then
  		SyncPackages := (ReadString('cbxSync_Checked') = 'True');
  finally
    Free;
  end;
end;

{------------------------------------------------------------------------------}

procedure Register;
begin
	PathEdExpert := TPathEdExpert.Create;
  RegisterLibraryExpert(PathEdExpert);
end;

{------------------------------------------------------------------------------}

procedure TfrmSetPath.btnOptionsClick(Sender: TObject);
begin
  with TfrmPathOptions.Create(nil) do
  try                          
    if ShowModal = mrOK then
    begin
      DisplayPackagePath  := cbxDisplayPackages.Checked;
      SyncPackages        := cbxSync.Checked;
    end;
  finally
    Free;
  end;
end;

{------------------------------------------------------------------------------}

procedure TfrmSetPath.Sort1Click(Sender: TObject);
begin
  lstPath.Sorted := True;
end;

end.

