pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

jvcllaz: Move unit JvButton.pas to new package JvStdCtrls (like in Delphi version).

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@5442 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2016-12-07 16:17:41 +00:00
parent ccc4276d0d
commit 13e96a6e1b
14 changed files with 263 additions and 1042 deletions
Download Patch File Download Diff File Expand all files Collapse all files

3
components/jvcllaz/run/JvCore/JvConsts.pas
View File

@ -205,6 +205,9 @@ const
AF_ICON = $00000001;
AF_SEQUENCE = $00000002;
DT_PATH_ELLIPSIS = $4000;
const
KeyboardShiftStates = [ssShift, ssAlt, ssCtrl];
MouseShiftStates = [ssLeft, ssRight, ssMiddle, ssDouble];

8
components/jvcllaz/run/JvCore/JvExControls.pas
View File

@ -44,7 +44,8 @@ unit JvExControls;
interface
uses
Classes, types, Controls, Graphics, LCLIntf, LCLType, LMessages, Forms;
Classes, types, Controls, Graphics, LCLIntf, LCLType, LMessages, Forms,
JvTypes;
type
TDlgCode =
@ -67,6 +68,7 @@ const
CM_DENYSUBCLASSING = JvThemes.CM_DENYSUBCLASSING;
CM_PERFORM = CM_BASE + $500 + 0; // LParam: "Msg: ^TMessage"
CM_SETAUTOSIZE = CM_BASE + $500 + 1; // WParam: "Value: Boolean"
******************** NOT CONVERTED *)
type
TJvHotTrackOptions = class;
@ -123,7 +125,6 @@ type
property FrameVisible: Boolean read FFrameVisible write SetFrameVisible default False;
property FrameColor: TColor read FFrameColor write SetFrameColor default $006A240A;
end;
******************** NOT CONVERTED *)
type
TStructPtrMessage = class(TObject)
@ -491,7 +492,7 @@ begin
end;
end;
(******************** NOT CONVERTED
//=== { TJvHotTrackOptions } ======================================
constructor TJvHotTrackOptions.Create;
@ -568,7 +569,6 @@ begin
Changed;
end;
end;
******************** NOT CONVERTED *)
//============================================================================

66
components/jvcllaz/run/JvCore/JvJCLUtils.pas
View File

@ -46,10 +46,10 @@ interface
// the JCL has the same problem with CLX it should not make any difference.
uses
Classes, Graphics, LCLIntf, LCLType;
Classes, Graphics, LCLIntf, LCLType, LMessages;
(******************** NOT CONVERTED
const
(******************** NOT CONVERTED
{$IFDEF MSWINDOWS}
PathDelim = '\';
DriveDelim = ':';
@ -61,8 +61,10 @@ const
AllFilesMask = '*';
{$ENDIF UNIX}
// Note: the else is on purpose, VCL is not defined for a console application
******************** NOT CONVERTED *)
NullHandle = 0;
(******************** NOT CONVERTED
{$IFDEF UNIX}
type
TFileTime = Integer;
@ -854,6 +856,7 @@ const
function DateIsNull(const pdtValue: TDateTime; const pdtKind: TdtKind): Boolean;
// Replacement for Win32Check to avoid platform specific warnings in D6
function OSCheck(RetVal: Boolean): Boolean;
******************** NOT CONVERTED *)
{ Shortens a fully qualified Path name so that it can be drawn with a specified length limit.
Same as FileCtrl.MinimizeName in functionality (but not implementation). Included here to
@ -863,6 +866,7 @@ function MinimizeText(const Text: string; Canvas: TCanvas; MaxWidth: Integer): s
{ MinimizeString trunactes long string, S, and appends
'...' symbols, if Length of S is more than MaxLen }
function MinimizeString(const S: string; const MaxLen: Integer): string;
(******************** NOT CONVERTED
{$IFNDEF CLR}
{$IFDEF MSWINDOWS}
@ -962,8 +966,10 @@ function WindowClassName(Wnd: THandle): string;
procedure SwitchToWindow(Wnd: THandle; Restore: Boolean);
procedure ActivateWindow(Wnd: THandle);
procedure ShowWinNoAnimate(Handle: THandle; CmdShow: Integer);
******************** NOT CONVERTED *)
procedure KillMessage(Wnd: THandle; Msg: Cardinal);
(******************** NOT CONVERTED
{ SetWindowTop put window to top without recreating window }
procedure SetWindowTop(const Handle: THandle; const Top: Boolean);
procedure CenterWindow(Wnd: THandle);
@ -1192,6 +1198,10 @@ function SecondsBetween(const Now: TDateTime; const FTime: TDateTime): Integer;
implementation
uses
Math,
JvConsts;
(******************** NOT CONVERTED
uses
{$IFDEF HAS_UNIT_RTLCONSTS}
@ -2083,17 +2093,6 @@ begin
Result := S2 + Result;
end;
function MinimizeString(const S: string; const MaxLen: Integer): string;
begin
if Length(S) > MaxLen then
if MaxLen < 3 then
Result := Copy(S, 1, MaxLen)
else
Result := Copy(S, 1, MaxLen - 3) + '...'
else
Result := S;
end;
function TrueInflateRect(const R: TRect; const I: Integer): TRect;
begin
with R do
@ -8180,27 +8179,19 @@ begin
Result := RetVal;
end;
******************** NOT CONVERTED *)
function MinimizeFileName(const FileName: string; Canvas: TCanvas; MaxLen: Integer): string;
var
{$IFDEF CLR}
sb: StringBuilder;
{$ENDIF CLR}
R: TRect;
flags: Word;
begin
Result := FileName;
R := Rect(0, 0, MaxLen, Canvas.TextHeight('Wq'));
{$IFDEF CLR}
sb := StringBuilder.Create(Result);
// DrawText() doesn't exist with StringBuilder parameter (2005)
if DrawTextEx(Canvas.Handle, sb, sb.Length, R,
DT_SINGLELINE or DT_MODIFYSTRING or DT_PATH_ELLIPSIS or DT_CALCRECT or
DT_NOPREFIX, nil) <= 0 then
{$ELSE}
UniqueString(Result);
if DrawText(Canvas.Handle, PChar(Result), Length(Result), R,
DT_SINGLELINE or DT_MODIFYSTRING or DT_PATH_ELLIPSIS or DT_CALCRECT or
DT_NOPREFIX) <= 0 then
{$ENDIF CLR}
flags := DT_SINGLELINE or DT_MODIFYSTRING or DT_PATH_ELLIPSIS or
DT_CALCRECT or DT_NOPREFIX;
if DrawText(Canvas.Handle, PChar(Result), Length(Result), R, flags) <= 0 then
Result := FileName;
end;
@ -8218,6 +8209,18 @@ begin
end;
end;
function MinimizeString(const S: string; const MaxLen: Integer): string;
begin
if Length(S) > MaxLen then
if MaxLen < 3 then
Result := Copy(S, 1, MaxLen)
else
Result := Copy(S, 1, MaxLen - 3) + '...'
else
Result := S;
end;
(******************** NOT CONVERTED
{$IFNDEF CLR}
{$IFDEF MSWINDOWS}
@ -8950,7 +8953,7 @@ begin
SetWindowPos(Wnd, 0, R.Left, R.Top, 0, 0, SWP_NOACTIVATE or
SWP_NOSIZE or SWP_NOZORDER);
end;
******************** NOT CONVERTED *)
{ Delete the requested message from the queue, but throw back }
{ any WM_QUIT msgs that PeekMessage may also return. }
@ -8960,11 +8963,14 @@ var
M: TMsg;
begin
M.Message := 0;
if PeekMessage(M, Wnd, Msg, Msg, PM_REMOVE) and (M.Message = WM_QUIT) then
{ wp ---- PostQuitMessage does not exist in Lazarus
if PeekMessage(M, Wnd, Msg, Msg, PM_REMOVE) and (M.Message = LM_QUIT) then
PostQuitMessage(M.WParam);
}
end;
(******************** NOT CONVERTED
procedure SetWindowTop(const Handle: THandle; const Top: Boolean);
const
TopFlag: array [Boolean] of Longword = (HWND_NOTOPMOST, HWND_TOPMOST);

143
components/jvcllaz/run/JvCore/JvJVCLUtils.pas
View File

@ -26,13 +26,20 @@ Known Issues:
// Conversion is done in incremental way: as types / classes / routines
// are needed they are converted.
{$mode objfpc}{$H+}
{$MODE DELPHI}
//{$mode objfpc}{$H+}
unit JvJVCLUtils;
interface
uses
Classes, Graphics, JvTypes, ImgList, LCLType, Types;
{$IFDEF WIN32}
Windows,
{$ENDIF}
Classes, Graphics, Controls, ImgList,
LCLType, LCLProc, LMessages, Types,
JvTypes;
(******************** NOT CONVERTED
// Transform an icon to a bitmap
@ -86,6 +93,7 @@ function CaptureScreen(WndHandle: Longword): TBitmap; overload;
{$ENDIF MSWINDOWS}
procedure RGBToHSV(R, G, B: Integer; var H, S, V: Integer);
******************** NOT CONVERTED *)
{ from JvVCLUtils }
@ -93,6 +101,7 @@ procedure CopyParentImage(Control: TControl; Dest: TCanvas);
{ Windows resources (bitmaps and icons) VCL-oriented routines }
procedure DrawBitmapTransparent(Dest: TCanvas; DstX, DstY: Integer;
Bitmap: TBitmap; TransparentColor: TColor);
(******************** NOT CONVERTED
procedure DrawBitmapRectTransparent(Dest: TCanvas; DstX, DstY: Integer;
SrcRect: TRect; Bitmap: TBitmap; TransparentColor: TColor);
procedure StretchBitmapRectTransparent(Dest: TCanvas; DstX, DstY, DstW,
@ -102,6 +111,8 @@ function MakeBitmap(ResID: PChar): TBitmap;
function MakeBitmapID(ResID: Word): TBitmap;
function MakeModuleBitmap(Module: THandle; ResID: PChar): TBitmap;
{$ENDIF !CLR}
******************** NOT CONVERTED *)
function AllocPatternBitmap(BkColor, FgColor: TColor): TBitmap;
function CreateTwoColorsBrushPattern(Color1, Color2: TColor): TBitmap;
function CreateDisabledBitmap_NewStyle(FOriginal: TBitmap; BackColor: TColor):
TBitmap;
@ -109,12 +120,15 @@ function CreateDisabledBitmapEx(FOriginal: TBitmap; OutlineColor, BackColor,
HighLightColor, ShadowColor: TColor; DrawHighlight: Boolean): TBitmap;
function CreateDisabledBitmap(FOriginal: TBitmap; OutlineColor: TColor):
TBitmap;
(******************** NOT CONVERTED
procedure AssignBitmapCell(Source: TGraphic; Dest: TBitmap; Cols, Rows,
Index: Integer);
function ChangeBitmapColor(Bitmap: TBitmap; Color, NewColor: TColor): TBitmap;
******************** NOT CONVERTED *)
procedure ImageListDrawDisabled(Images: TCustomImageList; Canvas: TCanvas;
X, Y, Index: Integer; HighLightColor, GrayColor: TColor;
DrawHighlight: Boolean);
(******************** NOT CONVERTED
{$IFNDEF CLR}
function MakeIcon(ResID: PChar): TIcon;
@ -166,7 +180,11 @@ function GetControlPanelApplet(const AFileName: string; Strings: TStrings;
{$ENDIF !CLR}
function PointInPolyRgn(const P: TPoint; const Points: array of TPoint): Boolean;
******************** NOT CONVERTED *)
function PaletteColor(Color: TColor): Longint;
(******************** NOT CONVERTED
procedure PaintInverseRect(const RectOrg, RectEnd: TPoint);
procedure DrawInvertFrame(ScreenRect: TRect; Width: Integer);
@ -212,9 +230,12 @@ function LoadAniCursor(Instance: THandle; ResID: PChar): HCURSOR;
{ Windows API level routines }
******************** NOT CONVERTED *)
procedure StretchBltTransparent(DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
SrcDC: HDC; SrcX, SrcY, SrcW, Srch: Integer;
Palette: HPALETTE; TransparentColor: TColorRef);
(******************** NOT CONVERTED
procedure DrawTransparentBitmap(DC: HDC; Bitmap: HBITMAP;
DstX, DstY: Integer; TransparentColor: TColorRef);
function PaletteEntries(Palette: HPALETTE): Integer;
@ -279,8 +300,10 @@ function FindFormByClass(FormClass: TFormClass): TForm;
function FindFormByClassName(const FormClassName: string): TForm;
{ AppMinimized returns True, if Application is minimized }
function AppMinimized: Boolean;
******************** NOT CONVERTED *)
function IsForegroundTask: Boolean;
(******************** NOT CONVERTED
{ MessageBox is Application.MessageBox with string (not PChar) parameters.
if Caption parameter = '', it replaced with Application.Title }
function MessageBox(const Msg, Caption: string; const Flags: Integer): Integer;
@ -832,7 +855,11 @@ function ReplaceImageListReference(This: TComponent; NewReference: TCustomImageL
implementation
uses
sysutils, LCLIntf, math;
sysutils, LCLIntf,
{$IFDEF MSWINDOWS}
CommCtrl,
{$ENDIF}
math, JvConsts, JvJCLUtils;
(********************
SysConst,
Consts,
@ -1500,14 +1527,12 @@ begin
else
Result := pcItem.SubItems[piIndex - 1];
end;
******************** NOT CONVERTED *)
{from JvVCLUtils }
{ Bitmaps }
// see above for VisualCLX version of CopyParentImage
type
TJvParentControl = class(TWinControl);
@ -1531,7 +1556,7 @@ begin
// calls it as well. Best example is a TJvSpeeButton in a TJvPanel,
// both with Transparent set to True (discovered while working on
// Mantis 3624)
GetViewPortOrgEx(DC, ViewPortOrg);
GetViewPortOrgEx(DC, @ViewPortOrg);
with Control do
begin
@ -1555,7 +1580,7 @@ begin
{$ELSE}
with TJvParentControl(Control.Parent) do
begin
Perform(WM_ERASEBKGND, DC, 0);
Perform(LM_ERASEBKGND, DC, 0);
PaintWindow(DC);
end;
{$ENDIF CLR}
@ -1583,7 +1608,7 @@ begin
try
SetViewPortOrgEx(DC, Left + ViewPortOrg.X, Top + ViewPortOrg.Y, nil);
IntersectClipRect(DC, 0, 0, Width, Height);
Perform(WM_PAINT, DC, 0);
Perform(LM_PAINT, DC, 0);
finally
RestoreDC(DC, SaveIndex);
ControlState := ControlState - [csPaintCopy];
@ -1597,6 +1622,7 @@ begin
ControlState := ControlState - [csPaintCopy];
end;
end;
(******************** NOT CONVERTED
@ -1672,11 +1698,11 @@ begin
Dest.Transparent := Source.Transparent;
end;
end;
******************** NOT CONVERTED *)
{ Transparent bitmap }
procedure StretchBltTransparent(DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
SrcDC: HDC; SrcX, SrcY, SrcW, Srch: Integer; Palette: HPALETTE;
TransparentColor: TColorRef);
@ -1763,7 +1789,7 @@ begin
DeleteDC(SaveDC);
end;
(******************** NOT CONVERTED
procedure DrawTransparentBitmapRect(DC: HDC; Bitmap: HBITMAP; DstX, DstY,
DstW, DstH: Integer; SrcRect: TRect; TransparentColor: TColorRef);
@ -1794,6 +1820,7 @@ begin
DrawTransparentBitmapRect(DC, Bitmap, DstX, DstY, BM.bmWidth, BM.bmHeight,
Rect(0, 0, BM.bmWidth, BM.bmHeight), TransparentColor);
end;
******************** NOT CONVERTED*)
procedure StretchBitmapTransparent(Dest: TCanvas; Bitmap: TBitmap;
TransparentColor: TColor; DstX, DstY, DstW, DstH, SrcX, SrcY,
@ -1866,6 +1893,7 @@ begin
Bitmap.Width, Bitmap.Height, 0, 0, Bitmap.Width, Bitmap.Height);
end;
{ CreateDisabledBitmap. Creating TBitmap object with disable button glyph
image. You must destroy it outside by calling TBitmap.Free method. }
@ -1979,6 +2007,8 @@ begin
clBtnFace, clBtnHighlight, clBtnShadow, True);
end;
(******************** NOT CONVERTED
{ ChangeBitmapColor. This function create new TBitmap object.
You must destroy it outside by calling TBitmap.Free method. }
@ -2006,6 +2036,8 @@ begin
end;
end;
******************** NOT CONVERTED *)
procedure ImageListDrawDisabled(Images: TCustomImageList; Canvas: TCanvas;
X, Y, Index: Integer; HighLightColor, GrayColor: TColor;
DrawHighlight: Boolean);
@ -2022,7 +2054,11 @@ begin
begin
Brush.Color := clWhite;
FillRect(Rect(0, 0, Images.Width, Images.Height));
{$IFDEF MSWINDOWS}
ImageList_Draw(Images.Handle, Index, Handle, 0, 0, ILD_MASK);
{$ELSE}
ImageList_Draw ????
{$ENDIF}
end;
Bmp.Monochrome := True;
if DrawHighlight then
@ -2044,6 +2080,7 @@ begin
end;
end;
{ Brush Pattern }
function CreateTwoColorsBrushPattern(Color1, Color2: TColor): TBitmap;
@ -2065,6 +2102,19 @@ begin
end;
end;
{ A function existing in Delphi's graphics, but missing in LCL.
According to Delphi help:
"AllocPatternBitmap returns a reference to an 8 by 8 pixel TBitmap that
is filled with a pattern. Pixels alternate between BkColor and FgColor colors
horizontally and vertically in a quilt pattern." - this is exactly what
CreateTwoColorsBrushPattern does... }
function AllocPatternBitmap(BkColor, FgColor: TColor): TBitmap;
begin
Result := CreateTwoColorsBrushPattern(BkColor, FgColor);
end;
(******************** NOT CONVERTED
{ Icons }
{$IFNDEF CLR}
@ -2198,14 +2248,14 @@ begin
DeleteObject(Rgn);
end;
end;
******************** NOT CONVERTED *)
function PaletteColor(Color: TColor): Longint;
begin
Result := ColorToRGB(Color) or PaletteMask;
end;
(******************** NOT CONVERTED
function CreateRotatedFont(Font: TFont; Angle: Integer): HFONT;
var
LogFont: TLogFont;
@ -3000,75 +3050,50 @@ function AppMinimized: Boolean;
begin
Result := IsIconic(GetAppHandle);
end;
******************** NOT CONVERTED *)
{$IFDEF MSWINDOWS}
{ Check if this is the active Windows task }
{ Copied from implementation of FORMS.PAS }
type
{$IFNDEF CLR}
PCheckTaskInfo = ^TCheckTaskInfo;
{$ENDIF !CLR}
TCheckTaskInfo = record
FocusWnd: Windows.HWND;
FocusWnd: HWND;
Found: Boolean;
end;
{$IFDEF CLR}
PCheckTaskInfo = TCheckTaskInfo;
var
CheckTaskHashLock: TObject = nil;
CheckTaskInfo: PCheckTaskInfo;
{$ENDIF CLR}
function CheckTaskWindow(Window: HWND; Data: Longint): LongBool; {$IFNDEF CLR}stdcall;{$ENDIF}
function CheckTaskWindow(Window: HWND; Data: PtrInt): LongBool; stdcall;
begin
Result := True;
{$IFDEF CLR}
if CheckTaskInfo.FocusWnd = Window then
if PCheckTaskInfo(Data)^.FocusWnd = Window then
begin
CheckTaskInfo.Found := True;
{$ELSE}
if PCheckTaskInfo(Data).FocusWnd = Window then
begin
PCheckTaskInfo(Data).Found := True;
{$ENDIF CLR}
PCheckTaskInfo(Data)^.Found := True;
Result := False;
end;
end;
{$ENDIF}
function IsForegroundTask: Boolean;
{$IFDEF MSWINDOWS}
var
Info: TCheckTaskInfo;
{$ENDIF}
begin
Info.FocusWnd := Windows.GetActiveWindow;
{$IFDEF MSWINDOWS}
Info.FocusWnd := GetActiveWindow;
Info.Found := False;
{$IFDEF CLR}
if CheckTaskHashLock = nil then
CheckTaskHashLock := TObject.Create;
Monitor.Enter(CheckTaskHashLock);
try
CheckTaskInfo := Info;
EnumThreadWindows(GetCurrentThreadId, CheckTaskWindow, 0);
Info := CheckTaskInfo;
finally
Monitor.Exit(CheckTaskHashLock);
end;
{$ELSE}
EnumThreadWindows(GetCurrentThreadId, @CheckTaskWindow, Longint(@Info));
{$ENDIF CLR}
EnumThreadWindows(GetCurrentThreadID, @CheckTaskWindow, PtrInt(@Info));
Result := Info.Found;
end;
{$ENDIF MSWINDOWS}
{$IFDEF UNIX}
function IsForegroundTask: Boolean;
begin
{$ELSE}
{$IFDEF UNIX}
Result := Application.Active;
{$ELSE}
Result := true;
{$ENDIF}
{$ENDIF}
end;
{$ENDIF UNIX}
(******************** NOT CONVERTED
function MessageBox(const Msg, Caption: string; const Flags: Integer): Integer;
{$IFDEF CLR}

15
components/jvcllaz/run/JvCore/JvTypes.pas
View File

@ -31,7 +31,8 @@ Known Issues:
// Conversion is done in incremental way: as types / classes / routines
// are needed they are converted.
{$mode objfpc}{$H+}
//{$mode objfpc}{$H+}
{$MODE DELPHI}
unit JvTypes;
@ -98,6 +99,7 @@ type
{$IFDEF CLR}
IUnknown = IInterface;
{$ENDIF CLR}
********************)
// Base class for persistent properties that can show events.
// By default, Delphi and BCB don't show the events of a class
@ -107,14 +109,10 @@ type
// from having events for a sub property.
// The design time editor associated with TJvPersistent will display
// the events, thus mimicking a Sub Component.
{$IFDEF COMPILER6_UP}
TJvPersistent = class(TComponent)
public
constructor Create(AOwner: TComponent); override;
end;
{$ELSE}
TJvPersistent = class(TPersistent);
{$ENDIF COMPILER6_UP}
// Added by dejoy (2005-04-20)
// A lot of TJVxxx control persistent properties used TPersistent,
@ -122,7 +120,7 @@ type
// and property change notify.
TJvPropertyChangeEvent = procedure(Sender: TObject; const PropName: string) of object;
TJvPersistentProperty = class(TPersistent)//?? TJvPersistent
TJvPersistentProperty = class(TPersistent) // ?? TJvPersistent)
private
FUpdateCount: Integer;
FOnChanging: TNotifyEvent;
@ -145,6 +143,7 @@ type
property OnChangingProperty: TJvPropertyChangeEvent read FOnChangingProperty write FOnChangingProperty;
end;
(********************
TJvRegKey = (hkClassesRoot, hkCurrentUser, hkLocalMachine, hkUsers,
hkPerformanceData, hkCurrentConfig, hkDynData);
TJvRegKeys = set of TJvRegKey;
@ -675,8 +674,6 @@ type
implementation
(***************
{$IFDEF COMPILER6_UP}
constructor TJvPersistent.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
@ -684,7 +681,6 @@ begin
SetSubComponent(True);
Name := 'SubComponent';
end;
{$ENDIF COMPILER6_UP}
{ TJvPersistentProperty }
@ -733,7 +729,6 @@ begin
else
Changed;
end;
***************)
end.