david
fff1b2a4dc
git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.SDAC@3 6f543ec7-021b-7e4c-98c9-62eafc7fb9a8
459 lines
11 KiB
PHP
459 lines
11 KiB
PHP
|
|
procedure SetCursor(Value: integer);
|
|
procedure ShowDebugForm(DASQLMonitorClass: TDASQLMonitorClass;
|
|
Component: TComponent; SQL: string; Params: TDAParams; Caption: string);
|
|
function ShowConnectForm(ConnectDialog: TCustomConnectDialog): boolean;
|
|
procedure StartWait;
|
|
procedure StopWait;
|
|
function ApplicationTitle: string;
|
|
|
|
{$IFDEF MSWINDOWS}
|
|
function GetHelpFileName(const ProjectName: string): string;
|
|
{$ENDIF}
|
|
|
|
implementation
|
|
|
|
var
|
|
SQLDelay: longword = 30;
|
|
|
|
{$IFDEF WIN32}
|
|
var
|
|
TimerID: word = 0;
|
|
StartTime: longword = 0;
|
|
|
|
procedure FreeTimer(ForceKill: boolean = False);
|
|
begin
|
|
if (TimerID <> 0) and (ForceKill or (GetTickCount - StartTime > SQLDelay)) then begin
|
|
KillTimer(0, TimerID);
|
|
TimerID := 0;
|
|
StartTime := 0;
|
|
SetCursor(crDefault);
|
|
end;
|
|
end;
|
|
|
|
procedure TimerCallBack(hWnd: HWND; Message: Word; TimerID: word;
|
|
SysTime: longint); stdcall;
|
|
begin
|
|
FreeTimer;
|
|
end;
|
|
{$ELSE}
|
|
type
|
|
TCursorTimer = class (TTimer)
|
|
private
|
|
procedure TimerHandler(Sender: TObject);
|
|
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
end;
|
|
|
|
var
|
|
Timer: TTimer;
|
|
|
|
{ TCursorTimer }
|
|
|
|
constructor TCursorTimer.Create(AOwner: TComponent);
|
|
begin
|
|
inherited;
|
|
|
|
OnTimer := TimerHandler;
|
|
end;
|
|
|
|
procedure TCursorTimer.TimerHandler(Sender: TObject);
|
|
begin
|
|
Enabled := False;
|
|
SetCursor(crDefault);
|
|
end;
|
|
{$ENDIF}
|
|
|
|
const
|
|
{$IFDEF MSWINDOWS}
|
|
KeyPath = '\SOFTWARE\CoreLab\DBAccess\';
|
|
{$ENDIF}
|
|
SQLArrowCount: integer = 0;
|
|
|
|
procedure SetCursor(Value: integer);
|
|
begin
|
|
if ChangeCursor
|
|
{$IFDEF WIN32}and (GetCurrentThreadID = MainThreadID){$ENDIF}
|
|
then
|
|
case Value of
|
|
crDefault: begin
|
|
if SQLArrowCount > 0 then begin
|
|
if Screen.Cursor <> crSQLWait then
|
|
Dec(SQLArrowCount);
|
|
if SQLArrowCount > 0 then
|
|
Screen.Cursor := crSQLArrow
|
|
else
|
|
Screen.Cursor := crDefault;
|
|
end
|
|
else
|
|
Screen.Cursor := crDefault;
|
|
end;
|
|
crSQLWait: begin
|
|
{$IFDEF WIN32}
|
|
if TimerID = 0 then
|
|
TimerID := SetTimer(0, 0, SQLDelay, @TimerCallBack);
|
|
|
|
if Screen.Cursor <> crSQLWait then
|
|
Screen.Cursor := crSQLWait;
|
|
|
|
StartTime := GetTickCount;
|
|
{$ELSE}
|
|
if Timer = nil then begin
|
|
Timer := TCursorTimer.Create(nil);
|
|
Timer.Enabled := False;
|
|
end;
|
|
if not Timer.Enabled then begin
|
|
Timer.Interval := SQLDelay;
|
|
Timer.Enabled := True;
|
|
end;
|
|
{$IFNDEF K3}
|
|
// strange AV when freeing cursor on exit (perhaps beta problem)
|
|
if Screen.Cursor <> crSQLWait then
|
|
Screen.Cursor := crSQLWait;
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
end;
|
|
crSQLArrow: begin
|
|
Inc(SQLArrowCount);
|
|
Screen.Cursor:= crSQLArrow;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
type
|
|
TDebugForm = class (TForm)
|
|
public
|
|
constructor CreateNew(Owner: TComponent; Dummy: integer = 0); override;
|
|
|
|
procedure FormKeyPress(Sender: TObject; var Key: char);
|
|
procedure ButtonClick(Sender: TObject);
|
|
end;
|
|
|
|
{ TDebugForm }
|
|
|
|
constructor TDebugForm.CreateNew(Owner: TComponent; Dummy: integer = 0);
|
|
begin
|
|
inherited CreateNew(Owner);
|
|
|
|
KeyPreview := True;
|
|
OnKeyPress := FormKeyPress;
|
|
end;
|
|
|
|
procedure TDebugForm.FormKeyPress(Sender: TObject; var Key: char);
|
|
begin
|
|
if (Key = #13) or (Key = #27) then
|
|
Close;
|
|
end;
|
|
|
|
procedure TDebugForm.ButtonClick(Sender: TObject);
|
|
begin
|
|
Close;
|
|
end;
|
|
|
|
procedure ShowDebugForm(DASQLMonitorClass: TDASQLMonitorClass;
|
|
Component: TComponent; SQL: string; Params: TDAParams; Caption: string);
|
|
var
|
|
Form: TDebugForm;
|
|
Memo: TMemo;
|
|
St: string;
|
|
Panel: TPanel;
|
|
{$IFDEF MSWINDOWS}
|
|
Registry: TRegistry;
|
|
{$ENDIF}
|
|
begin
|
|
Form := TDebugForm.CreateNew(nil);
|
|
|
|
{$IFDEF MSWINDOWS}
|
|
Registry := TRegistry.Create;
|
|
{$ENDIF}
|
|
|
|
try
|
|
St := DASQLMonitorClass.GetCaption + ' Debug: ';
|
|
if Component.Owner <> nil then
|
|
St := St + Component.Owner.Name + '.';
|
|
St := St + Component.Name;
|
|
if Caption <> '' then
|
|
St := St + ' [' + Caption + ']';
|
|
|
|
Form.Caption := St;
|
|
|
|
Panel := TPanel.Create(Form);
|
|
with Panel do begin
|
|
Parent := Form;
|
|
Align := alTop;
|
|
Height := 24;
|
|
BevelInner := bvNone;
|
|
BevelOuter := bvNone;
|
|
end;
|
|
|
|
with TButton.Create(Form) do begin
|
|
Parent := Panel;
|
|
Caption := 'Close';
|
|
Font.Style := [fsBold];
|
|
Top := 1;
|
|
Left := 0;
|
|
Height := 22;
|
|
Width := 150;
|
|
OnClick := Form.ButtonClick;
|
|
end;
|
|
|
|
with TLabel.Create(Form) do begin
|
|
Parent := Panel;
|
|
Caption := 'Before execution';
|
|
Font.Style := [fsBold];
|
|
Font.Color := clNavy;
|
|
Top := 5;
|
|
Left := 175;
|
|
end;
|
|
|
|
with TPanel.Create(Form) do begin
|
|
Parent := Form;
|
|
Align := alLeft;
|
|
Width := 15;
|
|
BevelInner := bvLowered;
|
|
BevelOuter := bvNone;
|
|
end;
|
|
|
|
Memo := TMemo.Create(Form);
|
|
with Memo do begin
|
|
Parent := Form;
|
|
Align := alClient;
|
|
ReadOnly := True;
|
|
Color := clBtnFace;
|
|
Font.Name := 'Courier New';
|
|
{$IFDEF MSWINDOWS}
|
|
{$IFNDEF CLX}
|
|
Font.Charset := GetDefFontCharSet;
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
ScrollBars := ssBoth;
|
|
WordWrap := False;
|
|
end;
|
|
|
|
Form.ActiveControl := Memo;
|
|
|
|
Memo.Lines.Text := SQL + #13#10 + #13#10 + DASQLMonitorClass.GetParams(Params);
|
|
Memo.SelStart := 0;
|
|
|
|
{$IFDEF MSWINDOWS}
|
|
if Registry.OpenKey(KeyPath + 'Debug', False) then begin
|
|
if Registry.ValueExists('Left') then
|
|
Form.Left := Registry.ReadInteger('Left');
|
|
if Registry.ValueExists('Top') then
|
|
Form.Top := Registry.ReadInteger('Top');
|
|
if Registry.ValueExists('Width') then
|
|
Form.Width := Registry.ReadInteger('Width');
|
|
if Registry.ValueExists('Height') then
|
|
Form.Height := Registry.ReadInteger('Height');
|
|
|
|
Registry.CloseKey;
|
|
end
|
|
else
|
|
{$ENDIF}
|
|
begin
|
|
Form.Width := (Screen.Width) div 2;
|
|
Form.Left := (Screen.Width - Form.Width) div 2;
|
|
Form.Top := (Screen.Height - Form.Height) div 2;
|
|
end;
|
|
|
|
Form.ShowModal;
|
|
|
|
{$IFDEF MSWINDOWS}
|
|
if Registry.OpenKey(KeyPath + 'Debug', True) then begin
|
|
Registry.WriteInteger('Left', Form.Left);
|
|
Registry.WriteInteger('Top', Form.Top);
|
|
Registry.WriteInteger('Width', Form.Width);
|
|
Registry.WriteInteger('Height', Form.Height);
|
|
Registry.CloseKey;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
finally
|
|
{$IFDEF MSWINDOWS}
|
|
Registry.Free;
|
|
{$ENDIF}
|
|
Form.Free;
|
|
end;
|
|
end;
|
|
|
|
type
|
|
_TCustomConnectDialog = class(TCustomConnectDialog)
|
|
end;
|
|
|
|
function ShowConnectForm(ConnectDialog: TCustomConnectDialog): boolean;
|
|
var
|
|
FormClass: TFormClass;
|
|
ConnectForm: TForm;
|
|
PropInfo: PPropInfo;
|
|
begin
|
|
if (ConnectDialog.DialogClass = '')
|
|
or (csDesigning in ConnectDialog.ComponentState)
|
|
then
|
|
FormClass := TFormClass(_TCustomConnectDialog(ConnectDialog).DefDialogClass)
|
|
else
|
|
FormClass := TFormClass(FindClass(ConnectDialog.DialogClass));
|
|
|
|
ConnectForm := FormClass.Create(nil);
|
|
try
|
|
PropInfo := GetPropInfo(FormClass.ClassInfo, 'ConnectDialog');
|
|
if PropInfo <> nil then
|
|
SetObjectProp(ConnectForm, PropInfo, ConnectDialog);
|
|
|
|
Result := (ConnectForm.ShowModal = mrOk) and ConnectDialog.Connection.Connected;
|
|
finally
|
|
ConnectForm.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure StartWait;
|
|
begin
|
|
SetCursor(crSQLWait);
|
|
end;
|
|
|
|
procedure StopWait;
|
|
begin
|
|
SetCursor(crDefault);
|
|
end;
|
|
|
|
function ApplicationTitle: string;
|
|
begin
|
|
Result := Application.Title;
|
|
end;
|
|
|
|
{$IFDEF MSWINDOWS}
|
|
{$IFDEF VER7P}
|
|
{$IFDEF VER8P}
|
|
function GetHelpFileName(const ProjectName: string): string;
|
|
var
|
|
Path: string;
|
|
Ind: integer;
|
|
|
|
Registry: TRegistry;
|
|
sl: TStringList;
|
|
i: integer;
|
|
UCProjectName: string;
|
|
begin
|
|
Result := '';
|
|
Registry := nil;
|
|
sl := nil;
|
|
try
|
|
Registry := TRegistry.Create;
|
|
{$IFDEF VER9P}
|
|
Registry.RootKey := HKEY_LOCAL_MACHINE;
|
|
if Registry.OpenKey('Software\CoreLab\' + ProjectName, False) then begin
|
|
try
|
|
{$IFDEF VER9}
|
|
Path := Registry.ReadString('D9');
|
|
{$ELSE}
|
|
{$IFDEF VER10}
|
|
Path := Registry.ReadString('D10');
|
|
{$ELSE}
|
|
{$IFDEF VER11}
|
|
Path := Registry.ReadString('D11');
|
|
{$ELSE}
|
|
error
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
Result := IncludeTrailingPathDelimiter(Path) + 'Doc\' + ProjectName + '.hxs';
|
|
Exit;
|
|
except
|
|
// silent
|
|
Registry.CloseKey;
|
|
end;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
Registry.RootKey := HKEY_CURRENT_USER;
|
|
sl := TStringList.Create;
|
|
if not Registry.OpenKey('Software\Borland\BDS\' +
|
|
{$IFDEF VER8}'2.0'{$ENDIF}
|
|
{$IFDEF VER9}'3.0'{$ENDIF}
|
|
{$IFDEF VER10}'4.0'{$ENDIF}
|
|
{$IFDEF VER11}'5.0'{$ENDIF}
|
|
+ '\Known Assemblies', False) then begin
|
|
Result := ProjectName + '.hxs';
|
|
Exit;
|
|
end;
|
|
|
|
Registry.GetValueNames(sl);
|
|
UCProjectName := UpperCase('CoreLab.' + ProjectName + '.Design');
|
|
for i := 0 to sl.Count - 1 do
|
|
if (Registry.GetDataType(sl[i]) in [rdString, rdExpandString])
|
|
and (UpperCase(Registry.ReadString(sl[i])) = UCProjectName) then begin
|
|
Path := sl[i];
|
|
Break;
|
|
end;
|
|
|
|
if Path = '' then begin
|
|
Result := ProjectName + '.hxs';
|
|
Exit;
|
|
end;
|
|
|
|
finally
|
|
sl.Free;
|
|
Registry.Free;
|
|
end;
|
|
|
|
Ind := LastDelimiter('\', Path);
|
|
Path := Copy(Path, 1, Ind - 1);
|
|
Ind := LastDelimiter('\', Path);
|
|
Path := Copy(Path, 1, Ind);
|
|
Result := Path + 'Doc\' + ProjectName + '.hxs';
|
|
end;
|
|
{$ELSE}
|
|
function GetHelpFileName(const ProjectName: string): string;
|
|
begin
|
|
Result := ProjectName + '.hlp';
|
|
end;
|
|
{$ENDIF}
|
|
{$ELSE}
|
|
function GetHelpFileName(const ProjectName: string): string;
|
|
var
|
|
Path: string;
|
|
Ind: integer;
|
|
begin
|
|
Path := Application.ExeName;
|
|
Ind := LastDelimiter('\', Path);
|
|
Path := Copy(Path, 1, Ind - 1);
|
|
Ind := LastDelimiter('\', Path);
|
|
Path := Copy(Path, 1, Ind);
|
|
Result := Path + 'help\' + ProjectName + '.hlp';
|
|
end;
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
|
|
initialization
|
|
{$IFDEF WIN32}
|
|
{$IFNDEF CLX}
|
|
Screen.Cursors[crSQLArrow] := LoadCursor(HInstance, 'SQLARROW');
|
|
{$ENDIF}
|
|
{$ELSE}
|
|
Timer := nil;
|
|
{$ENDIF}
|
|
|
|
SetCursorProc := SetCursor;
|
|
ShowConnectFormProc := ShowConnectForm;
|
|
ShowDebugFormProc := ShowDebugForm;
|
|
StartWaitProc := StartWait;
|
|
StopWaitProc := StopWait;
|
|
ApplicationTitleProc := ApplicationTitle;
|
|
{$IFNDEF VER6P}
|
|
ApplicationHandleException := Application.HandleException;
|
|
{$ENDIF};
|
|
|
|
finalization
|
|
{$IFDEF WIN32}
|
|
{$IFNDEF CLX}
|
|
DestroyCursor(Screen.Cursors[crSQLArrow]);
|
|
{$ENDIF}
|
|
FreeTimer(True);
|
|
{$ELSE}
|
|
if Timer <> nil then
|
|
Timer.Free;
|
|
{$ENDIF}
|
|
|
|
end.
|
|
|