git-svn-id: https://svn.code.sf.net/p/kolmck/code@79 91bb2d04-0c0c-4d2d-88a5-bbb6f4c1fa07
This commit is contained in:
dkolmck 2010-10-14 18:59:14 +00:00
parent 19cb111bcd
commit c23311e816
3 changed files with 202 additions and 189 deletions

View File

@ -1,3 +1,5 @@
{This version is compatible with KOL 3.00+ -- VK}
unit ActiveKOL;
interface
@ -9,9 +11,11 @@ uses
{$IFDEF _D6orHigher}
//{$WARN SYMBOL_DEPRECATED OFF}
{$WARN SYMBOL_PLATFORM OFF}
{$IFDEF _D7orHigher}
{$WARN UNSAFE_TYPE OFF}
{$WARN UNSAFE_CAST OFF}
{$WARN UNSAFE_CODE OFF}
{$ENDIF}
{$ENDIF}
{$IFNDEF _D5orHigher}
@ -215,13 +219,15 @@ type
procedure DestroyStorage;
procedure DestroyControl;
procedure StandardEvent(DispID: TDispID; var Params: TDispParams);
procedure SetMouseDblClk(const Value: TOnMouse);
//procedure SetMouseDblClk(const Value: TOnMouse);
procedure SetOnChar(const Value: TOnChar);
protected
{$IFDEF DELPHI_CODECOMPLETION_BUG}
//{$IFDEF DELPHI_CODECOMPLETION_BUG}
fNotAvailable: Boolean;
{$ENDIF}
//{$ENDIF}
{$IFNDEF USE_NAMES}
fName: String;
{$ENDIF}
FControlData: PControlData;
FOleObject: IOleObject;
FMiscStatus: Longint;
@ -337,8 +343,12 @@ type
procedure MouseUp(Button: TMouseButton; AShift: DWORD;
X, Y: Integer);
property OnKeyPress: TOnChar read fOnChar write SetOnChar;
property OnDblClick: TOnMouse read fOnMouseDblClk write SetMouseDblClk;
property OnKeyPress: TOnChar
read {$IFDEF EVENTS_DYNAMIC} Get_OnChar {$ELSE} EV.fOnChar {$ENDIF}
write SetOnChar;
property OnDblClick: TOnMouse index idx_fOnMouseDblClk
read {$IFDEF EVENTS_DYNAMIC} Get_OnMouseEvent {$ELSE} EV.fOnMouseDblClk {$ENDIF}
write SetOnMouseEvent; // SetMouseDblClk;
destructor Destroy; virtual;
@ -509,7 +519,7 @@ constructor TEnumPropDesc.Create(DispID, ValueCount: Integer;
var
I: Integer;
VarDesc: PVarDesc;
Name: WideString;
XName: WideString;
begin
FDispID := DispID;
FValueCount := ValueCount;
@ -518,12 +528,12 @@ begin
begin
OleCheck(TypeInfo.GetVarDesc(I, VarDesc));
try
OleCheck(TypeInfo.GetDocumentation(VarDesc^.memid, @Name,
OleCheck(TypeInfo.GetDocumentation(VarDesc^.memid, @XName,
nil, nil, nil));
with FValues^[I] do
begin
Value := TVarData(VarDesc^.lpVarValue^).VInteger;
Ident := Name;
Ident := XName;
while (Length(Ident) > 1) and (Ident[1] = '_') do
Delete(Ident, 1, 1);
end;
@ -825,8 +835,10 @@ begin
if FOleInPlaceObject = nil then
raise EOleError.CreateResFmt(e_Ole, Integer( @SCannotActivate ), [nil]);
HookControlWndProc;
if not fVisible and IsWindowVisible(fHandle) then
ShowWindow(fHandle, SW_HIDE);
if {$IFDEF USE_FLAGS} not(F3_Visible in fStyle.f3_Style)
{$ELSE} not fVisible {$ENDIF}
and IsWindowVisible(fHandle) then
ShowWindow(fHandle, SW_HIDE);
Result := TRUE;
end
else
@ -939,7 +951,9 @@ procedure TOleCtl.DblClk;
var MouseData: TMouseEventData;
P: TPoint;
begin
if Assigned(OnMouseDblClk) then
{$IFDEF NIL_EVENTS}
if Assigned(EV.fOnMouseDblClk) then
{$ENDIF}
begin
MouseData.Button := mbLeft;
MouseData.Shift := 0;
@ -947,7 +961,7 @@ begin
P := Screen2Client( P );
MouseData.X := P.x;
MouseData.Y := P.y;
OnMouseDblClk(@Self, MouseData);
EV.fOnMouseDblClk(@Self, MouseData);
end;
end;
@ -1322,9 +1336,10 @@ begin
// overriding this method, we allow for constructor to initialize
// the object.
fControlClassName := 'OleCtl'; // ClassName
fIsControl := TRUE;
fStyle := WS_VISIBLE or WS_CLIPCHILDREN or WS_CLIPSIBLINGS or
WS_CHILD; // or WS_BORDER or WS_THICKFRAME;
{$IFDEF USE_FLAGS} include( fFlagsG3, G3_IsControl );
{$ELSE} fIsControl := TRUE; {$ENDIF}
fStyle.Value := WS_VISIBLE or WS_CLIPCHILDREN or WS_CLIPSIBLINGS or
WS_CHILD; // or WS_BORDER or WS_THICKFRAME;
//AttachProc( WndProcCtrl ); for test only
@ -1365,8 +1380,9 @@ begin
((FControlData^.Reserved and cdForceSetClientSite) <> 0) then
OleCheck(FOleObject.SetClientSite(fOleCtlIntf));
OleCheck(FOleObject.QueryInterface(IPersistStreamInit, FPersistStream));
if FMiscStatus and OLEMISC_INVISIBLEATRUNTIME <> 0 then
fVisible := False;
if FMiscStatus and OLEMISC_INVISIBLEATRUNTIME <> 0 then
{$IFDEF USE_FLAGS} exclude( fStyle.f3_Style, F3_Visible );
{$ELSE} fVisible := False; {$ENDIF}
{if FMiscStatus and OLEMISC_SIMPLEFRAME <> 0 then
ControlStyle := [csAcceptsControls, csDoubleClicks, csNoStdEvents] else
ControlStyle := [csDoubleClicks, csNoStdEvents];}
@ -1451,17 +1467,17 @@ end;
procedure TOleCtl.KeyDown(var Key: Longint; AShift: DWORD);
begin
if Assigned(FOnKeyDown) then FOnKeyDown(@Self, Key, AShift);
if Assigned(EV.fOnKeyDown) then EV.fOnKeyDown(@Self, Key, AShift);
end;
procedure TOleCtl.KeyPress(var Key: KOLChar);
begin
if Assigned(FOnChar) then FOnChar(@Self, Key, 0);
if Assigned(EV.fOnChar) then EV.fOnChar(@Self, Key, 0);
end;
procedure TOleCtl.KeyUp(var Key: Longint; AShift: DWORD);
begin
if Assigned(FOnKeyUp) then FOnKeyUp(@Self, Key, AShift);
if Assigned(EV.fOnKeyUp) then EV.fOnKeyUp(@Self, Key, AShift);
end;
procedure TOleCtl.MouseDown(Button: TMouseButton; AShift: DWORD; X,
@ -1545,10 +1561,11 @@ begin
SetProperty(Index, Temp);
end;
procedure TOleCtl.SetMouseDblClk(const Value: TOnMouse);
(*procedure TOleCtl.SetMouseDblClk(const Value: TOnMouse);
begin
fOnMouseDblClk := Value;
end;
{$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF}
.fOnMouseDblClk := Value;
end;*)
procedure TOleCtl.SetName(const Value: String);
var
@ -1603,7 +1620,8 @@ end;
procedure TOleCtl.SetOnChar(const Value: TOnChar);
begin
fOnChar := Value;
{$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF}
.fOnChar := Value;
end;
procedure TOleCtl.SetOnLeave(const Value: TOnEvent);
@ -1733,20 +1751,20 @@ var
// - to access its protected fields
begin
Form := POleCtl( ParentForm );
if Form <> nil then
if Active then
begin
{if (Form.ActiveOleControl <> nil) and
(Form.ActiveOleControl <> Self) then
Form.ActiveOleControl.Perform(CM_UIDEACTIVATE, 0, 0);
Form.ActiveOleControl := Self;}
if (Form.fCurrentControl <> nil) and
(Form.fCurrentControl <> @Self) then
Form.fCurrentControl.Perform(CM_UIDEACTIVATE, 0, 0);
Form.fCurrentControl := @Self;
end else
if Form.fCurrentControl = @Self then
Form.fCurrentControl := nil;
if Form <> nil then
if Active then
begin
{if (Form.ActiveOleControl <> nil) and
(Form.ActiveOleControl <> Self) then
Form.ActiveOleControl.Perform(CM_UIDEACTIVATE, 0, 0);
Form.ActiveOleControl := Self;}
if (Form.DF.fCurrentControl <> nil) and
(Form.DF.fCurrentControl <> @Self) then
Form.DF.fCurrentControl.Perform(CM_UIDEACTIVATE, 0, 0);
Form.DF.fCurrentControl := @Self;
end else
if Form.DF.fCurrentControl = @Self then
Form.DF.fCurrentControl := nil;
end;
procedure TOleCtl.SetVariantProp(Index: Integer; const Value: Variant);
@ -1854,13 +1872,21 @@ begin
Word(Args^[1].VPointer^) := Key;
end;
DISPID_KEYPRESS:
if Params.cArgs > 0 then
begin
Ch := KOLChar(Integer(Variant(Args^[0])));
KeyPress(Ch);
if ((Args^[0].vType and varByRef) <> 0) then
KOLChar(Args^[0].VPointer^) := Ch;
end;
{DISPID_KEYPRESS:
if Params.cArgs > 0 then
begin
Ch := Char(Integer(Variant(Args^[0])));
Ch := KOLChar(Integer(Variant(Args^[0])));
KeyPress(Ch);
if ((Args^[0].vType and varByRef) <> 0) then
Char(Args^[0].VPointer^) := Ch;
end;
KOLChar(Args^[0].VPointer^) := Ch;
end;}
DISPID_MOUSEDOWN, DISPID_MOUSEMOVE, DISPID_MOUSEUP:
if Params.cArgs >= 4 then
begin

174
KOL.pas
View File

@ -14,7 +14,7 @@
Key Objects Library (C) 2000 by Kladov Vladimir.
****************************************************************
* VERSION 3.00.i
* VERSION 3.00.j
****************************************************************
K.O.L. - is a set of objects to create small programs
@ -581,7 +581,15 @@ interface
{$UNDEF SPEED_FASTER}
{$ENDIF}
{$IFDEF SAFE_CODE}
{$UNDEF NO_SAFE_CODE}
{$ENDIF}
{$IFDEF NO_SAFE_CODE}
{$UNDEF SAFE_CODE}
{$ENDIF}
{$IFnDEF NO_SAFE_CODE}
{$DEFINE SAFE_CODE}
{$ENDIF}
{$IFDEF NOT_USE_RICHEDIT}
{$DEFINE NOT_UNLOAD_RICHEDITLIB}
@ -11153,10 +11161,7 @@ function MulDiv( A, B, C: Integer ): Integer;
{* }
function MakeDateTimeRange( D1, D2: TDateTime ): TDateTimeRange;
{* Returns TDateTimeRange from two TDateTime bounds. }
//[Integer FUNCTIONS DECLARATIONS]
procedure Swap( var X, Y: Integer ); overload;
procedure Swap(var X, Y: Byte); overload;
procedure Swap(var X, Y: String); overload;
procedure Swap( var X, Y: Integer );
{* exchanging values }
function Min( X, Y: Integer ): Integer;
{* minimum of two integers }
@ -11190,12 +11195,12 @@ function UInt2Str( Value: DWORD ): AnsiString;
function Int2StrEx( Value, MinWidth: Integer ): AnsiString;
{* Like Int2Str, but resulting string filled with leading spaces to provide
at least MinWidth characters. }
function Int2Rome( Value: Integer ): AnsiString;
function Int2Rome( Value: Integer ): KOLString;
{* Represents number 1..8999 to Rome numer. }
function Int2Ths( I : Integer ) : AnsiString;
function Int2Ths( I: Integer ): KOLString;
{* Converts integer into string, separating every three digits from each
other by character ThsSeparator. (Convert to thousands). You }
function Int2Digs( Value, Digits : Integer ) : AnsiString;
function Int2Digs( Value, Digits: Integer ): KOLString;
{* Converts integer to string, inserting necessary number of leading zeroes
to provide desired length of string, given by Digits parameter. If
resulting string is greater then Digits, string is not truncated anyway. }
@ -15044,7 +15049,7 @@ end;
function MsgBox( const S: KOLString; Flags: DWORD ): DWORD;
var Title: PKOLChar;
begin
{$IFDEF SAFE_CODE} // MsgBox should be called when Applet already created
{$IFnDEF NO_SAFE_CODE} // MsgBox should be called when Applet already created
Title := nil; // (and yet not destroyed)
if assigned( Applet ) then
{$ENDIF}
@ -15062,7 +15067,7 @@ begin
{$ENDIF}
Result := MessageBox( 0, PKOLChar( S ), Title, Flags );
{$IFDEF SNAPMOUSE2DFLTBTN}
{$IFDEF SAFE_CODE}
{$IFnDEF NO_SAFE_CODE}
if Assigned( Applet ) then
{$ENDIF}
Applet.DetachProc( WndProcSnapMouse2DfltBtn );
@ -15331,7 +15336,7 @@ begin
Result.ToDate := D2;
end;
procedure Swap( var X, Y: Integer ); overload;
procedure Swap( var X, Y: Integer );
{$IFDEF F_P}
var Tmp: Integer;
begin
@ -15347,24 +15352,6 @@ asm
end;
{$ENDIF F_P/DELPHI}
procedure Swap(var X, Y: Byte); overload;
var
T: Byte;
begin
T := X;
X := Y;
Y := T;
end;
procedure Swap(var X, Y: String); overload;
var
T: String;
begin
T := X;
X := Y;
Y := T;
end;
function Min( X, Y: Integer ): Integer;
asm
{$IFDEF F_P}
@ -20396,16 +20383,16 @@ begin
Result := ' ' + Result;
end;
function Int2Rome( Value: Integer ): AnsiString;
const RomeDigs = AnsiString('IVXLCDMT');
function RomeNum( N, FromIdx: Integer ): AnsiString;
function Int2Rome( Value: Integer ): KOLString;
const RomeDigs = KOLString('IVXLCDMT');
function RomeNum( N, FromIdx: Integer ): KOLString;
begin
CASE N OF
1, 2, 3: Result := StrRepeat( RomeDigs[ FromIdx ], N );
4: Result := RomeDigs[ FromIdx ] + RomeDigs[ FromIdx + 1 ];
4: Result := '' + RomeDigs[ FromIdx ] + RomeDigs[ FromIdx + 1 ];
5, 6, 7, 8: Result := RomeDigs[ FromIdx + 1 ] + StrRepeat( RomeDigs[ FromIdx ],
N - 5 );
9: Result := RomeDigs[ FromIdx ] + RomeDigs[ FromIdx + 2 ]
9: Result := '' + RomeDigs[ FromIdx ] + RomeDigs[ FromIdx + 2 ]
else Result := '';
END;
end;
@ -20425,8 +20412,67 @@ begin
end;
end;
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
{$IFDEF ASM_UNICODE}
function Int2Ths( I : Integer ) : AnsiString;
asm
PUSH EBP
MOV EBP, ESP
PUSH EAX
PUSH EDX
CALL Int2Str
POP EDX
POP EAX
TEST EAX, EAX
JGE @@0
NEG EAX
@@0:
CMP EAX, 1000
JL @@Exit
PUSH EDX
MOV EAX, [EDX]
PUSH EAX
CALL System.@LStrLen // EAX = Length(Result)
POP EDX
PUSH EDX // EDX = @Result[ 1 ]
XOR ECX, ECX
@@1:
ROL ECX, 8
DEC EAX
MOV CL, [EDX+EAX]
JZ @@fin
CMP ECX, 300000h
JL @@1
PUSH ECX
XOR ECX, ECX
MOV CL, [ThsSeparator]
JMP @@1
@@fin: CMP CL, '-'
JNE @@fin1
CMP CH, [ThsSeparator]
JNE @@fin1
MOV CH, 0 // this corrects -,ddd,...
@@fin1: CMP ECX, 01000000h
JGE @@fin2
INC EAX
ROL ECX, 8
JMP @@fin1
@@fin2: PUSH ECX
LEA EDX, [ESP+EAX]
MOV EAX, [EBP-4]
{$IFDEF _D2009orHigher}
XOR ECX, ECX // TODO: safe to change ecx?
{$ENDIF}
CALL System.@LStrFromPChar
@@Exit:
MOV ESP, EBP
POP EBP
end;
{$ELSE ASM_VERSION}
function Int2Ths( I : Integer ): KOLString;
var S : AnsiString;
begin
S := Int2Str( I );
@ -20443,9 +20489,59 @@ begin
end;
{$ENDIF ASM_VERSION}
{$IFDEF ASM_VERSION}{$ELSE ASM_VERSION} //Pascal
function Int2Digs( Value, Digits : Integer ) : AnsiString;
var M : AnsiString;
{$IFDEF ASM_UNICODE}
function Int2Digs( Value, Digits : Integer ) : KOLString;
asm
PUSH EBP
MOV EBP, ESP
PUSH EDX // [EBP-4] = Digits
PUSH ECX
MOV EDX, ECX
CALL Int2Str
POP ECX
PUSH ECX // [EBP-8] = @Result
MOV EAX, [ECX]
PUSH EAX
CALL System.@LStrLen
POP EDX // EDX = @Result[1]
MOV ECX, EAX // ECX = Length( Result )
ADD EAX, EAX
SUB ESP, EAX
MOV EAX, ESP
PUSHAD
CALL StrCopy
POPAD
MOV EDX, EAX
ADD ESP, -100
CMP byte ptr [EDX], '-'
PUSHFD
JNE @@1
INC EDX
@@1:
MOV EAX, [EBP-4] // EAX = Digits
CMP ECX, EAX
JGE @@2
DEC EDX
MOV byte ptr [EDX], '0'
INC ECX
JMP @@1
@@2:
POPFD
JNE @@3
DEC EDX
MOV byte ptr [EDX], '-'
@@3:
MOV EAX, [EBP-8]
{$IFDEF _D2009orHigher}
XOR ECX, ECX // TODO: eax or ecx affect result?
{$ENDIF}
CALL System.@LStrFromPChar
MOV ESP, EBP
POP EBP
end;
{$ELSE ASM_VERSION} //Pascal
function Int2Digs( Value, Digits : Integer ) : KOLString;
var M : KOLString;
begin
Result := Int2Str( Value );
M := '';

View File

@ -2407,115 +2407,6 @@ asm
@@exit:
end;
function Int2Ths( I : Integer ) : AnsiString;
asm
PUSH EBP
MOV EBP, ESP
PUSH EAX
PUSH EDX
CALL Int2Str
POP EDX
POP EAX
TEST EAX, EAX
JGE @@0
NEG EAX
@@0:
CMP EAX, 1000
JL @@Exit
PUSH EDX
MOV EAX, [EDX]
PUSH EAX
CALL System.@LStrLen // EAX = Length(Result)
POP EDX
PUSH EDX // EDX = @Result[ 1 ]
XOR ECX, ECX
@@1:
ROL ECX, 8
DEC EAX
MOV CL, [EDX+EAX]
JZ @@fin
CMP ECX, 300000h
JL @@1
PUSH ECX
XOR ECX, ECX
MOV CL, [ThsSeparator]
JMP @@1
@@fin: CMP CL, '-'
JNE @@fin1
CMP CH, [ThsSeparator]
JNE @@fin1
MOV CH, 0 // this corrects -,ddd,...
@@fin1: CMP ECX, 01000000h
JGE @@fin2
INC EAX
ROL ECX, 8
JMP @@fin1
@@fin2: PUSH ECX
LEA EDX, [ESP+EAX]
MOV EAX, [EBP-4]
{$IFDEF _D2009orHigher}
XOR ECX, ECX // TODO: safe to change ecx?
{$ENDIF}
CALL System.@LStrFromPChar
@@Exit:
MOV ESP, EBP
POP EBP
end;
function Int2Digs( Value, Digits : Integer ) : AnsiString;
asm
PUSH EBP
MOV EBP, ESP
PUSH EDX // [EBP-4] = Digits
PUSH ECX
MOV EDX, ECX
CALL Int2Str
POP ECX
PUSH ECX // [EBP-8] = @Result
MOV EAX, [ECX]
PUSH EAX
CALL System.@LStrLen
POP EDX // EDX = @Result[1]
MOV ECX, EAX // ECX = Length( Result )
ADD EAX, EAX
SUB ESP, EAX
MOV EAX, ESP
PUSHAD
CALL StrCopy
POPAD
MOV EDX, EAX
ADD ESP, -100
CMP byte ptr [EDX], '-'
PUSHFD
JNE @@1
INC EDX
@@1:
MOV EAX, [EBP-4] // EAX = Digits
CMP ECX, EAX
JGE @@2
DEC EDX
MOV byte ptr [EDX], '0'
INC ECX
JMP @@1
@@2:
POPFD
JNE @@3
DEC EDX
MOV byte ptr [EDX], '-'
@@3:
MOV EAX, [EBP-8]
{$IFDEF _D2009orHigher}
XOR ECX, ECX // TODO: eax or ecx affect result?
{$ENDIF}
CALL System.@LStrFromPChar
MOV ESP, EBP
POP EBP
end;
function Num2Bytes( Value : Double ) : AnsiString;
asm
PUSH EBX