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

4
components/jvcllaz/design/JvCtrls/JvCtrlsReg.pas
View File

@ -14,12 +14,12 @@ implementation
{$R ../../resource/JvHTControlsReg.res}
uses
Classes, JvDsgnConsts, JvHtControls, {JvDBHTLabel,} JvHint, JvHTHintForm,
Classes, JvDsgnConsts,
JvHtControls, {JvDBHTLabel,} JvHint, JvHTHintForm,
PropEdits, Controls;
procedure Register;
begin
// RegisterComponents(RsPaletteButton, [TJvHTButton]);
RegisterComponents(RsPaletteLabel, [TJvHTLabel]);
RegisterComponents(RsPaletteListComboTree, [TJvHTListBox, TJvHTComboBox]);
RegisterComponents(RsPaletteNonVisual, [TJvHint]);

24
components/jvcllaz/design/JvStdCtrls/JvStdCtrlsReg.pas Normal file
View File

@ -0,0 +1,24 @@
unit JvStdCtrlsReg;
{$mode objfpc}{$H+}
interface
uses
SysUtils;
procedure Register;
implementation
uses
Classes, JvDsgnConsts, JvButton,
Controls;
procedure Register;
begin
//RegisterComponents(RsPaletteButton, [TJvButton]);
end;
end.

12
components/jvcllaz/examples/JvNavigationPane/JvNavPaneDemo.lpi
View File

@ -36,7 +36,7 @@
<PackageName Value="LCL"/>
</Item2>
</RequiredPackages>
<Units Count="6">
<Units Count="7">
<Unit0>
<Filename Value="JvNavPaneDemo.lpr"/>
<IsPartOfProject Value="True"/>
@ -51,7 +51,6 @@
<ComponentName Value="JvNavPaneDemoMainFrm"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<IsVisibleTab Value="True"/>
<EditorIndex Value="1"/>
<CursorPos X="3" Y="11"/>
<UsageCount Value="22"/>
@ -83,6 +82,15 @@
<CursorPos X="31" Y="47"/>
<UsageCount Value="10"/>
</Unit5>
<Unit6>
<Filename Value="..\..\run\JvPageComps\JvNavigationPane.pas"/>
<IsVisibleTab Value="True"/>
<EditorIndex Value="2"/>
<TopLine Value="31"/>
<CursorPos X="61" Y="50"/>
<UsageCount Value="10"/>
<Loaded Value="True"/>
</Unit6>
</Units>
<JumpHistory Count="2" HistoryIndex="1">
<Position1>

12
components/jvcllaz/packages/JvCtrlsLazR.lpk
View File

@ -19,19 +19,15 @@
- Listboxes, Comboboxes, TreeViews"/>
<License Value="The JVCL is released in accordance with the MPL 1.1 license. To get your own copy or read it, go to http://www.mozilla.org/MPL/MPL-1.1.html. "/>
<Version Major="1" Release="1"/>
<Files Count="3">
<Files Count="2">
<Item1>
<Filename Value="..\run\JvCtrls\JvButton.pas"/>
<UnitName Value="JvButton"/>
</Item1>
<Item2>
<Filename Value="..\run\JvCtrls\JvHint.pas"/>
<UnitName Value="JvHint"/>
</Item2>
<Item3>
</Item1>
<Item2>
<Filename Value="..\run\JvCtrls\JvHtControls.pas"/>
<UnitName Value="JvHtControls"/>
</Item3>
</Item2>
</Files>
<RequiredPkgs Count="2">
<Item1>

4
components/jvcllaz/packages/JvPageCompsR.lpk
View File

@ -8,7 +8,7 @@
<Version Value="11"/>
<PathDelim Value="\"/>
<SearchPaths>
<OtherUnitFiles Value="..\run\JvPageComps"/>
<OtherUnitFiles Value="..\run\JvPageComps;..\run\JvStdCtrls"/>
<UnitOutputDirectory Value="..\lib\$(TargetCPU)-$(TargetOS)\run\JvPageComps"/>
</SearchPaths>
</CompilerOptions>
@ -27,7 +27,7 @@
</Files>
<RequiredPkgs Count="3">
<Item1>
<PackageName Value="JvCtrlsLazR"/>
<PackageName Value="JvStdCtrlsLazR"/>
</Item1>
<Item2>
<PackageName Value="JvCoreLazR"/>

44
components/jvcllaz/packages/JvStdCtrlsLazD.lpk Normal file
View File

@ -0,0 +1,44 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<Package Version="4">
<PathDelim Value="\"/>
<Name Value="JvStdCtrlsLazD"/>
<Type Value="RunAndDesignTime"/>
<Author Value="Lazarus port by: Werner Pamler"/>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<SearchPaths>
<OtherUnitFiles Value="..\design\JvStdCtrls"/>
<UnitOutputDirectory Value="..\lib\$(TargetCPU)-$(TargetOS)\design\JvStdCtrls"/>
</SearchPaths>
</CompilerOptions>
<Description Value="Standard controls of the JVCL library (https://sourceforge.net/projects/jvcl/) (designtime code)"/>
<License Value="The JVCL is released in accordance with the MPL 1.1 license. To get your own copy or read it, go to http://www.mozilla.org/MPL/MPL-1.1.html. "/>
<Version Major="1" Release="1"/>
<Files Count="1">
<Item1>
<Filename Value="..\design\JvStdCtrls\JvStdCtrlsReg.pas"/>
<HasRegisterProc Value="True"/>
<UnitName Value="JvStdCtrlsReg"/>
</Item1>
</Files>
<RequiredPkgs Count="3">
<Item1>
<PackageName Value="JvCoreLazD"/>
</Item1>
<Item2>
<PackageName Value="JvStdCtrlsLazR"/>
</Item2>
<Item3>
<PackageName Value="FCL"/>
</Item3>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
</Package>
</CONFIG>

43
components/jvcllaz/packages/JvStdCtrlsLazR.lpk Normal file
View File

@ -0,0 +1,43 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<Package Version="4">
<PathDelim Value="\"/>
<Name Value="JvStdCtrlsLazR"/>
<Author Value="Lazarus port by: Werner Pamler"/>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<SearchPaths>
<OtherUnitFiles Value="..\run\JvStdCtrls"/>
<UnitOutputDirectory Value="..\lib\$(TargetCPU)-$(TargetOS)\run\JvStdCtrls"/>
</SearchPaths>
</CompilerOptions>
<Description Value="Standard controls of the JVCL library (https://sourceforge.net/projects/jvcl/) (runtime code):
- Buttons
- Hypertext components
- Labels
- Listboxes, Comboboxes, TreeViews"/>
<License Value="The JVCL is released in accordance with the MPL 1.1 license. To get your own copy or read it, go to http://www.mozilla.org/MPL/MPL-1.1.html. "/>
<Version Major="1" Release="1"/>
<Files Count="1">
<Item1>
<Filename Value="..\run\JvStdCtrls\JvButton.pas"/>
<UnitName Value="JvButton"/>
</Item1>
</Files>
<RequiredPkgs Count="2">
<Item1>
<PackageName Value="JvCoreLazR"/>
</Item1>
<Item2>
<PackageName Value="FCL"/>
</Item2>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
</Package>
</CONFIG>

4
components/jvcllaz/packages/JvXPCtrlsLazR.lpk
View File

@ -9,7 +9,7 @@
<PathDelim Value="\"/>
<SearchPaths>
<OtherUnitFiles Value="..\run\JvXPCtrls"/>
<UnitOutputDirectory Value="..lib\$(TargetCPU)-$(TargetOS)\run\JvXPCtrls"/>
<UnitOutputDirectory Value="..\lib\$(TargetCPU)-$(TargetOS)\run\JvXPCtrls"/>
</SearchPaths>
</CompilerOptions>
<Description Value="XP style controls of the JVCL library (https://sourceforge.net/projects/jvcl/) (runtime code)"/>
@ -43,7 +43,7 @@
</Files>
<RequiredPkgs Count="3">
<Item1>
<PackageName Value="JvCtrlsLazR"/>
<PackageName Value="JvStdCtrlsLazR"/>
</Item1>
<Item2>
<PackageName Value="JvCoreLazR"/>

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.

923
components/jvcllaz/run/JvCtrls/JvButton.pas
View File

@ -1,923 +0,0 @@
{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.
The Original Code is: JvButton.PAS, released on 2001-02-28.
The Initial Developer of the Original Code is S�bastien Buysse [sbuysse att buypin dott com]
Portions created by S�bastien Buysse are Copyright (C) 2001 S�bastien Buysse.
All Rights Reserved.
Contributor(s): Michael Beck [mbeck att bigfoot dott com].
You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.sourceforge.net
Known Issues:
-----------------------------------------------------------------------------}
// $Id: JvButton.pas 11400 2007-06-28 21:24:06Z ahuser $
// Initial port to Lazarus by Sergio Samayoa - september 2007.
// Conversion is done in incremental way: as types / classes / routines
// are needed they are converted.
{$mode objfpc}{$H+}
unit JvButton;
interface
uses
Classes, Controls, Graphics, JvComponent, JvConsts, JvTypes, LMessages, Menus;
type
TJvButtonMouseState = (bsMouseInside, bsMouseDown);
TJvButtonMouseStates = set of TJvButtonMouseState;
TJvCustomGraphicButton = class(TJvGraphicControl)
private
FStates: TJvButtonMouseStates;
FBuffer: TBitmap;
FFlat: Boolean;
FDropDownMenu: TPopupMenu;
FDown: Boolean;
FForceSameSize: Boolean;
FAllowAllUp: Boolean;
FGroupIndex: Integer;
FHotTrack: Boolean;
FHotFont: TFont;
FHotTrackFontOptions: TJvTrackFontOptions;
FOnDropDownMenu: TContextPopupEvent;
FDropArrow: Boolean;
FOnDropDownClose: TNotifyEvent;
function GetPattern: TBitmap;
procedure SetFlat(const Value: Boolean);
procedure SetDown(Value: Boolean);
procedure CMButtonPressed(var Msg: TCMButtonPressed); message CM_JVBUTTONPRESSED;
procedure CMForceSize(var Msg: TCMForceSize); message CM_FORCESIZE;
procedure CMSysColorChange(var Msg: TLMessage); message CM_SYSCOLORCHANGE;
procedure SetForceSameSize(const Value: Boolean);
procedure SetAllowAllUp(const Value: Boolean);
procedure SetGroupIndex(const Value: Integer);
procedure SetHotFont(const Value: TFont);
procedure SetHotTrackFontOptions(const Value: TJvTrackFontOptions);
procedure SetDropArrow(const Value: Boolean);
procedure SetDropDownMenu(const Value: TPopupMenu);
protected
procedure ButtonPressed(Sender: TJvCustomGraphicButton; AGroupIndex: Integer); virtual;
procedure ForceSize(Sender: TControl; AWidth, AHeight: Integer);
function DoDropDownMenu(Button: TMouseButton; Shift: TShiftState; X, Y: Integer): Boolean; virtual;
procedure DropDownClose;
procedure UpdateExclusive;
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseEnter(Control: TControl); override;
procedure MouseLeave(Control: TControl); override;
procedure Paint; override;
procedure PaintButton(ACanvas: TCanvas); virtual;
procedure PaintFrame(ACanvas: TCanvas); virtual;
function InsideBtn(X, Y: Integer): Boolean; virtual;
function WantKey(Key: Integer; Shift: TShiftState;
const KeyText: WideString): Boolean; override;
procedure EnabledChanged; override;
procedure FontChanged; override;
procedure RepaintBackground; virtual;
procedure TextChanged; override;
property AllowAllUp: Boolean read FAllowAllUp write SetAllowAllUp default False;
property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0;
property MouseStates: TJvButtonMouseStates read FStates write FStates default [];
property ForceSameSize: Boolean read FForceSameSize write SetForceSameSize default False;
property Pattern: TBitmap read GetPattern;
property Flat: Boolean read FFlat write SetFlat default False;
property HotTrack: Boolean read FHotTrack write FHotTrack default False;
property HotTrackFont: TFont read FHotFont write SetHotFont;
property HotTrackFontOptions: TJvTrackFontOptions read FHotTrackFontOptions write SetHotTrackFontOptions default
DefaultTrackFontOptions;
property Down: Boolean read FDown write SetDown default False;
property DropDownMenu: TPopupMenu read FDropDownMenu write SetDropDownMenu;
property DropArrow: Boolean read FDropArrow write SetDropArrow default False;
property OnDropDownMenu: TContextPopupEvent read FOnDropDownMenu write FOnDropDownMenu;
property OnDropDownClose: TNotifyEvent read FOnDropDownClose write FOnDropDownClose;
public
procedure Click; override;
procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure DrawDropArrow(ACanvas: TCanvas; ArrowRect: TRect); virtual;
end;
(******************** NOT CONVERTED
TJvCustomButton = class(TJvExButton)
private
FDropDownMenu: TPopupMenu;
FHotTrack: Boolean;
FHotFont: TFont;
FFontSave: TFont;
FWordWrap: Boolean;
FForceSameSize: Boolean;
FHotTrackFontOptions: TJvTrackFontOptions;
FOnDropDownMenu: TContextPopupEvent;
FDropArrow: Boolean;
procedure SetHotFont(const Value: TFont);
procedure SetWordWrap(const Value: Boolean);
procedure SetForceSameSize(const Value: Boolean);
procedure CMForceSize(var Msg: TCMForceSize); message CM_FORCESIZE;
procedure SetHotTrackFontOptions(const Value: TJvTrackFontOptions);
procedure SetDropArrow(const Value: Boolean);
procedure SetDropDownMenu(const Value: TPopupMenu);
protected
function DoDropDownMenu(X, Y: Integer): Boolean; virtual;
procedure ForceSize(Sender: TControl; AWidth, AHeight: Integer);
procedure MouseEnter(Control: TControl); override;
procedure MouseLeave(Control: TControl); override;
procedure FontChanged; override;
procedure CreateParams(var Params: TCreateParams); override;
function GetRealCaption: string; dynamic;
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
property WordWrap: Boolean read FWordWrap write SetWordWrap default True;
property ForceSameSize: Boolean read FForceSameSize write SetForceSameSize default False;
property DropArrow: Boolean read FDropArrow write SetDropArrow default False;
property DropDownMenu: TPopupMenu read FDropDownMenu write SetDropDownMenu;
property HotTrack: Boolean read FHotTrack write FHotTrack default False;
property HotTrackFont: TFont read FHotFont write SetHotFont;
property HotTrackFontOptions: TJvTrackFontOptions read FHotTrackFontOptions write SetHotTrackFontOptions default
DefaultTrackFontOptions;
property HintColor;
property OnParentColorChange;
property OnDropDownMenu: TContextPopupEvent read FOnDropDownMenu write FOnDropDownMenu;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Click;override;
procedure DrawDropArrow(Canvas: TCanvas; ArrowRect: TRect); virtual;
procedure SetBounds(ALeft: Integer; ATop: Integer; AWidth: Integer; AHeight: Integer); override;
end;
// TJvDropDownButton draws a DropDown button with the DropDown glyph
// (also themed). It ignores the properties Glyph and Flat
TJvDropDownButton = class(TSpeedButton)
protected
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
end;
******************** NOT CONVERTED *)
implementation
uses
Forms, JvJVCLUtils, LCLIntf, LCLType, SysUtils;
(******************** NOT CONVERTED
const
JvBtnLineSeparator = '|';
******************** NOT CONVERTED *)
var
GlobalPattern: TBitmap = nil;
function CreateBrushPattern: TBitmap;
var
X, Y: Integer;
begin
if GlobalPattern = nil then
begin
GlobalPattern := TBitmap.Create;
try
GlobalPattern.Width := 8; { must have this size }
GlobalPattern.Height := 8;
with GlobalPattern.Canvas do
begin
Brush.Style := bsSolid;
Brush.Color := clBtnFace;
FillRect(Rect(0, 0, GlobalPattern.Width, GlobalPattern.Height));
for Y := 0 to 7 do
for X := 0 to 7 do
if (Y mod 2) = (X mod 2) then { toggles between even/odd pixels }
Pixels[X, Y] := clWhite; { on even/odd rows }
end;
except
FreeAndNil(GlobalPattern);
end;
end;
Result := GlobalPattern;
end;
//=== { TJvCustomGraphicButton } =============================================
constructor TJvCustomGraphicButton.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := ControlStyle -
[csOpaque, csDoubleClicks ];
FStates := [];
SetBounds(0, 0, 40, 40);
FBuffer := TBitmap.Create;
FFlat := False;
FDropArrow := False;
FForceSameSize := False;
FHotFont := TFont.Create;
FHotTrackFontOptions := DefaultTrackFontOptions;
end;
destructor TJvCustomGraphicButton.Destroy;
begin
FBuffer.Free;
FHotFont.Free;
inherited Destroy;
end;
procedure TJvCustomGraphicButton.DrawDropArrow(ACanvas: TCanvas; ArrowRect: TRect);
var
I: Integer;
begin
if not Enabled then
ACanvas.Pen.Color := clInactiveCaption
else
ACanvas.Pen.Color := clWindowText;
for I := 0 to 3 do
begin
if ArrowRect.Left + I <= ArrowRect.Right - I then
begin
ACanvas.MoveTo(ArrowRect.Left + I, ArrowRect.Top + I);
ACanvas.LineTo(ArrowRect.Right - I, ArrowRect.Top + I);
end;
end;
end;
{ Handle speedkeys (Alt + key) }
function TJvCustomGraphicButton.WantKey(Key: Integer; Shift: TShiftState;
const KeyText: WideString): Boolean;
begin
Result := IsAccel(Key, Caption) and Enabled and (Shift * KeyboardShiftStates = [ssAlt]);
if Result then
Click
else
Result := inherited WantKey(Key, Shift, KeyText);
end;
procedure TJvCustomGraphicButton.EnabledChanged;
begin
inherited EnabledChanged;
if not Enabled then
FStates := [];
RepaintBackground;
end;
procedure TJvCustomGraphicButton.MouseEnter(Control: TControl);
begin
if csDesigning in ComponentState then
Exit;
if Enabled and not MouseOver then
begin
Include(FStates, bsMouseInside);
inherited MouseEnter(Control);
if Flat then
RepaintBackground;
if HotTrack then
Repaint;
end;
end;
procedure TJvCustomGraphicButton.MouseLeave(Control: TControl);
begin
if Enabled and MouseOver then
begin
Exclude(FStates, bsMouseInside);
inherited MouseLeave(Control);
if Flat then
RepaintBackground;
if HotTrack then
Repaint;
end;
end;
procedure TJvCustomGraphicButton.Paint;
var
ArrowRect: TRect;
begin
// FBuffer.Width := Width;
// FBuffer.Height := Height;
PaintFrame(Canvas);
PaintButton(Canvas);
if DropArrow and Assigned(DropDownMenu) then
begin
ArrowRect := Rect(Width - 16, Height div 2, Width - 9, Height div 2 + 9);
if bsMouseDown in FStates then
OffsetRect(ArrowRect, 1, 1);
DrawDropArrow(Canvas, ArrowRect);
end;
// BitBlt(Canvas.Handle, 0, 0, Width,Height, FBuffer.Canvas.Handle, 0, 0, SRCCOPY);
end;
procedure TJvCustomGraphicButton.PaintFrame(ACanvas: TCanvas);
begin
// do nothing
end;
procedure TJvCustomGraphicButton.PaintButton(ACanvas: TCanvas);
begin
if (bsMouseInside in FStates) and HotTrack then
ACanvas.Font := FHotFont
else
ACanvas.Font := Font;
end;
function TJvCustomGraphicButton.InsideBtn(X, Y: Integer): Boolean;
begin
Result := PtInRect(Rect(0, 0, Width, Height), Point(X, Y));
end;
procedure TJvCustomGraphicButton.MouseDown(Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
Tmp: TPoint;
begin
if not Enabled then
Exit;
inherited MouseDown(Button, Shift, X, Y);
if InsideBtn(X, Y) then
begin
FStates := [bsMouseDown, bsMouseInside];
RepaintBackground;
end;
SetCaptureControl(Self);
Tmp := ClientToScreen(Point(0, Height));
DoDropDownMenu(Button, Shift, Tmp.X, Tmp.Y);
end;
procedure TJvCustomGraphicButton.MouseMove(Shift: TShiftState;
X, Y: Integer);
begin
inherited MouseMove(Shift, X, Y);
if MouseCapture then
begin
if not InsideBtn(X, Y) then
begin
if bsMouseInside in FStates then
begin
Exclude(FStates, bsMouseInside);
RepaintBackground;
end;
end
else
begin
if not (bsMouseInside in FStates) then
begin
Include(FStates, bsMouseInside);
RepaintBackground;
end;
end;
end;
end;
procedure TJvCustomGraphicButton.MouseUp(Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if GetCaptureControl = Self then
ReleaseCapture;
if not Enabled then
Exit;
inherited MouseUp(Button, Shift, X, Y);
Exclude(FStates, bsMouseDown);
// 26.09.2007 - SESS:
// Update bsMouseInside flag also.
if not InsideBtn(X, Y) and (bsMouseInside in FStates) then
Exclude(FStates, bsMouseInside);
RepaintBackground;
end;
function TJvCustomGraphicButton.DoDropDownMenu(Button: TMouseButton; Shift: TShiftState; X, Y: Integer): Boolean;
var
Msg: TMsg;
Handled: Boolean;
begin
Result := (Button = mbLeft) and (DropDownMenu <> nil);
if Result then
begin
DropDownMenu.PopupComponent := Self;
Handled := False;
if Assigned(FOnDropDownMenu) then
FOnDropDownMenu(Self, Point(X, Y), Handled);
if not Handled then
DropDownMenu.Popup(X, Y)
else
Exit;
{ wait 'til menu is done }
while PeekMessage(Msg, 0, LM_MOUSEFIRST, LM_MOUSELAST, PM_REMOVE) do
{nothing};
{ release button }
MouseUp(Button, Shift, X, Y);
DropDownClose;
end;
end;
procedure TJvCustomGraphicButton.SetFlat(const Value: Boolean);
begin
if FFlat <> Value then
begin
FFlat := Value;
if FFlat then
ControlStyle := ControlStyle - [csOpaque]
else
ControlStyle := ControlStyle + [csOpaque];
RepaintBackground;
end;
end;
procedure TJvCustomGraphicButton.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if (Operation = opRemove) and (AComponent = DropDownMenu) then
DropDownMenu := nil;
end;
procedure TJvCustomGraphicButton.SetDown(Value: Boolean);
begin
if GroupIndex = 0 then
Value := False;
if FDown <> Value then
begin
if FDown and not AllowAllUp then
Exit;
FDown := Value;
UpdateExclusive;
Invalidate;
end;
end;
procedure TJvCustomGraphicButton.SetForceSameSize(const Value: Boolean);
begin
if FForceSameSize <> Value then
begin
FForceSameSize := Value;
if FForceSameSize then
SetBounds(Left, Top, Width, Height);
end;
end;
procedure TJvCustomGraphicButton.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
var
Form: TCustomForm;
Msg: TCMForceSize;
begin
inherited SetBounds(ALeft, ATop, AWidth, AHeight);
if ForceSameSize then
begin
Form := GetParentForm(Self);
if Assigned(Form) then
begin
Msg.Msg := CM_FORCESIZE;
Msg.Sender := Self;
Msg.NewSize.X := AWidth;
Msg.NewSize.Y := AHeight;
Form.Broadcast(Msg);
end;
end;
end;
procedure TJvCustomGraphicButton.CMForceSize(var Msg: TCMForceSize);
begin
with Msg do
ForceSize(Sender, NewSize.x, NewSize.y);
end;
function TJvCustomGraphicButton.GetPattern: TBitmap;
begin
Result := CreateBrushPattern;
end;
procedure TJvCustomGraphicButton.SetAllowAllUp(const Value: Boolean);
begin
if FAllowAllUp <> Value then
begin
FAllowAllUp := Value;
UpdateExclusive;
end;
end;
procedure TJvCustomGraphicButton.SetGroupIndex(const Value: Integer);
begin
if FGroupIndex <> Value then
begin
FGroupIndex := Value;
UpdateExclusive;
end;
end;
procedure TJvCustomGraphicButton.UpdateExclusive;
var
Msg: TCMButtonPressed;
begin
if (GroupIndex <> 0) and (Parent <> nil) then
begin
Msg.Msg := CM_JVBUTTONPRESSED;
Msg.Index := GroupIndex;
Msg.Control := Self;
Msg.Result := 0;
Parent.Broadcast(Msg);
end;
end;
procedure TJvCustomGraphicButton.CMButtonPressed(var Msg: TCMButtonPressed);
begin
ButtonPressed(TJvCustomGraphicButton(Msg.Control), Msg.Index);
end;
procedure TJvCustomGraphicButton.SetHotFont(const Value: TFont);
begin
FHotFont.Assign(Value);
end;
procedure TJvCustomGraphicButton.SetHotTrackFontOptions(const Value: TJvTrackFontOptions);
begin
if FHotTrackFontOptions <> Value then
begin
FHotTrackFontOptions := Value;
UpdateTrackFont(HotTrackFont, Font, HotTrackFontOptions);
end;
end;
procedure TJvCustomGraphicButton.SetDropArrow(const Value: Boolean);
begin
if FDropArrow <> Value then
begin
FDropArrow := Value;
Invalidate;
end;
end;
procedure TJvCustomGraphicButton.SetDropDownMenu(const Value: TPopupMenu);
begin
if FDropDownMenu <> Value then
begin
FDropDownMenu := Value;
if DropArrow then
Invalidate;
end;
end;
procedure TJvCustomGraphicButton.CMSysColorChange(var Msg: TLMessage);
begin
inherited;
RepaintBackground;
end;
procedure TJvCustomGraphicButton.FontChanged;
begin
inherited FontChanged;
UpdateTrackFont(HotTrackFont, Font, HotTrackFontOptions);
end;
procedure TJvCustomGraphicButton.TextChanged;
begin
inherited TextChanged;
RepaintBackground;
end;
procedure TJvCustomGraphicButton.Click;
begin
if GroupIndex <> 0 then
begin
if AllowAllUp then
Down := not Down
else
Down := True;
end;
try
inherited Click;
except
// Mantis 3097: In case there is an exception, we ensure here that the
// button is not left "down", and we reraise the exception as we can't
// handle it and don't want to ignore it.
Exclude(FStates, bsMouseDown);
RepaintBackground;
raise;
end;
end;
procedure TJvCustomGraphicButton.ButtonPressed(Sender: TJvCustomGraphicButton;
AGroupIndex: Integer);
begin
if AGroupIndex = GroupIndex then
if Sender <> Self then
begin
if Sender.Down and Down then
begin
FDown := False;
Exclude(FStates, bsMouseDown);
RepaintBackground;
end;
FAllowAllUp := Sender.AllowAllUp;
end;
end;
procedure TJvCustomGraphicButton.ForceSize(Sender: TControl; AWidth, AHeight: Integer);
begin
if Sender <> Self then
inherited SetBounds(Left, Top, AWidth, AHeight);
end;
(******************** NOT CONVERTED
//=== { TJvCustomButton } ====================================================
constructor TJvCustomButton.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FDropArrow := False;
FHotTrack := False;
FHotFont := TFont.Create;
FFontSave := TFont.Create;
// ControlStyle := ControlStyle + [csAcceptsControls];
FWordWrap := True;
FForceSameSize := False;
FHotTrackFontOptions := DefaultTrackFontOptions;
end;
destructor TJvCustomButton.Destroy;
begin
FHotFont.Free;
FFontSave.Free;
inherited Destroy;
end;
procedure TJvCustomButton.Click;
var
Tmp: TPoint;
begin
// Call ClientToScreen before the inherited Click as the OnClick handler might
// reset the parent, which is needed by ClientToScreen.
Tmp := ClientToScreen(Point(0, Height));
inherited Click;
DoDropDownMenu(Tmp.X, Tmp.Y);
end;
procedure TJvCustomButton.DrawDropArrow(Canvas: TCanvas; ArrowRect: TRect);
var
I: Integer;
begin
if not Enabled then
Canvas.Pen.Color := clInactiveCaption
else
Canvas.Pen.Color := clWindowText;
for I := 0 to (ArrowRect.Bottom - ArrowRect.Top) do
begin
if ArrowRect.Left + I <= ArrowRect.Right - I then
begin
Canvas.MoveTo(ArrowRect.Left + I, ArrowRect.Top + I);
Canvas.LineTo(ArrowRect.Right - I, ArrowRect.Top + I);
end;
end;
end;
procedure TJvCustomButton.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.Style := Params.Style or BS_MULTILINE;
end;
procedure TJvCustomButton.SetHotTrackFontOptions(const Value: TJvTrackFontOptions);
begin
if FHotTrackFontOptions <> Value then
begin
FHotTrackFontOptions := Value;
UpdateTrackFont(HotTrackFont, Font, HotTrackFontOptions);
end;
end;
procedure TJvCustomButton.SetDropArrow(const Value: Boolean);
begin
if FDropArrow <> Value then
begin
FDropArrow := Value;
Invalidate;
end;
end;
procedure TJvCustomButton.SetHotFont(const Value: TFont);
begin
FHotFont.Assign(Value);
end;
procedure TJvCustomButton.SetDropDownMenu(const Value: TPopupMenu);
begin
if FDropDownMenu <> Value then
begin
FDropDownMenu := Value;
if DropArrow then
Invalidate;
end;
end;
procedure TJvCustomButton.MouseEnter(Control: TControl);
begin
if not MouseOver then
begin
if FHotTrack then
begin
FFontSave.Assign(Font);
Font.Assign(FHotFont);
end;
inherited MouseEnter(Control);
end;
end;
procedure TJvCustomButton.MouseLeave(Control: TControl);
begin
if MouseOver then
begin
if FHotTrack then
Font.Assign(FFontSave);
inherited MouseLeave(Control);
end;
end;
procedure TJvCustomButton.FontChanged;
begin
inherited FontChanged;
UpdateTrackFont(HotTrackFont, Font, HotTrackFontOptions);
end;
function TJvCustomButton.GetRealCaption: string;
begin
if WordWrap then
Result := StringReplace(Caption, JvBtnLineSeparator, Lf, [rfReplaceAll])
else
Result := Caption;
end;
procedure TJvCustomButton.SetWordWrap(const Value: Boolean);
begin
if FWordWrap <> Value then
begin
FWordWrap := Value;
Invalidate;
end;
end;
procedure TJvCustomButton.SetForceSameSize(const Value: Boolean);
begin
if FForceSameSize <> Value then
begin
FForceSameSize := Value;
if FForceSameSize then
SetBounds(Left, Top, Width, Height);
end;
end;
procedure TJvCustomButton.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
var
Form: TCustomForm;
Msg: TCMForceSize;
begin
inherited SetBounds(ALeft, ATop, AWidth, AHeight);
if ForceSameSize then
begin
Form := GetParentForm(Self);
if Assigned(Form) then
begin
Msg.Msg := CM_FORCESIZE;
Msg.Sender := Self;
Msg.NewSize.X := AWidth;
Msg.NewSize.Y := AHeight;
Form.Broadcast(Msg);
end;
end;
end;
procedure TJvCustomButton.CMForceSize(var Msg: TCMForceSize);
begin
with Msg do
ForceSize(Sender, NewSize.x, NewSize.y);
end;
procedure TJvCustomButton.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if (Operation = opRemove) and (AComponent = FDropDownMenu) then
DropDownMenu := nil;
end;
******************** NOT CONVERTED *)
procedure TJvCustomGraphicButton.RepaintBackground;
var
R: TRect;
begin
if (Parent <> nil) and Parent.HandleAllocated then
begin
R := BoundsRect;
InvalidateRect(Parent.Handle, @R, True);
end;
Repaint;
end;
(******************** NOT CONVERTED
procedure TJvCustomButton.ForceSize(Sender: TControl; AWidth, AHeight: Integer);
begin
if Sender <> Self then
inherited SetBounds(Left, Top, AWidth, AHeight);
end;
function TJvCustomButton.DoDropDownMenu(X, Y: Integer): Boolean;
var
Msg: TMsg;
Handled: Boolean;
begin
Result := (DropDownMenu <> nil);
if Result then
begin
DropDownMenu.PopupComponent := Self;
case DropDownMenu.Alignment of
paRight:
Inc(X, Width);
paCenter:
Inc(X, Width div 2);
end;
Handled := False;
if Assigned(FOnDropDownMenu) then
FOnDropDownMenu(Self, Point(X, Y), Handled);
if not Handled then
DropDownMenu.Popup(X, Y)
else
Exit;
{ wait 'til menu is done }
while PeekMessage(Msg, 0, WM_MOUSEFIRST, WM_MOUSELAST, PM_REMOVE) do
{nothing};
end;
end;
//=== { TJvDropDownButton } ==================================================
constructor TJvDropDownButton.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Width := 16;
Height := 16;
end;
procedure TJvDropDownButton.Paint;
var
PaintRect: TRect;
DrawFlags: Integer;
DC: HDC;
Bmp: TBitmap;
begin
// adjust FState and FDragging
DC := Canvas.Handle;
Bmp := TBitmap.Create;
try
Bmp.Width := 1;
Bmp.Height := 1;
Canvas.Handle := Bmp.Canvas.Handle;
try
inherited Paint;
finally
Canvas.Handle := DC;
end;
finally
Bmp.Free;
end;
PaintRect := Rect(0, 0, Width, Height);
DrawFlags := DFCS_SCROLLCOMBOBOX or DFCS_ADJUSTRECT;
if FState in [bsDown, bsExclusive] then
DrawFlags := DrawFlags or DFCS_PUSHED;
{$IFDEF JVCLThemesEnabled}
if ThemeServices.ThemesEnabled then
DrawThemedFrameControl(Self, Canvas.Handle, PaintRect, DFC_SCROLL, DrawFlags)
else
{$ENDIF JVCLThemesEnabled}
begin
DrawFrameControl(Canvas.Handle, PaintRect, DFC_SCROLL, DrawFlags);
end;
end;
******************** NOT CONVERTED *)
procedure TJvCustomGraphicButton.DropDownClose;
begin
if Assigned(FOnDropDownClose) then
FOnDropDownClose(Self);
end;
finalization
FreeAndNil(GlobalPattern);
end.