HideForm
unit HideForm;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, Menus;
type
THideFormEvent = procedure of object;
THideForm = class(TComponent)
private
iinterval : Integer;
visibleHeight : Integer;
visibleWidth : Integer;
visibleLeft : Integer;
visibleTop : Integer;
visibleBorderStyle : TFormBorderStyle;
hiddenHeight : Integer;
hiddenWidth : Integer;
hiddenLeft : Integer;
hiddenTop : Integer;
ccolor : TColor;
cloakIndex : Integer;
sstep : Integer;
isAnimated : Boolean;
resizeFirst : Boolean;
formMenu : TMainMenu;
FOnHide: THideFormEvent;
FOnShow: THideFormEvent;
procedure calculateHiddenPosition;
procedure saveVisibleData;
function inPlace : Boolean;
function inPosition : Boolean;
function inSize : Boolean;
procedure resize;
procedure move;
procedure Translate;
procedure fixPosition;
procedure Cloak;
procedure controlBorder;
procedure menuVisible;
procedure toPosition;
procedure toSize;
procedure resizeBeforeMoving;
procedure moveAndResize;
procedure SetOnHide(const Value: THideFormEvent);
procedure SetOnShow(const Value: THideFormEvent);
{ Private declarations }
protected
{ Protected declarations }
public
{ Public declarations }
isHidden : Boolean;
published
property interval : Integer read iinterval write iinterval;
property step : Integer read sstep write sstep;
property height : Integer read hiddenHeight write hiddenHeight;
property width : Integer read hiddenWidth write hiddenWidth;
property Animated : Boolean read isAnimated write isAnimated;
property resizeThenMove : Boolean read resizeFirst write resizeFirst;
property color : TColor read ccolor write ccolor;
property OnHide : THideFormEvent read FOnHide write SetOnHide;
property OnShow : THideFormEvent read FOnShow write SetOnShow;
procedure Hide;
procedure Show;
{ Published declarations }
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('MSA', [THideForm]);
end;
procedure THideForm.calculateHiddenPosition;
begin
with Screen do
begin
HiddenLeft := Width - HiddenWidth;
HiddenTop := (Height - HiddenHeight) div 2;
end;
end;
procedure THideForm.saveVisibleData;
begin
with (Owner as TForm) do
begin
VisibleLeft := Left;
VisibleTop := Top;
VisibleWidth := Width;
VisibleHeight := Height;
end;
end;
function THideForm.inPosition : Boolean;
var toTop, toLeft : Integer;
begin
if isHidden then
begin
toTop := visibleTop;
toLeft := visibleLeft;
end
else
begin
toTop := hiddenTop;
toLeft := hiddenLeft;
end;
inPosition := False;
with (Owner as TForm) do
begin
if (Abs(Top - toTop) > (sstep + 1)) then exit;
if (Abs(Left - toLeft) > (sstep + 1)) then exit;
end;
inPosition := True;
end;
function THideForm.inSize : Boolean;
var toHeight, toWidth : Integer;
begin
if isHidden then
begin
toHeight := visibleHeight;
toWidth := visibleWidth;
end
else
begin
toHeight := hiddenHeight;
toWidth := hiddenWidth;
end;
inSize := False;
with (Owner as TForm) do
begin
if (Abs(Height - toHeight) > (sstep + 1)) then exit;
if (Abs(width - toWidth) > (sstep + 1)) then exit;
end;
inSize := True;
end;
function THideForm.inPlace : Boolean;
begin
if inSize and inPosition then inPlace := True else inPlace := False;
end;
procedure THideForm.resize;
var toHeight, toWidth : Integer;
begin
if isHidden then
begin
toHeight := visibleHeight;
toWidth := visibleWidth;
end
else
begin
toHeight := hiddenHeight;
toWidth := hiddenWidth;
end;
with (Owner as TForm) do
begin
if (Abs(Height - toHeight) > (sstep + 1)) then
if (height > toHeight) then height := height - sstep
else height := height + sstep;
if (Abs(width - toWidth) > (sstep + 1)) then
if (width > toWidth) then width := width - sstep
else width := width + sstep;
end;
end;
procedure THideForm.move;
var toTop, toLeft : Integer;
begin
if isHidden then
begin
toTop := visibleTop;
toLeft := visibleLeft;
end
else
begin
toTop := hiddenTop;
toLeft := hiddenLeft;
end;
with (Owner as TForm) do
begin
if (Abs(Top - toTop) > (sstep + 1)) then
if (top > toTop) then top := top - sstep
else top := top + sstep;
if (Abs(Left - toLeft) > (sstep + 1)) then
if (left > toLeft) then left := left - sstep
else left := left + sstep;
end;
end;
procedure THideForm.toSize;
var
moment : TTimeStamp;
begin
moment := DateTimeToTimeStamp(Now);
repeat
if (DateTimeToTimeStamp(Now).Time >= (moment.Time + iinterval))
then
begin
resize;
moment := DateTimeToTimeStamp(Now);
end;
until inSize;
end;
procedure THideForm.toPosition;
var
moment : TTimeStamp;
begin
moment := DateTimeToTimeStamp(Now);
repeat
if (DateTimeToTimeStamp(Now).Time >= (moment.Time + iinterval))
then
begin
move;
moment := DateTimeToTimeStamp(Now);
end;
until inPosition;
end;
procedure THideForm.resizeBeforeMoving;
begin
if isHidden then
begin
toPosition;
toSize;
end
else
begin
toSize;
toPosition;
end;
end;
procedure THideForm.moveAndResize;
var
moment : TTimeStamp;
begin
moment := DateTimeToTimeStamp(Now);
repeat
if (DateTimeToTimeStamp(Now).Time >= (moment.Time + iinterval))
then
begin
move;
resize;
moment := DateTimeToTimeStamp(Now);
end;
until inPlace;
end;
procedure THideForm.Translate;
begin
if resizeFirst then resizeBeforeMoving
else moveAndResize;
end;
procedure THideForm.fixPosition;
var toHeight, toWidth, toTop, toLeft : Integer;
begin
if isHidden then
begin
toHeight := visibleHeight;
toWidth := visibleWidth;
toTop := visibleTop;
toLeft := visibleLeft;
end
else
begin
toHeight := hiddenHeight;
toWidth := hiddenWidth;
toTop := hiddenTop;
toLeft := hiddenLeft;
end;
with (Owner as TForm) do
begin
Top := toTop;
Left := toLeft;
Width := toWidth;
Height := toHeight;
end;
end;
procedure THideForm.Cloak;
var cloak : TPanel;
begin
menuVisible;
if ishidden then Owner.Components[cloakIndex].Free
else
begin
cloak := TPanel.Create (Owner);
cloak.Parent := (Owner as TWinControl);
cloak.color := ccolor;
cloak.Align := alClient;
cloak.Hint := (Owner as TForm).Caption;
cloak.ShowHint := True;
cloakIndex := cloak.ComponentIndex;
end;
end;
procedure THideForm.menuVisible;
begin
with (Owner as TForm) do
if isHidden then Menu := formMenu
else
begin
formMenu := Menu;
Menu := nil;
end;
end;
procedure THideForm.controlBorder;
begin
if isHidden then (Owner as TForm).BorderStyle := visibleBorderStyle
else (Owner as TForm).BorderStyle := bsNone;
end;
procedure THideForm.Hide;
begin
if not ((Owner is TForm) and (not isHidden)) then exit;
visibleBorderStyle := (Owner as TForm).BorderStyle;
calculateHiddenPosition;
saveVisibleData;
if not isAnimated then (Owner as TForm).Visible := False;
controlBorder;
Cloak;
if isAnimated then Translate;
fixPosition;
if not isAnimated then (Owner as TForm).Visible := True;
isHidden := True;
if Assigned(OnHide) then OnHide;
end;
procedure THideForm.Show;
begin
if not ((Owner is TForm) and isHidden) then exit;
if isAnimated then Translate;
if not isAnimated then (Owner as TForm).Visible := False;
fixPosition;
controlBorder;
Cloak;
if not isAnimated then (Owner as TForm).Visible := True;
isHidden := False;
if Assigned(OnShow) then OnShow;
end;
procedure THideForm.SetOnHide(const Value: THideFormEvent);
begin
FOnHide := Value;
end;
procedure THideForm.SetOnShow(const Value: THideFormEvent);
begin
FOnShow := Value;
end;
end.
Delphi - .....................................
TEtwNavigatorKeys
unit Navkeys; { TEtwNavigatorKeys component. }
interface
uses
Windows,
SysUtils,
Messages,
Classes,
Graphics,
Controls,
Forms,
Dialogs,
Menus,
DBCtrls,
DBTables,
DB,
IniFiles,
DsgnIntf,
Clipbrd;
type
TEtwDefaultEditor = class(TDefaultEditor)
private
FEventToEdit: String;
FEventEditor: TPropertyEditor;
protected
procedure CheckPropertyEditor(PropertyEditor: TPropertyEditor); dynamic;
public
procedure Edit; override;
property EventToEdit: String read FEventToEdit write FEventToEdit;
end;
TEtwShiftState = (Shift, Alt, Ctrl, Left, Right, Middle, Double);
TUseKeys = (
keyLBUTTON,keyRBUTTON,keyCANCEL,keyMBUTTON,keyBACK,keyTAB,
keyCLEAR,keyRETURN,keySHIFT,keyCONTROL,keyMENU,keyPAUSE,keyCAPITAL,
keyESCAPE,keySPACE,keyPRIOR,keyNEXT,keyEND,keyHOME,keyLEFT,keyUP,keyRIGHT,
keyDOWN,keySELECT,keyEXECUTE,keySNAPSHOT,keyINSERT,keyDELETE,keyHELP,
key1,key2,key3,key4,key5,key6,key7,key8,key9,keyA,keyB,keyC,keyD,
keyE,keyF,keyG,keyH,keyI,keyJ,keyK,keyL,keyM,keyN,keyO,keyP,keyQ,keyR,
keyS,keyT,keyU,keyV,keyW,keyX,keyY,keyZ,keyNUMPAD0,keyNUMPAD1,keyNUMPAD2,
keyNUMPAD3,keyNUMPAD4,keyNUMPAD5,keyNUMPAD6,keyNUMPAD7,keyNUMPAD8,keyNUMPAD9,
keyMULTIPLY,keyADD,keySEPARATOR,keySUBTRACT,keyDECIMAL,keyDIVIDE,keyF1,keyF2,
keyF3,keyF4,keyF5,keyF6,keyF7,keyF8,keyF9,keyF10,keyF11,keyF12,keyF13,keyF14,
keyF15,keyF16,keyF17,keyF18,keyF19,keyF20,keyF21,keyF22,keyF23, keyF24,
keyNUMLOCK,keySCROLL
);
TEtwKeys = class(TPersistent)
private
FFirst, FPrior, FNext, FLast, FInsert, FDelete,FEdit,FPost,FCancel,FRefresh : TUseKeys;
FOwner : TComponent;
procedure SetFirst (Value : TUseKeys);
procedure SetPrior (Value : TUseKeys);
procedure SetNext (Value : TUseKeys);
procedure SetLast (Value : TUseKeys);
procedure SetInsert (Value : TUseKeys);
procedure SetDelete (Value : TUseKeys);
procedure SetEdit (Value : TUseKeys);
procedure SetPost (Value : TUseKeys);
procedure SetCancel (Value : TUseKeys);
procedure SetRefresh (Value : TUseKeys);
procedure SetKey ( EtwKey : TUseKeys; var RealKey : word);
public
constructor CreateFor (MyComponent : TComponent);
published
property First : TUseKeys read FFirst write SetFirst;
property Prior : TUseKeys read FPrior write SetPrior;
property Next : TUseKeys read FNext write SetNext;
property Last : TUseKeys read FLast write SetLast;
property Insert : TUseKeys read FInsert write SetInsert;
property Delete : TUseKeys read FDelete write SetDelete;
property Edit : TUseKeys read FEdit write SetEdit;
property Post : TUseKeys read FPost write SetPost;
property Cancel : TUseKeys read FCancel write SetCancel;
property Refresh : TUseKeys read FRefresh write SetRefresh;
end;
TEtwNavigatorKeys = class(TComponent)
private
{ Private declarations }
FUseFirst, FUsePrior, FUseNext, FUseLast, FUseInsert, FUseDelete,FUseEdit,FUsePost,FUseCancel,FUseRefresh : word;
FUseShiftState : TShiftstate;
FNavigator : TDBNavigator;
FEtwShiftState : TetwShiftState;
FKeys : TEtwKeys;
FClearClipboard: boolean;
procedure SetNavigator(newValue: TDBNavigator);
procedure SetEtwShiftState ( Value : TEtwShiftState);
function CheckButtonState (btn : TNavigateBtn; key : word) : boolean;
protected
{ Protected declarations }
procedure Notification (AComponent : TComponent; Operation :TOperation); override;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
{ Published properties and events }
procedure HandleKey (Key : word; Shift : TShiftState);
property Navigator : TDBNavigator read FNavigator write SetNavigator;
property ShiftState : TEtwShiftState read FEtwShiftState write SetEtwShiftState;
property Keys : TEtwKeys read FKeys write FKeys;
property ClearClipboard : boolean read FClearClipboard write FClearClipboard default false;
end; { TEtwNavigatorKeys }
TEtwNavigatorKeysEditor = class(TEtwDefaultEditor)
public
function GetVerbCount: integer; override;
function GetVerb(Index: integer): string; override;
procedure ExecuteVerb(Index: integer); override;
end; { TEtwDBScrollBoxEditor }
procedure Register;
implementation
uses
WinProcs, TypInfo;
procedure TEtwDefaultEditor.CheckPropertyEditor(PropertyEditor: TPropertyEditor);
{ Checks PropertyEditor to make sure it matches FEventToEdit. }
var
localFreeEditor: Boolean;
begin
localFreeEditor := True;
try
if not Assigned(FEventEditor) and (PropertyEditor is TMethodProperty) then begin
if CompareText(PropertyEditor.GetName, FEventToEdit) = 0 then begin
localFreeEditor := False; { Don't free since we're going to hold on to this and free later. }
FEventEditor := PropertyEditor;
end;
end;
finally
if localFreeEditor then PropertyEditor.Free;
end;
end; { CheckPropertyEditor }
procedure TEtwDefaultEditor.Edit;
var
Components: TComponentList;
begin
if FEventToEdit = '' then begin { no event to edit specified, so use inherited behavior. }
inherited Edit;
exit;
end;
Components := TComponentList.Create;
try
Components.Add(Component);
FEventEditor := nil;
try
GetComponentProperties(Components, tkAny, Designer, CheckPropertyEditor);
if Assigned(FEventEditor) then begin
FEventEditor.Edit;
end;
finally
FEventEditor.Free;
end; { try/finally }
finally
Components.Free;
end; { try/finally }
end; { Edit }
function TEtwNavigatorKeysEditor.GetVerbCount: integer;
begin
result := 3;
end; { GetVerbCount }
function TEtwNavigatorKeysEditor.GetVerb(Index: integer): string;
begin
case Index of
0: result := 'About';
1: result := 'Save TEtwNavigatorKeys';
2: result := 'Read TEtwNavigatorKeys';
end; { case }
end; { GetVerb }
procedure TEtwNavigatorKeysEditor.ExecuteVerb(Index: integer);
var
Ini : TIniFile;
DirectoryArr : array [0..255] of char;
Directory : string;
begin
case Index of
0: { About }
begin
messageDlg('TEtwNavigatorKeys 2.0a' + #13#10 +
'Developed by Eric ten Westenend' + #13#10 +
'Cypres Informatisering B.V.' + #13#10 +
'The Netherlands' + #13#10 +
'E-Mail : ewes@compuserve.com', mtInformation,[mbOk],0);
end;
1: { Save properties }
begin
if messageDlg('Save properties for TEtwNavigatorKeys ?',mtConfirmation,[mbYes,mbNo],0) = mrYes then begin
GetWindowsDirectory(DirectoryArr,256);
Directory := strPas(DirectoryArr);
Ini := TInifile.Create(Directory + 'NavigatorKeys.INI'); // Create/Open INI-file
try
ini.writeInteger('Properties','ShiftState',ord(TEtwNavigatorKeys(Component).ShiftState));
ini.writeInteger('Properties','First',ord(TEtwNavigatorKeys(Component).Keys.First));
ini.writeInteger('Properties','Prior',ord(TEtwNavigatorKeys(Component).Keys.Prior));
ini.writeInteger('Properties','Next',ord(TEtwNavigatorKeys(Component).Keys.Next));
ini.writeInteger('Properties','Last',ord(TEtwNavigatorKeys(Component).Keys.Last));
ini.writeInteger('Properties','Insert',ord(TEtwNavigatorKeys(Component).Keys.Insert));
ini.writeInteger('Properties','Delete',ord(TEtwNavigatorKeys(Component).Keys.Delete));
ini.writeInteger('Properties','Edit',ord(TEtwNavigatorKeys(Component).Keys.Edit));
ini.writeInteger('Properties','Post',ord(TEtwNavigatorKeys(Component).Keys.Post));
ini.writeInteger('Properties','Cancel',ord(TEtwNavigatorKeys(Component).Keys.Cancel));
ini.writeInteger('Properties','Refresh',ord(TEtwNavigatorKeys(Component).Keys.Refresh));
ini.writeBool('Properties','ClearClipboard',TEtwNavigatorKeys(Component).ClearClipBoard);
Finally
Ini.Free; // Release
end;
end;
end;
2 :
begin
if messageDlg('Read properties for TEtwNavigatorKeys ?',mtConfirmation,[mbYes,mbNo],0) = mrYes then begin
GetWindowsDirectory(DirectoryArr,256);
Directory := strPas(DirectoryArr);
Ini := TInifile.Create(Directory + 'NavigatorKeys.INI'); // Create/Open INI-file
try
TEtwNavigatorKeys(Component).FEtwShiftState := TEtwShiftState(ini.readInteger('Properties','ShiftState',0));
TEtwNavigatorKeys(Component).Keys.First := TUseKeys(ini.ReadInteger('Properties','First',18));
TEtwNavigatorKeys(Component).Keys.Prior := TUseKeys(ini.ReadInteger('Properties','Prior',15));
TEtwNavigatorKeys(Component).Keys.Next := TUseKeys(ini.ReadInteger('Properties','Next',16));
TEtwNavigatorKeys(Component).Keys.Last := TUseKeys(ini.ReadInteger('Properties','Last',17));
TEtwNavigatorKeys(Component).Keys.Insert := TUseKeys(ini.ReadInteger('Properties','Insert',26));
TEtwNavigatorKeys(Component).Keys.Delete := TUseKeys(ini.ReadInteger('Properties','Delete',27));
TEtwNavigatorKeys(Component).Keys.Edit := TUseKeys(ini.ReadInteger('Properties','Edit',80));
TEtwNavigatorKeys(Component).Keys.Post := TUseKeys(ini.ReadInteger('Properties','Post',7));
TEtwNavigatorKeys(Component).Keys.Cancel := TUseKeys(ini.ReadInteger('Properties','Cancel',13));
TEtwNavigatorKeys(Component).Keys.Refresh := TUseKeys(ini.ReadInteger('Properties','Refresh',91));
TEtwNavigatorKeys(Component).ClearClipboard := ini.ReadBool('Properties','ClearClipboard',false);
finally
Ini.Free;
end;
end;
end;
end; { case }
end; { ExecuteVerb }
constructor TEtwKeys.CreateFor (MyComponent : TComponent);
begin
inherited create;
FOwner := MyComponent;
end;
procedure TEtwKeys.SetKey ( EtwKey : TUseKeys; var RealKey : word);
begin
case EtwKey of
keyLBUTTON : RealKey := vk_LBUTTON ;
keyRBUTTON : RealKey := vk_RBUTTON ;
keyCANCEL : RealKey := vk_CANCEL ;
keyMBUTTON : RealKey := vk_MBUTTON ;
keyBACK : RealKey := vk_BACK ;
keyTAB : RealKey := vk_TAB ;
keyCLEAR : RealKey := vk_CLEAR ;
keyRETURN : RealKey := vk_RETURN ;
keySHIFT : RealKey := vk_SHIFT ;
keyCONTROL : RealKey := vk_CONTROL ;
keyMENU : RealKey := vk_MENU ;
keyPAUSE : RealKey := vk_PAUSE ;
keyCAPITAL : RealKey := vk_CAPITAL ;
keyESCAPE : RealKey := vk_ESCAPE ;
keySPACE : RealKey := vk_SPACE ;
keyPRIOR : RealKey := vk_PRIOR ;
keyNEXT : RealKey := vk_NEXT ;
keyEND : RealKey := vk_END ;
keyHOME : RealKey := vk_HOME ;
keyLEFT : RealKey := vk_LEFT ;
keyUP : RealKey := vk_UP ;
keyRIGHT : RealKey := vk_RIGHT ;
keyDOWN : RealKey := vk_DOWN ;
keySELECT : RealKey := vk_SELECT ;
keyEXECUTE : RealKey := vk_EXECUTE ;
keySNAPSHOT : RealKey := vk_SNAPSHOT ;
keyINSERT : RealKey := vk_INSERT ;
keyDELETE : RealKey := vk_DELETE ;
keyHELP : RealKey := vk_HELP ;
key1 : RealKey := ord('1') ;
key2 : RealKey := ord('2') ;
key3 : RealKey := ord('3') ;
key4 : RealKey := ord('4') ;
key5 : RealKey := ord('5') ;
key6 : RealKey := ord('6') ;
key7 : RealKey := ord('7') ;
key8 : RealKey := ord('8') ;
key9 : RealKey := ord('9') ;
keyA : RealKey := ord('A') ;
keyB : RealKey := ord('B') ;
keyC : RealKey := ord('C') ;
keyD : RealKey := ord('D') ;
keyE : RealKey := ord('E') ;
keyF : RealKey := ord('F') ;
keyG : RealKey := ord('G') ;
keyH : RealKey := ord('H') ;
keyI : RealKey := ord('I') ;
keyJ : RealKey := ord('J') ;
keyK : RealKey := ord('K') ;
keyL : RealKey := ord('L') ;
keyM : RealKey := ord('M') ;
keyN : RealKey := ord('N') ;
keyO : RealKey := ord('O') ;
keyP : RealKey := ord('P') ;
keyQ : RealKey := ord('Q') ;
keyR : RealKey := ord('R') ;
keyS : RealKey := ord('S') ;
keyT : RealKey := ord('T') ;
keyU : RealKey := ord('U') ;
keyV : RealKey := ord('V') ;
keyW : RealKey := ord('W') ;
keyX : RealKey := ord('X') ;
keyY : RealKey := ord('Y') ;
keyZ : RealKey := ord('Z') ;
keyNUMPAD0 : RealKey := vk_NUMPAD0 ;
keyNUMPAD1 : RealKey := vk_NUMPAD1 ;
keyNUMPAD2 : RealKey := vk_NUMPAD2 ;
keyNUMPAD3 : RealKey := vk_NUMPAD3 ;
keyNUMPAD4 : RealKey := vk_NUMPAD4 ;
keyNUMPAD5 : RealKey := vk_NUMPAD5 ;
keyNUMPAD6 : RealKey := vk_NUMPAD6 ;
keyNUMPAD7 : RealKey := vk_NUMPAD7 ;
keyNUMPAD8 : RealKey := vk_NUMPAD8 ;
keyNUMPAD9 : RealKey := vk_NUMPAD9 ;
keyMULTIPLY : RealKey := vk_MULTIPLY ;
keyADD : RealKey := vk_ADD ;
keySEPARATOR : RealKey := vk_SEPARATOR ;
keySUBTRACT : RealKey := vk_SUBTRACT ;
keyDECIMAL : RealKey := vk_DECIMAL ;
keyDIVIDE : RealKey := vk_DIVIDE ;
keyF1 : RealKey := vk_F1 ;
keyF2 : RealKey := vk_F2 ;
keyF3 : RealKey := vk_F3 ;
keyF4 : RealKey := vk_F4 ;
keyF5 : RealKey := vk_F5 ;
keyF6 : RealKey := vk_F6 ;
keyF7 : RealKey := vk_F7 ;
keyF8 : RealKey := vk_F8 ;
keyF9 : RealKey := vk_F9 ;
keyF10 : RealKey := vk_F10 ;
keyF11 : RealKey := vk_F11 ;
keyF12 : RealKey := vk_F12 ;
keyF13 : RealKey := vk_F13 ;
keyF14 : RealKey := vk_F14 ;
keyF15 : RealKey := vk_F15 ;
keyF16 : RealKey := vk_F16 ;
keyF17 : RealKey := vk_F17 ;
keyF18 : RealKey := vk_F18 ;
keyF19 : RealKey := vk_F19 ;
keyF20 : RealKey := vk_F20 ;
keyF21 : RealKey := vk_F21 ;
keyF22 : RealKey := vk_F22 ;
keyF23 : RealKey := vk_F23 ;
keyF24 : RealKey := vk_F24 ;
keyNUMLOCK : RealKey := vk_NUMLOCK ;
keySCROLL : RealKey := vk_SCROLL ;
end;
end;
procedure TEtwKeys.SetFirst (value : TUseKeys);
begin
if value <> FFirst then begin
if ( (value <> FPrior)
and (value <> FNext)
and (value <> FLast)
and (value <> FInsert)
and (value <> FDelete)
and (value <> FEdit)
and (value <> FPost)
and (value <> FCancel)
and (value <> FRefresh)
) then begin
FFirst := Value;
SetKey(FFirst, TEtwNavigatorKeys(FOwner).FUseFirst);
end else begin
raise exception.Create('Key already assigned to another key');
end;
end;
end;
procedure TEtwKeys.SetPrior (value : TUseKeys);
begin
if value <> FPrior then begin
if ( (value <> FFirst)
and (value <> FNext)
and (value <> FLast)
and (value <> FInsert)
and (value <> FDelete)
and (value <> FEdit)
and (value <> FPost)
and (value <> FCancel)
and (value <> FRefresh)
) then begin
FPrior := Value;
SetKey(FPrior, TEtwNavigatorKeys(FOwner).FUsePrior);
end else begin
raise exception.create('Key already assigned to another key');
end;
end;
end;
procedure TEtwKeys.SetNext (value : TUseKeys);
begin
if value <> FNext then begin
if ( (value <> FFirst)
and (value <> FPrior)
and (value <> FLast)
and (value <> FInsert)
and (value <> FDelete)
and (value <> FEdit)
and (value <> FPost)
and (value <> FCancel)
and (value <> FRefresh)
) then begin
FNext := Value;
SetKey(FNext, TEtwNavigatorKeys(FOwner).FUseNext);
end else begin
raise exception.create('Key already assigned to another key');
end;
end;
end;
procedure TEtwKeys.SetLast (value : TUseKeys);
begin
if value <> FLast then begin
if ( (value <> FFirst)
and (value <> FPrior)
and (value <> FNext)
and (value <> FInsert)
and (value <> FDelete)
and (value <> FEdit)
and (value <> FPost)
and (value <> FCancel)
and (value <> FRefresh)
) then begin
FLast := Value;
SetKey(FLast, TEtwNavigatorKeys(FOwner).FUseLast);
end else begin
raise exception.create('Key already assigned to another key');
end;
end;
end;
procedure TEtwKeys.SetInsert (value : TUseKeys);
begin
if value <> FInsert then begin
if ( (value <> FFirst)
and (value <> FPrior)
and (value <> FNext)
and (value <> FLast)
and (value <> FDelete)
and (value <> FEdit)
and (value <> FPost)
and (value <> FCancel)
and (value <> FRefresh)
) then begin
FInsert := Value;
SetKey(FInsert, TEtwNavigatorKeys(FOwner).FUseInsert);
end else begin
raise exception.create('Key already assigned to another key');
end;
end;
end;
procedure TEtwKeys.SetDelete (value : TUseKeys);
begin
if value <> FDelete then begin
if ( (value <> FFirst)
and (value <> FPrior)
and (value <> FNext)
and (value <> FLast)
and (value <> FInsert)
and (value <> FEdit)
and (value <> FPost)
and (value <> FCancel)
and (value <> FRefresh)
) then begin
FDelete := Value;
SetKey(FDelete, TEtwNavigatorKeys(FOwner).FUseDelete);
end else begin
raise exception.create('Key already assigned to another key');
end;
end;
end;
procedure TEtwKeys.SetEdit (value : TUseKeys);
begin
if value <> FEdit then begin
if ( (value <> FFirst)
and (value <> FPrior)
and (value <> FNext)
and (value <> FLast)
and (value <> FInsert)
and (value <> FDelete)
and (value <> FPost)
and (value <> FCancel)
and (value <> FRefresh)
) then begin
FEdit := Value;
SetKey(FEdit, TEtwNavigatorKeys(FOwner).FUseEdit);
end else begin
raise exception.create('Key already assigned to another key');
end;
end;
end;
procedure TEtwKeys.SetPost (value : TUseKeys);
begin
if value <> FPost then begin
if ( (value <> FFirst)
and (value <> FPrior)
and (value <> FNext)
and (value <> FLast)
and (value <> FInsert)
and (value <> FDelete)
and (value <> FEdit)
and (value <> FCancel)
and (value <> FRefresh)
) then begin
FPost := Value;
SetKey(FPost, TEtwNavigatorKeys(FOwner).FUsePost);
end else begin
raise exception.create('Key already assigned to another key');
end;
end;
end;
procedure TEtwKeys.SetCancel (value : TUseKeys);
begin
if value <> FCancel then begin
if ( (value <> FFirst)
and (value <> FPrior)
and (value <> FNext)
and (value <> FLast)
and (value <> FInsert)
and (value <> FDelete)
and (value <> FEdit)
and (value <> FPost)
and (value <> FRefresh)
) then begin
FCancel := Value;
SetKey(FCancel, TEtwNavigatorKeys(FOwner).FUseCancel);
end else begin
raise exception.create('Key already assigned to another key');
end;
end;
end;
procedure TEtwKeys.SetRefresh (value : TUseKeys);
begin
if value <> FRefresh then begin
if ( (value <> FFirst)
and (value <> FPrior)
and (value <> FNext)
and (value <> FLast)
and (value <> FInsert)
and (value <> FDelete)
and (value <> FEdit)
and (value <> FPost)
and (value <> FCancel)
) then begin
FRefresh := Value;
SetKey(FRefresh, TEtwNavigatorKeys(FOwner).FUseRefresh);
end else begin
raise exception.Create('Key already assigned to another key');
end;
end;
end;
function TEtwNavigatorKeys.CheckButtonState (btn : TNavigateBtn; key : word) : boolean;
var
ctrlcounter : Integer;
clipboard : TClipBoard;
begin
result := False;
for ctrlcounter := 0 to Navigator.ControlCount - 1
do
begin
if TNavButton(Navigator.Controls[ctrlcounter]).Index = btn
then
result := (Navigator.Controls[ctrlcounter].enabled) and
(Navigator.Controls[ctrlcounter].visible);
if result then begin
if ( ( (FUseShiftState = [ssShift])
and (Key = VK_Insert) )
or ( (FUseShiftState = [ssCtrl] )
and (Key = ord('V')) )
) then begin
if ClearClipboard then begin
try
clipboard := TClipBoard.Create;
clipboard.clear;
finally
Clipboard.Free;
end;
end;
end;
Navigator.BtnClick(btn);
break;
end;
end;
end;
procedure TEtwNavigatorKeys.Notification (AComponent : TComponent; Operation :TOperation);
begin
Inherited Notification(AComponent, Operation);
if Operation = opRemove then begin
if AComponent = FNavigator then begin
FNavigator := nil;
end;
end;
end;
procedure TEtwNavigatorKeys.HandleKey (Key : word; Shift : TShiftState);
begin
if Navigator = nil then begin
raise exception.create('No navigator attached !');
exit;
end;
if shift = FUseShiftState then begin
if Key = FUseFirst then begin
CheckButtonState (nbFirst, key);
end else begin
if Key = FUsePrior then begin
CheckButtonState (nbPrior, key);
end else begin
if Key = FUseNext then begin
CheckButtonState (nbNext, key);
end else begin
if Key = FUseLast then begin
CheckButtonState (nbLast, key);
end else begin
if Key = FUseInsert then begin
CheckButtonState (nbInsert, key);
end else begin
if Key = FUseDelete then begin
CheckButtonState (nbDelete, key);
end else begin
if Key = FUseEdit then begin
CheckButtonState (nbEdit, key);
end else begin
if Key = FUsePost then begin
CheckButtonState (nbPost, key);
end else begin
if Key = FUseCancel then begin
CheckButtonState (nbCancel, key);
end else begin
if Key = FUseRefresh then begin
CheckButtonState (nbRefresh, key);
end;
end;
end;
end;
end;
end;
end;
end;
end;
end;
end;
end;
procedure TEtwNavigatorKeys.SetEtwShiftState ( Value : TEtwShiftState);
begin
//TShiftState = set of (ssShift, ssAlt, ssCtrl, ssLeft, ssRight, ssMiddle, ssDouble);
if value <> FEtwShiftState then begin
FEtwShiftState := value;
if FEtwShiftstate = Shift then begin
FUseShiftstate := [ssShift];
end else begin
if FEtwShiftstate = Alt then begin
FUseShiftstate := [ssAlt];
end else begin
if FEtwShiftstate = Ctrl then begin
FUseShiftstate := [ssCtrl];
end else begin
if FEtwShiftstate = Left then begin
FUseShiftstate := [ssLeft];
end else begin
if FEtwShiftstate = Right then begin
FUseShiftstate := [ssRight];
end else begin
if FEtwShiftstate = Middle then begin
FUseShiftstate := [ssMiddle];
end else begin
if FEtwShiftstate = Double then begin
FUseShiftstate := [ssDouble];
end;
end;
end;
end;
end;
end;
end;
end;
end;
procedure TEtwNavigatorKeys.SetNavigator(newValue: TDBNavigator);
var
DirectoryArr : array [0..255] of char;
Directory : string;
Ini : TIniFile;
begin
if not (csDesigning in Componentstate) then begin
FNavigator := newValue;
exit; // Only in Design mode
end;
if FNavigator <> newValue then
begin
if FNavigator = nil then begin
GetWindowsDirectory(DirectoryArr,256);
Directory := strPas(DirectoryArr);
if FileExists(Directory + 'NavigatorKeys.INI') then begin
Ini := TInifile.Create(Directory + 'NavigatorKeys.INI'); // Create/Open INI-file
try
ShiftState := TEtwShiftState(ini.readInteger('Properties','ShiftState',0));
Keys.First := TUseKeys(ini.ReadInteger('Properties','First',18));
Keys.Prior := TUseKeys(ini.ReadInteger('Properties','Prior',15));
Keys.Next := TUseKeys(ini.ReadInteger('Properties','Next',16));
Keys.Last := TUseKeys(ini.ReadInteger('Properties','Last',17));
Keys.Insert := TUseKeys(ini.ReadInteger('Properties','Insert',26));
Keys.Delete := TUseKeys(ini.ReadInteger('Properties','Delete',27));
Keys.Edit := TUseKeys(ini.ReadInteger('Properties','Edit',80));
Keys.Post := TUseKeys(ini.ReadInteger('Properties','Post',7));
Keys.Cancel := TUseKeys(ini.ReadInteger('Properties','Cancel',13));
Keys.Refresh := TUseKeys(ini.ReadInteger('Properties','Refresh',91));
ClearClipBoard := ini.ReadBool('Properties','ClearClipboard',false);
finally
Ini.Free;
end;
end;
end;
FNavigator := newValue;
end; { if }
end; { SetNavigator }
destructor TEtwNavigatorKeys.Destroy;
begin
Fkeys.Free;
inherited Destroy;
end; { Destroy }
constructor TEtwNavigatorKeys.Create(AOwner: TComponent);
{ Creates an object of type TEtwNavigatorKeys, and initializes properties. }
begin
inherited Create(AOwner);
FNavigator := nil;
FEtwShiftState := Shift;
FUseshiftState := [ssShift];
FClearClipboard := false;
FUseFirst := VK_HOME;
FUsePrior := VK_NEXT;
FUseLast := VK_END;
FUseInsert := VK_INSERT;
FUseDelete := VK_DELETE;
FUseEdit := VK_F1;
FUsePost := VK_RETURN;
FUseCancel := VK_ESCAPE;
FUseRefresh := VK_F12;
FKeys := TEtwKeys.CreateFor(Self);
with FKeys do begin
First := keyHOME;
Prior := keyPRIOR;
Next := keyNEXT;
Last := keyEND;
Insert := keyINSERT;
Delete := keyDELETE;
Edit := keyF1;
Post := keyRETURN;
Cancel := keyESCAPE;
Refresh := keyF12;
end;
end; { Create }
procedure Register;
begin
RegisterComponents('Libertel', [TEtwNavigatorKeys]);
RegisterComponentEditor(TEtwNavigatorKeys, TEtwNavigatorKeysEditor);
end; { Register }
end.
Delphi - .....................................
TNSComboBox
unit TNSComboBox;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Registry;
type
TTNSComboBox = class(TComboBox)
private
{ Private declarations }
FTNSNames : TStringList;
FTNSFilename : string;
procedure GetTNSNamesFileName();
function GetTNSNamesFromFile() : TStringList;
protected
{ Protected declarations }
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure LoadFromTNSNames;
property TNSNames : TStringList read GetTNSNamesFromFile;
property TNSFilename : string read FTNSFilename write FTNSFilename;
published
{ Published declarations }
end;
procedure Register;
implementation
constructor TTNSComboBox.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
if not (csDesigning in componentstate) then begin
GetTNSNamesFileName;
LoadFromTNSNames();
end;
end;
destructor TTNSComboBox.Destroy;
begin
if FTNSNames <> nil then
FTNSNames.free;
inherited;
end;
procedure TTNSComboBox.GetTNSNamesFileName();
function TestOracleHome(Reg : TRegistry) : string;
var
strFilename : string;
begin
try
strFilename := '';
if Reg.OpenKeyReadOnly('SoftwareOracle') then
strFilename := Trim(Reg.ReadString('ORACLE_HOME'));
//if the str is not null then append the rest of the filename on
if strFilename <> '' then begin
strFilename := strFilename + 'networkadmintnsnames.ora';
//test if this file exists, if it doesn't then set the filename = ''
if FileExists(strFilename) = False then
strFilename := '';
end;
result := strFilename;
except
result := '';
end;
end;
var
Reg: TRegistry;
strFilename : string;
begin
//first look for TNSNames.ora in the registry location
Reg := TRegistry.Create;
strFilename := '';
try
Reg.RootKey := HKEY_LOCAL_MACHINE;
//try and locate TNS_ADMIN key
if Reg.OpenKeyReadOnly('SoftwareOracle') then
strFilename := Trim(Reg.ReadString('TNS_ADMIN'));
//if not then use ORACLE_HOME to get the home directory and
//look in /Network/Admin for tnsnames.ora
if strFilename = '' then begin
strFilename := TestOracleHome(Reg);
end
else begin
//if the filename listed in TNS_ADMIN doesn't exist
if FileExists(strFilename) = False then begin
strFilename := TestOracleHome(Reg);
end;
end;
finally
Reg.CloseKey;
Reg.Free;
end;
//if it wasn't found in the registry then try a couple of common places
if strFilename = '' then begin
//if it wasn't found in the registry then try C:orantnetworkadmin
if FileExists('C:orantnetworkadmintnsnames.ora') then begin
strFilename := 'C:orantnetworkadmintnsnames.ora';
end
//if it wasn't found in the registry then try C:orawin95networkadmin
else if FileExists('C:orawin95networkadmintnsnames.ora') then begin
strFilename := 'C:orawin95networkadmintnsnames.ora';
end
else
strFilename := '';
end;
//return the filename
FTNSFilename := strFilename;
end;
function TTNSComboBox.GetTNSNamesFromFile() : TStringList;
var
strLine : string;
begin
//if the TNSNames.ora file is empty then try and get it
if FTNSFilename = '' then begin
GetTNSNamesFileName();
//if the name is still empty after trying to get it then it isn't
//there so abort
if FTNSFilename = '' then
Abort;
end;
//check if the file actually exists
if FileExists(FTNSFilename) = False then
Abort;
//if the stringlist is nil then create a new one else clear the list
if FTNSNames = nil then
FTNSNames := TStringList.Create
else
FTNSNames.Clear;
try
AssignFile(Input, FTNSFilename);
Reset(Input);
//loop through tnsnames.ora file parsing out valid SIDs
while not SeekEof(Input) do begin
Readln(Input, strLine);
strLine := Trim(strLine);
//if the line is one we should store then store it
if Pos('.world =',strLine) > 0 then begin
strLine := Copy(strLine,0,Length(strLine)-2);
FTNSNames.Add(strLine);
end;
end;
CloseFile(Input);
if FTNSNames.Count <= 0 then
Abort;
FTNSNames.Sort;
result := FTNSNames;
except
//MessageDlg('There was a problem reading the TNSnames.ora file.', mtError,[mbOK],0);
FTNSNames.Free;
result := nil;
end;
end;
procedure TTNSComboBox.LoadFromTNSNames;
var
i : integer;
begin
if FTNSFilename <> '' then begin
GetTNSNamesFromFile;
if FTNSNames <> nil then begin
Self.Items.Clear;
for i := 0 to FTNSNames.Count - 1 do
Self.Items.Add(FTNSNames[i]);
end;
end;
end;
procedure Register;
begin
RegisterComponents('Melman', [TTNSComboBox]);
end;
end.
Delphi - .....................................
