1094 lines
32 KiB
ObjectPascal
1094 lines
32 KiB
ObjectPascal
unit uMain;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
interface
|
|
|
|
uses
|
|
BGRABitmap, BGRABitmapTypes, Classes, SysUtils, FileUtil, Forms, Controls,
|
|
Graphics, StdCtrls, ExtCtrls, Menus, Dialogs, ActnList, BGRAVirtualScreen,
|
|
BCButton, BCPanel, BGRAImageList, BGRAResizeSpeedButton, LCLType, LCLIntf,
|
|
{$ifdef Windows}
|
|
Windows,
|
|
{$endif}
|
|
XMLConf, SynMemo, SynEdit;
|
|
|
|
type
|
|
TBorderPos = (bpTopLeft, bpTopRight, bpBottomLeft,
|
|
bpBottomRight, bpTop, bpBottom,bpLeft,bpRight,bpnone);
|
|
|
|
{ TfrmMain }
|
|
|
|
TfrmMain = class(TForm)
|
|
BCButton1: TBCButton;
|
|
BCButton13: TBCButton;
|
|
BCButton14: TBCButton;
|
|
BCButton15: TBCButton;
|
|
BCButton6: TBCButton;
|
|
BCButton8: TBCButton;
|
|
BCPanel1: TBCPanel;
|
|
BCPanel2: TBCPanel;
|
|
btnClipboard: TBCButton;
|
|
btnClose: TBCButton;
|
|
btnColors: TBCButton;
|
|
btnCopy: TBCButton;
|
|
btnCut: TBCButton;
|
|
btnExit: TBCButton;
|
|
btnFileMenu: TBCButton;
|
|
btnFileMenuClose: TBGRAResizeSpeedButton;
|
|
btnFileNew: TBCButton;
|
|
btnFileOpen: TBCButton;
|
|
btnFileSave: TBCButton;
|
|
btnHelp: TBCButton;
|
|
btnHide: TBCButton;
|
|
btnMaximize: TBCButton;
|
|
btnMinimize: TBCButton;
|
|
btnNew: TBCButton;
|
|
btnOpen: TBCButton;
|
|
btnPaste: TBCButton;
|
|
btnPreview: TBCButton;
|
|
btnPrint: TBCButton;
|
|
btnSave: TBCButton;
|
|
btnTabEdit: TBCButton;
|
|
btnTabHome: TBCButton;
|
|
btnTabSettings: TBCButton;
|
|
btnTool1: TBCButton;
|
|
btnTool2: TBCButton;
|
|
btnTool3: TBCButton;
|
|
FileMenu: TBCPanel;
|
|
ImageList16: TBGRAImageList;
|
|
ImageList16White: TBGRAImageList;
|
|
ImageList32: TBGRAImageList;
|
|
ImageListColors: TBGRAImageList;
|
|
imgResize: TImage;
|
|
Label2: TLabel;
|
|
lblTitle: TBCButton;
|
|
mnuColorChange: TMenuItem;
|
|
mnuColorGreen: TMenuItem;
|
|
mnuColorLiteBlue: TMenuItem;
|
|
mnuColorOrange: TMenuItem;
|
|
mnuColorPetrol: TMenuItem;
|
|
mnuColorPurple: TMenuItem;
|
|
mnuColorRed: TMenuItem;
|
|
pnlEdit2: TBCPanel;
|
|
pnlEditClipboard: TBCPanel;
|
|
pnlHomeCommand: TBCPanel;
|
|
pnlHomeExit: TBCPanel;
|
|
pnlSettings2: TBCPanel;
|
|
pnlSettingsUI: TBCPanel;
|
|
popColors: TPopupMenu;
|
|
Splitter1: TSplitter;
|
|
SynMemo1: TSynMemo;
|
|
vsBody: TBGRAVirtualScreen;
|
|
vsBorder: TBGRAVirtualScreen;
|
|
vsForm: TBGRAVirtualScreen;
|
|
vsTab: TBGRAVirtualScreen;
|
|
vsTitle: TBGRAVirtualScreen;
|
|
XMLConfigMain: TXMLConfig;
|
|
procedure btnTool1Click(Sender: TObject);
|
|
procedure btnTool2Click(Sender: TObject);
|
|
procedure btnTool3Click(Sender: TObject);
|
|
procedure SynMemo1MouseDown(Sender: TObject; Button: TMouseButton;
|
|
Shift: TShiftState; X, Y: Integer);
|
|
procedure btnHideClick(Sender: TObject);
|
|
procedure btnSaveClick(Sender: TObject);
|
|
procedure btnColorsMouseWheel(Sender: TObject; Shift: TShiftState;
|
|
WheelDelta: integer; MousePos: TPoint; var Handled: boolean);
|
|
procedure btnCutClick(Sender: TObject);
|
|
procedure btnPrintClick(Sender: TObject);
|
|
procedure btnCopyClick(Sender: TObject);
|
|
procedure btnPasteClick(Sender: TObject);
|
|
procedure btnPreviewClick(Sender: TObject);
|
|
procedure btnClipboardClick(Sender: TObject);
|
|
procedure btnCloseClick(Sender: TObject);
|
|
procedure btnExitClick(Sender: TObject);
|
|
procedure btnMaximizeClick(Sender: TObject);
|
|
procedure btnMinimizeClick(Sender: TObject);
|
|
procedure btnNewClick(Sender: TObject);
|
|
procedure btnFileMenuCloseMouseDown(Sender: TObject; Button: TMouseButton;
|
|
Shift: TShiftState; X, Y: integer);
|
|
procedure btnFileMenuMouseDown(Sender: TObject; Button: TMouseButton;
|
|
Shift: TShiftState; X, Y: integer);
|
|
procedure btnHelpMouseDown(Sender: TObject; Button: TMouseButton;
|
|
Shift: TShiftState; X, Y: integer);
|
|
procedure btnOpenClick(Sender: TObject);
|
|
procedure btnTabHomeMouseDown(Sender: TObject; Button: TMouseButton;
|
|
Shift: TShiftState; X, Y: integer);
|
|
procedure FormActivate(Sender: TObject);
|
|
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
|
|
procedure FormCreate(Sender: TObject);
|
|
procedure FormWindowStateChange(Sender: TObject);
|
|
procedure imgResizeMouseDown(Sender: TObject; Button: TMouseButton;
|
|
Shift: TShiftState; X, Y: integer);
|
|
procedure imgResizeMouseMove(Sender: TObject; Shift: TShiftState;
|
|
X, Y: integer);
|
|
procedure Memo1MouseDown(Sender: TObject; Button: TMouseButton;
|
|
Shift: TShiftState; X, Y: integer);
|
|
procedure mnuColorChangeClick(Sender: TObject);
|
|
procedure vsBodyRedraw(Sender: TObject; Bitmap: TBGRABitmap);
|
|
procedure vsBorderResize(Sender: TObject);
|
|
procedure vsFormRedraw(Sender: TObject; Bitmap: TBGRABitmap);
|
|
procedure vsTabMouseDown(Sender: TObject; Button: TMouseButton;
|
|
Shift: TShiftState; X, Y: integer);
|
|
procedure vsTabRedraw(Sender: TObject; Bitmap: TBGRABitmap);
|
|
procedure vsTitleDblClick(Sender: TObject);
|
|
procedure vsTitleMouseDown(Sender: TObject; Button: TMouseButton;
|
|
Shift: TShiftState; X, Y: integer);
|
|
procedure vsTitleMouseMove(Sender: TObject; Shift: TShiftState; X, Y: integer);
|
|
procedure vsTitleRedraw(Sender: TObject; Bitmap: TBGRABitmap);
|
|
private
|
|
{ private declarations }
|
|
FormStyleModifyDone: boolean;
|
|
// procedure CreateParams(VAR Params: TCreateParams); override;
|
|
// procedure WMNCHitTest(VAR Msg: TWMNcHitTest); message WM_NCHITTEST;
|
|
procedure ColorChange(Sender: TObject);
|
|
procedure MoveAnimation(moveobj: TComponent; leftfrom: integer;
|
|
leftto: integer; topfrom: integer; topto: integer);
|
|
public
|
|
{ public declarations }
|
|
isFocused: Boolean;
|
|
procedure AppActivate(Sender: TObject);
|
|
procedure AppDeactivate(Sender: TObject);
|
|
constructor Create(TheOwner: TComponent); override;
|
|
end;
|
|
|
|
var
|
|
frmMain: TfrmMain;
|
|
TabColor: string;
|
|
MausPos: TPoint;
|
|
xx, yy: integer;
|
|
d: boolean = False;
|
|
|
|
PtSize: TPoint;
|
|
DoResize: boolean;
|
|
|
|
implementation
|
|
|
|
{$R *.lfm}
|
|
|
|
uses
|
|
uRibbon; {, uResize;}
|
|
|
|
{ TfrmMain }
|
|
|
|
{procedure TfrmMain.CreateParams(VAR Params: TCreateParams);
|
|
begin
|
|
Inherited CreateParams(Params);
|
|
WITH Params DO
|
|
Style := (Style OR WS_POPUP) AND (NOT WS_DLGFRAME);
|
|
{or... Style := Style + WS_POPUP - WS_DLGFRAME; which is the
|
|
equivalent to the above statement}
|
|
end;
|
|
|
|
procedure TfrmMain.WMNCHitTest(var msg: TWMNCHitTest);
|
|
begin
|
|
inherited;
|
|
if (msg.Result = htClient) then
|
|
msg.Result := htCaption;
|
|
end;
|
|
}
|
|
|
|
{ Dropshadow Function places a shadow behind a Form with Borderstyle=bsNone; }
|
|
{http://www.delphipraxis.net/32245-dropshadow.html
|
|
Am bestem im Konstruktor aufzurufen
|
|
****Windows OS only!****
|
|
|
|
function DropShadow(const Handle: THandle): boolean;
|
|
|
|
function IsXP: boolean;
|
|
begin
|
|
Result := (Win32Platform = VER_PLATFORM_WIN32_NT) and
|
|
((Win32MajorVersion > 5) or ((Win32MajorVersion = 5) and
|
|
(Win32MinorVersion >= 1)));
|
|
end;
|
|
|
|
const
|
|
SPI_SETDROPSHADOW = $1025;
|
|
CS_DROPSHADOW = $00020000;
|
|
begin
|
|
Result := IsXP and SystemParametersInfo(SPI_SETDROPSHADOW, 0, Pointer(True), 0) and
|
|
(SetClassLong(Handle, GCL_STYLE, GetClassLong(Handle, GCL_STYLE) or
|
|
CS_DROPSHADOW) <> 0);
|
|
end;
|
|
}
|
|
|
|
{ For whatever reason the following doesnt work? Form is still painted w/o shadow!
|
|
Function Dropshadow() works though!
|
|
|
|
procedure TfrmMain.CreateParams(var Params: TCreateParams);
|
|
const
|
|
SPI_SETDROPSHADOW = $1025;
|
|
CS_DROPSHADOW = $00020000;
|
|
begin
|
|
inherited;
|
|
if CheckWin32Version(5, 1) then
|
|
begin
|
|
SystemParametersInfo(SPI_SETDROPSHADOW, 0, Pointer(True), 0);
|
|
Params.WindowClass.style := Params.WindowClass.style or CS_DROPSHADOW;
|
|
end;
|
|
end;
|
|
}
|
|
|
|
constructor TfrmMain.Create(TheOwner: TComponent);
|
|
begin
|
|
inherited Create(TheOwner);
|
|
Application.OnDeactivate:=@AppDeactivate;
|
|
Application.OnActivate:=@AppActivate;
|
|
end;
|
|
|
|
procedure TfrmMain.AppDeactivate(Sender: TObject);
|
|
begin
|
|
isFocused := FALSE;
|
|
vsBorder.Color:=$00838383;
|
|
lblTitle.GlobalOpacity:=125;
|
|
btnMinimize.GlobalOpacity:=125;
|
|
btnMaximize.GlobalOpacity:=125;
|
|
btnClose.GlobalOpacity:=125;
|
|
btnTool1.GlobalOpacity:=125;
|
|
btnTool2.GlobalOpacity:=125;
|
|
btnTool3.GlobalOpacity:=125;
|
|
end;
|
|
|
|
procedure TfrmMain.AppActivate(Sender: TObject);
|
|
begin
|
|
isFocused := TRUE;
|
|
vsBorder.Color:=uRibbon.MainColor;
|
|
lblTitle.GlobalOpacity:=255;
|
|
btnMinimize.GlobalOpacity:=255;
|
|
btnMaximize.GlobalOpacity:=255;
|
|
btnClose.GlobalOpacity:=255;
|
|
btnTool1.GlobalOpacity:=255;
|
|
btnTool2.GlobalOpacity:=255;
|
|
btnTool3.GlobalOpacity:=255;
|
|
end;
|
|
|
|
|
|
procedure TfrmMain.FormCreate(Sender: TObject);
|
|
begin
|
|
{ Features presently implemented as of 06.04.2016
|
|
- Moveable and Sizeable Form without Border and Caption
|
|
- Extended drag area
|
|
- Form has shadow (CS_DROPSHADOW)
|
|
- Max- / Minimizing of Form
|
|
- Doubleclick on Title maximizes / restores Form
|
|
- RightClick on Title shows Systemmenu
|
|
- Form indicates whether it has focus or not
|
|
- Quick Access Toolbuttons
|
|
- XML storage of some properties (Form size, position and colors)
|
|
- Custom painting of images and caption on Buttons (Windows ok, but not sure it works on Linux?)
|
|
- Slide-in and slide-out effect of Menu (Windows ok, needs finetuning on Linux, Z-Order?)
|
|
}
|
|
{ TODO : Presently cant find a working way to use the sizeable system border }
|
|
{ DONE : Rightclick on vsTitle to show SystemMenu }
|
|
{ DONE : Replace Icon and Caption by customizable Quick Access Toolbuttons on vsTitle }
|
|
{ DONE : Line break in custom drawn text on Buttons }
|
|
{ TODO : Radio Button, Drop Down Example on vsBody }
|
|
{ TODO : Implementation of File Menu }
|
|
{ TODO : Offer classical menus as an option to user }
|
|
{ TODO : All color definitions to be shifted to uRibbon.pas }
|
|
{ TODO : Linux - Slide effect of Menu needs finetuning }
|
|
{ TODO : Linux - Custom painting on Buttons needs to be verified }
|
|
|
|
{ Create the XML config component to store some settings }
|
|
XMLConfigMain := TXMLConfig.Create(nil);
|
|
XMLConfigMain.Filename := ChangeFileExt(Application.ExeName, '.xml');
|
|
|
|
{ Set BorderStyle from bsSingle to bsNone to get a Form w/o Title Bar }
|
|
BorderStyle := bsNone;
|
|
|
|
{ Place a shadow behind the Form }
|
|
{$ifdef Windows}
|
|
// DropShadow(Handle); // Better to use SetClasslong() as follows (Windows OS only):
|
|
{Handle = all Forms, frmMain.Handle = only frmMain Form
|
|
SetClassLong(Handle, GCL_STYLE, GetClassLong(Handle, GCL_STYLE) or CS_DROPSHADOW);
|
|
}
|
|
SetClassLong(frmMain.Handle, GCL_STYLE, GetClassLong(frmMain.Handle, GCL_STYLE) or CS_DROPSHADOW);
|
|
{ Following can be used on Windows < 8
|
|
// Soner: Füge die nächsten 3 Zeilen hinzu ------------------------------------
|
|
// vergiß uses LCLIntf; nicht.
|
|
SetWindowLong(Handle,GWL_STYLE, GetWindowLong(Handle, GWL_STYLE) or WS_THICKFRAME);
|
|
ClientHeight:=Height;
|
|
Refresh;
|
|
}
|
|
{$else}
|
|
// Something to be done for OS <> Windows?
|
|
{$endif}
|
|
|
|
{ Set Doublebuffered property to reduce flicker. }
|
|
Doublebuffered := True;
|
|
// vsBody.DoubleBuffered:=True;
|
|
// vsTab.DoubleBuffered:=True;
|
|
// vsForm.DoubleBuffered:=True;
|
|
// vsTitle.DoubleBuffered:=True;
|
|
// vsBorder.DoubleBuffered:=True;
|
|
|
|
{ Read and set the XML config values }
|
|
Position := poDesigned;
|
|
Top := StrToInt(XMLConfigMain.GetValue('FormTop', '250'));
|
|
Left := StrToInt(XMLConfigMain.GetValue('FormLeft', '550'));
|
|
Height := StrToInt(XMLConfigMain.GetValue('FormHeight', '350'));
|
|
Width := StrToInt(XMLConfigMain.GetValue('FormWidth', '600'));
|
|
|
|
{ Set Min Height and Min Width of Form to prevent vanishing of Form }
|
|
Constraints.MinHeight := 200;
|
|
Constraints.MinWidth := 250;
|
|
|
|
{ Set Colors }
|
|
|
|
{ Colors of Body Buttons are the same for all styles }
|
|
uRibbon.BtnFntColor := $00696969; // Button Font Color
|
|
uRibbon.BtnNormalColor := $00F1F1F1; // Button Normal
|
|
uRibbon.BtnHoverColor := $00cdcdcd; // Button Hover
|
|
uRibbon.BtnClickedColor := $00b0b0b0; // Button Clicked
|
|
|
|
TabColor := XMLConfigMain.GetValue('Color', 'blue');
|
|
|
|
{ Call ColorChange() to set colors }
|
|
ColorChange(self);
|
|
|
|
StyleRibbonBody(pnlHomeCommand);
|
|
StyleRibbonBody(pnlHomeExit);
|
|
StyleRibbonBody(pnlSettingsUI);
|
|
StyleRibbonBody(pnlEditClipboard);
|
|
|
|
{ to be done, let the user decide which UI he likes to use
|
|
// Set UI to Ribbon, otherwise use Classical Menus
|
|
if StrToInt(XMLConfigMain.GetValue('UI', ''))=1 then
|
|
SetUserInterface(false)
|
|
else
|
|
SetUserInterface(true);
|
|
}
|
|
|
|
{ Showing Form.Caption in Title bar }
|
|
lblTitle.Caption := frmMain.Caption;
|
|
end;
|
|
|
|
procedure TfrmMain.FormWindowStateChange(Sender: TObject);
|
|
begin
|
|
if WindowState = wsMaximized then
|
|
begin
|
|
with Screen.WorkAreaRect do
|
|
SetBounds(Left, Top, Right - Left, Bottom - Top);
|
|
end;
|
|
end;
|
|
|
|
procedure TfrmMain.imgResizeMouseDown(Sender: TObject; Button: TMouseButton;
|
|
Shift: TShiftState; X, Y: integer);
|
|
begin
|
|
PtSize.y := Mouse.CursorPos.y - Top - Height;
|
|
PtSize.x := Mouse.CursorPos.x - Left - Width;
|
|
end;
|
|
|
|
procedure TfrmMain.imgResizeMouseMove(Sender: TObject; Shift: TShiftState;
|
|
X, Y: integer);
|
|
begin
|
|
if ssLeft in shift then
|
|
begin
|
|
Width := Mouse.CursorPos.x - Left - PtSize.x;
|
|
Height := Mouse.CursorPos.y - Top - PtSize.y;
|
|
end;
|
|
end;
|
|
|
|
procedure TfrmMain.Memo1MouseDown(Sender: TObject; Button: TMouseButton;
|
|
Shift: TShiftState; X, Y: integer);
|
|
begin
|
|
{Hide Menu if not fixed}
|
|
if vsBody.Tag = 1 then
|
|
vsBody.Hide;
|
|
end;
|
|
|
|
procedure TfrmMain.SynMemo1MouseDown(Sender: TObject; Button: TMouseButton;
|
|
Shift: TShiftState; X, Y: Integer);
|
|
begin
|
|
{Hide Menu if not fixed}
|
|
if vsBody.Tag = 1 then
|
|
vsBody.Hide;
|
|
end;
|
|
|
|
procedure TfrmMain.ColorChange(Sender: TObject);
|
|
begin
|
|
case TabColor of
|
|
'blue':
|
|
begin
|
|
// TabColor := 'blue';
|
|
uRibbon.MainColor := $009A572A;
|
|
uRibbon.TabFntColor := $009A572A;
|
|
uRibbon.TabNormalColor := $009A572A;
|
|
uRibbon.TabHoverColor := $00b66d3e;
|
|
uRibbon.TabClickedColor := $00F1F1F1;
|
|
uRibbon.ToolNormalColor := $009A572A;
|
|
uRibbon.ToolHoverColor := $00b66d3e;
|
|
uRibbon.ToolClickedColor := $00784012;
|
|
end;
|
|
'green':
|
|
begin
|
|
// TabColor := 'green';
|
|
uRibbon.MainColor := $00477422;
|
|
uRibbon.TabFntColor := $00477422;
|
|
uRibbon.TabNormalColor := $00477422;
|
|
uRibbon.TabHoverColor := $00679443;
|
|
uRibbon.TabClickedColor := $00F1F1F1;
|
|
uRibbon.ToolNormalColor := $00477422;
|
|
uRibbon.ToolHoverColor := $00679443;
|
|
uRibbon.ToolClickedColor := $00395d1b;
|
|
end;
|
|
'red':
|
|
begin
|
|
// TabColor := 'red';
|
|
uRibbon.MainColor := $003a37a4;
|
|
uRibbon.TabFntColor := $003a37a4;
|
|
uRibbon.TabNormalColor := $003a37a4;
|
|
uRibbon.TabHoverColor := $005956c7;
|
|
uRibbon.TabClickedColor := $00F1F1F1;
|
|
uRibbon.ToolNormalColor := $003a37a4;
|
|
uRibbon.ToolHoverColor := $005956c7;
|
|
uRibbon.ToolClickedColor := $002e2c83;
|
|
end;
|
|
'orange':
|
|
begin
|
|
// TabColor := 'orange';
|
|
uRibbon.MainColor := $002a47b7;
|
|
uRibbon.TabFntColor := $002a47b7;
|
|
uRibbon.TabNormalColor := $002a47b7;
|
|
uRibbon.TabHoverColor := $003959dc;
|
|
uRibbon.TabClickedColor := $00F1F1F1;
|
|
uRibbon.ToolNormalColor := $002a47b7;
|
|
uRibbon.ToolHoverColor := $003959dc;
|
|
uRibbon.ToolClickedColor := $00223992;
|
|
end;
|
|
'liteblue':
|
|
begin
|
|
// TabColor := 'lightblue';
|
|
uRibbon.MainColor := $00c77301;
|
|
uRibbon.TabFntColor := $00c77301;
|
|
uRibbon.TabNormalColor := $00c77301;
|
|
uRibbon.TabHoverColor := $00d48a2a;
|
|
uRibbon.TabClickedColor := $00F1F1F1;
|
|
uRibbon.ToolNormalColor := $00c77301;
|
|
uRibbon.ToolHoverColor := $00d48a2a;
|
|
uRibbon.ToolClickedColor := $009f5c01;
|
|
end;
|
|
'petrol':
|
|
begin
|
|
// TabColor := 'petrol';
|
|
uRibbon.MainColor := $00728200;
|
|
uRibbon.TabFntColor := $00728200;
|
|
uRibbon.TabNormalColor := $00728200;
|
|
uRibbon.TabHoverColor := $00839900;
|
|
uRibbon.TabClickedColor := $00F1F1F1;
|
|
uRibbon.ToolNormalColor := $00728200;
|
|
uRibbon.ToolHoverColor := $00839900;
|
|
uRibbon.ToolClickedColor := $005f6b1a;
|
|
end;
|
|
'purple':
|
|
begin
|
|
// TabColor := 'purple';
|
|
uRibbon.MainColor := $007b3980;
|
|
uRibbon.TabFntColor := $007b3980;
|
|
uRibbon.TabNormalColor := $007b3980;
|
|
uRibbon.TabHoverColor := $009e56a3;
|
|
uRibbon.TabClickedColor := $00F1F1F1;
|
|
uRibbon.ToolNormalColor := $007b3980;
|
|
uRibbon.ToolHoverColor := $009e56a3;
|
|
uRibbon.ToolClickedColor := $00622e66;
|
|
end;
|
|
end;
|
|
RibbonMenu(btnFileMenu);
|
|
|
|
RibbonTab(btnTabHome);
|
|
RibbonTab(btnTabEdit);
|
|
RibbonTab(btnTabSettings);
|
|
|
|
RibbonTool(btnHelp);
|
|
|
|
{Setting colors of Title Bar, Title Buttons and Tool Buttons}
|
|
vsTitle.Color := MainColor;
|
|
btnClose.StateNormal.Background.Color := uRibbon.ToolNormalColor;
|
|
btnMaximize.StateNormal.Background.Color := uRibbon.ToolNormalColor;
|
|
btnMaximize.StateHover.Background.Color := uRibbon.ToolHoverColor;
|
|
btnMaximize.StateClicked.Background.Color := uRibbon.ToolClickedColor;
|
|
btnMinimize.StateNormal.Background.Color := uRibbon.ToolNormalColor;
|
|
btnMinimize.StateHover.Background.Color := uRibbon.ToolHoverColor;
|
|
btnMinimize.StateClicked.Background.Color := uRibbon.ToolClickedColor;
|
|
btnTool1.StateNormal.Background.Color := uRibbon.ToolNormalColor;
|
|
btnTool1.StateHover.Background.Color := uRibbon.ToolHoverColor;
|
|
btnTool1.StateClicked.Background.Color := uRibbon.ToolClickedColor;
|
|
btnTool2.StateNormal.Background.Color := uRibbon.ToolNormalColor;
|
|
btnTool2.StateHover.Background.Color := uRibbon.ToolHoverColor;
|
|
btnTool2.StateClicked.Background.Color := uRibbon.ToolClickedColor;
|
|
btnTool3.StateNormal.Background.Color := uRibbon.ToolNormalColor;
|
|
btnTool3.StateHover.Background.Color := uRibbon.ToolHoverColor;
|
|
btnTool3.StateClicked.Background.Color := uRibbon.ToolClickedColor;
|
|
|
|
vsBorder.Color:=MainColor;
|
|
|
|
{Redraw all Objects}
|
|
vsTab.RedrawBitmap;
|
|
vsForm.RedrawBitmap;
|
|
vsBody.RedrawBitmap;
|
|
btnFileMenu.Repaint;
|
|
|
|
{ TODO : Applying color settings to file menu
|
|
// FileMenu.Background.Color:=uRibbon.MainColor;
|
|
// Splitter1.Color:=uRibbon.MainColor;
|
|
}
|
|
|
|
end;
|
|
|
|
procedure TfrmMain.mnuColorChangeClick(Sender: TObject);
|
|
var
|
|
mnu: TMenuItem;
|
|
begin
|
|
if (Sender is TMenuItem) then
|
|
begin
|
|
mnu := (Sender as TMenuItem);
|
|
case mnu.Name of
|
|
'mnuColorChange': TabColor := 'blue';
|
|
'mnuColorGreen': TabColor := 'green';
|
|
'mnuColorRed': TabColor := 'red';
|
|
'mnuColorOrange': TabColor := 'orange';
|
|
'mnuColorLiteBlue': TabColor := 'liteblue';
|
|
'mnuColorPetrol': TabColor := 'petrol';
|
|
'mnuColorPurple': TabColor := 'purple';
|
|
end;
|
|
ColorChange(self);
|
|
end;
|
|
|
|
end;
|
|
|
|
{ Animation of objects (c) Lazplanet
|
|
http://lazplanet.blogspot.de/2013/05/animate-move-of-object.html
|
|
Presently not used}
|
|
procedure TfrmMain.MoveAnimation(moveobj: TComponent; leftfrom: integer;
|
|
leftto: integer; topfrom: integer; topto: integer);
|
|
var
|
|
i: integer;
|
|
step: integer = 5;
|
|
moveareax, moveareay: integer;
|
|
begin
|
|
i := 1;
|
|
moveareax := leftto - leftfrom;
|
|
moveareay := topto - topfrom;
|
|
while i <= 100 do
|
|
begin
|
|
TButton(moveobj).Left := round(leftfrom + (moveareax * i / 100));
|
|
TButton(moveobj).Top := round(topfrom + (moveareay * i / 100));
|
|
Repaint;
|
|
Sleep(1);
|
|
// we exit the while...do loop when our work is done
|
|
if i >= 100 then
|
|
Exit;
|
|
Inc(i, step);
|
|
if (100 - i) < step then
|
|
i := 100;
|
|
end;
|
|
end;
|
|
|
|
procedure TfrmMain.btnExitClick(Sender: TObject);
|
|
begin
|
|
Close;
|
|
end;
|
|
|
|
procedure TfrmMain.btnMaximizeClick(Sender: TObject);
|
|
begin
|
|
if WindowState = wsNormal then
|
|
begin
|
|
WindowState := wsMaximized;
|
|
{ Set Form size to fit on screen and not to hide the taskbar}
|
|
with Screen.WorkAreaRect do
|
|
SetBounds(Left, Top, Right - Left, Bottom - Top);
|
|
end
|
|
else
|
|
WindowState := wsNormal;
|
|
end;
|
|
|
|
procedure TfrmMain.btnMinimizeClick(Sender: TObject);
|
|
begin
|
|
{ TODO : LINUX Application.Minimize;
|
|
Doesnt seem to work with Linux? Borderless forms apparently cannot be minimized
|
|
by design. Only way would be to use SW_HIDE, but then APP isnt shown on launch
|
|
pad. Another possibility would be a complete redesign of the application by
|
|
using TrayIcon, or use some normal form as mainform and keep it minimized all
|
|
the time (so it's visible in tray) }
|
|
{$ifdef Windows}
|
|
Application.Minimize;
|
|
{$else}
|
|
// Something to be done for OS <> Windows?
|
|
if MessageDlg('Warning', 'Hide application? It wont be shown on launch pad.',
|
|
mtWarning, [mbOK, mbCancel], 0) = mrOK then
|
|
ShowWindow(frmMain.Handle, SW_HIDE);
|
|
{$endif}
|
|
// Application.ProcessMessages;
|
|
end;
|
|
|
|
procedure TfrmMain.btnCloseClick(Sender: TObject);
|
|
begin
|
|
Close;
|
|
end;
|
|
|
|
procedure TfrmMain.btnHideClick(Sender: TObject);
|
|
var
|
|
i: integer = 66; // vsBody.Top := 66 // needs to be replaced by variable
|
|
step: integer = 10;
|
|
begin
|
|
if vsBody.Tag = 0 then //0 = Visible and Docked
|
|
begin
|
|
vsBody.Align := alNone;
|
|
vsBody.Width := vsBorder.Width-2;
|
|
;
|
|
vsBody.Anchors := [akTop, akLeft, akRight];
|
|
vsForm.Width := frmMain.Width;
|
|
{ Animation / Slide in of vsBody }
|
|
while i >= 0 do
|
|
begin
|
|
vsbody.Top := i;
|
|
Repaint;
|
|
// We spare some time...
|
|
Sleep(1);
|
|
Dec(i, step);
|
|
end;
|
|
vsBody.Hide;
|
|
vsBody.Tag := 1; // undocked
|
|
btnHide.ImageIndex := 1;
|
|
btnHide.Hint := 'Fix Menu';
|
|
end
|
|
else
|
|
begin
|
|
vsForm.Align := alNone;
|
|
vsBody.Align := alTop;
|
|
vsForm.Align := alClient;
|
|
vsBody.Tag := 0;
|
|
btnHide.ImageIndex := 0;
|
|
btnHide.Hint := 'Hide Menu';
|
|
end;
|
|
end;
|
|
|
|
{// A more advanced way to resize the Form.
|
|
// Unit uResize is needed as well.
|
|
procedure TfrmMain.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
|
|
Y: Integer);
|
|
|
|
var LeftEdge,RightEdge,TopEdge,BottomEdge: Boolean;
|
|
BorderPosition: TBorderPos;
|
|
BW: Integer;
|
|
fRect: TRect;
|
|
fPos: TPoint;
|
|
begin
|
|
BW := 20;
|
|
LeftEdge := False;
|
|
RightEdge := False;
|
|
TopEdge := False;
|
|
BottomEdge := False;
|
|
//Check if mouse cursor is on left or right edge
|
|
if X < BW then
|
|
begin
|
|
LeftEdge := True;
|
|
end
|
|
else if X > Self.Width-BW then
|
|
begin
|
|
RightEdge := True;
|
|
end;
|
|
|
|
//Check if mouse cursor is on top or bottom edge
|
|
if Y < BorderWidth then
|
|
begin
|
|
TopEdge := True;
|
|
end
|
|
else if Y > Self.Height-BW then
|
|
begin
|
|
BottomEdge := True;
|
|
end;
|
|
|
|
//Get border position by using if..else if..else clause in order for if block
|
|
//to break as soon as one of the conditions is met
|
|
//First check for corners
|
|
if TopEdge and LeftEdge then BorderPosition := bpTopLeft
|
|
else if TopEdge and RightEdge then BorderPosition := bpTopRight
|
|
else if BottomEdge and LeftEdge then BorderPosition := bpBottomLeft
|
|
else if BottomEdge and RightEdge then BorderPosition := bpBottomRight
|
|
//and only then check for individual edges
|
|
else if TopEdge then BorderPosition := bpTop
|
|
else if BottomEdge then BorderPosition := bpBottom
|
|
else if LeftEdge then BorderPosition := bpLeft
|
|
else if RightEdge then BorderPosition := bpRight
|
|
//mouse cursor is not on any border edge
|
|
else BorderPosition := bpNone;
|
|
|
|
// fPos := Point(X, Y);
|
|
|
|
//Finally you can use case statement to execute needed code based on which
|
|
//border edge is your mouse cursor positioned
|
|
case BorderPosition of
|
|
bpNone: Cursor:=crDefault;//Label1.Caption := 'Not on border';
|
|
bpLeft:
|
|
begin
|
|
Cursor:=crSizeWE; //.Caption := 'Left border';
|
|
if ssLeft in shift then
|
|
ResizeForm.SetMouseDown( self, 5 );
|
|
end;
|
|
bpRight:
|
|
begin
|
|
Cursor := crSizeWE;//Label1.Caption := 'Right border';
|
|
if ssLeft in Shift then
|
|
ResizeForm.SetMouseDown( self, 4 );
|
|
end;
|
|
|
|
bpTop: Cursor:=crSizeNS;//Label1.Caption := 'Top border';
|
|
bpBottom:
|
|
begin
|
|
Cursor:=crSizeNS;//Label1.Caption := 'Bottom border';
|
|
if ssLeft in Shift then
|
|
ResizeForm.SetMouseDown( self, 8 );
|
|
end;
|
|
// bpTopLeft: Label1.Caption := 'Top Left corner';
|
|
// bpTopRight: Label1.Caption := 'Top Right corner';
|
|
bpBottomLeft:
|
|
begin
|
|
Cursor:=crSizeNESW;//Label1.Caption := 'Bottom Left corner';
|
|
if ssLeft in Shift then
|
|
ResizeForm.SetMouseDown( self, 13 );
|
|
end;
|
|
bpBottomRight:
|
|
begin
|
|
Cursor:=crSizeNWSE;//Label1.Caption := 'Bottom Right corner';
|
|
if ssLeft in Shift then
|
|
ResizeForm.SetMouseDown( self, 12 );
|
|
end;
|
|
end;
|
|
|
|
|
|
end;
|
|
}
|
|
|
|
|
|
procedure TfrmMain.btnColorsMouseWheel(Sender: TObject; Shift: TShiftState;
|
|
WheelDelta: integer; MousePos: TPoint; var Handled: boolean);
|
|
begin
|
|
{ TODO : Mousewheel to change Colors }
|
|
end;
|
|
|
|
procedure TfrmMain.btnFileMenuMouseDown(Sender: TObject; Button: TMouseButton;
|
|
Shift: TShiftState; X, Y: integer);
|
|
begin
|
|
Label2.Caption := 'File Menu clicked';
|
|
{ TODO : Implemantation of File Menu
|
|
FileMenu.Show;
|
|
MoveAnimation(FileMenu, -FileMenu.Width, vsTitle.Height, 1, 0);
|
|
// MoveAnimation(FileMenu, -FileMenu.Width, 0, 1, 0);
|
|
}
|
|
end;
|
|
|
|
procedure TfrmMain.btnFileMenuCloseMouseDown(Sender: TObject;
|
|
Button: TMouseButton; Shift: TShiftState; X, Y: integer);
|
|
begin
|
|
FileMenu.Hide;
|
|
end;
|
|
|
|
procedure TfrmMain.btnTabHomeMouseDown(Sender: TObject; Button: TMouseButton;
|
|
Shift: TShiftState; X, Y: integer);
|
|
var
|
|
tab: TBCButton;
|
|
i: integer = 1;
|
|
step: integer = 5;
|
|
begin
|
|
if (Sender is TBCButton) then
|
|
begin
|
|
tab := (Sender as TBCButton);
|
|
frmMain.DisableAutoSizing; //reduce flicker
|
|
case tab.Name of
|
|
'btnTabHome':
|
|
begin
|
|
btnTabHome.Down := True;
|
|
btnTabEdit.Down := False;
|
|
btnTabSettings.Down := False;
|
|
pnlHomeCommand.Show;
|
|
pnlHomeExit.Show;
|
|
pnlEditClipboard.Hide;
|
|
pnlEdit2.Hide;
|
|
pnlSettingsUI.Hide;
|
|
pnlSettings2.Hide;
|
|
end;
|
|
'btnTabEdit':
|
|
begin
|
|
btnTabHome.Down := False;
|
|
btnTabEdit.Down := True;
|
|
btnTabSettings.Down := False;
|
|
pnlHomeCommand.Hide;
|
|
pnlHomeExit.Hide;
|
|
pnlSettingsUI.Hide;
|
|
pnlSettings2.Hide;
|
|
pnlEditClipboard.Show;
|
|
pnlEdit2.Show;
|
|
end;
|
|
'btnTabSettings':
|
|
begin
|
|
btnTabHome.Down := False;
|
|
btnTabEdit.Down := False;
|
|
btnTabSettings.Down := True;
|
|
pnlHomeCommand.Hide;
|
|
pnlHomeExit.Hide;
|
|
pnlEditClipboard.Hide;
|
|
pnlEdit2.Hide;
|
|
pnlSettingsUI.Show;
|
|
pnlSettings2.Show;
|
|
end;
|
|
end;
|
|
frmMain.EnableAutoSizing; //reduce flicker
|
|
|
|
if not (vsBody.Visible) then
|
|
begin
|
|
vsBody.Show;
|
|
vsForm.Top := vsBody.Top;
|
|
{ Animation / Slide-out of vsBody }
|
|
while i <= 66 do
|
|
begin //66 = vsBody.Top // needs to be replaced by variable
|
|
vsbody.Top := i;
|
|
Repaint;
|
|
// We spare some time...
|
|
Sleep(1);
|
|
Inc(i, step);
|
|
end;
|
|
vsBody.Anchors := [akTop, akLeft, akRight];
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TfrmMain.FormActivate(Sender: TObject);
|
|
begin
|
|
{Setting Form style w/o Caption}
|
|
if not FormStyleModifyDone then
|
|
begin
|
|
{$ifdef Windows}
|
|
SetWindowLong(Handle, GWL_STYLE, GetWindowLong(Handle, GWL_STYLE) and
|
|
not WS_CAPTION);
|
|
{$else}
|
|
// Something to be done for OS <> Windows?
|
|
{$endif}
|
|
FormStyleModifyDone := True;
|
|
end;
|
|
end;
|
|
|
|
procedure TfrmMain.FormClose(Sender: TObject; var CloseAction: TCloseAction);
|
|
begin
|
|
{ Set config values, store and free up the XMLConfig }
|
|
XMLConfigMain.SetDeleteValue('FormTop', IntToStr(frmMain.Top), '');
|
|
XMLConfigMain.SetDeleteValue('FormLeft', IntToStr(frmMain.Left), '');
|
|
XMLConfigMain.SetDeleteValue('FormHeight', IntToStr(frmMain.Height), '');
|
|
XMLConfigMain.SetDeleteValue('FormWidth', IntToStr(frmMain.Width), '');
|
|
XMLConfigMain.SetDeleteValue('Color', TabColor, 'blue');
|
|
{ TODO: Classical Menu
|
|
if ActClassicalUI.Checked then
|
|
XMLConfigMain.SetDeleteValue('UI', '1', '')
|
|
else
|
|
XMLConfigMain.SetDeleteValue('UI', '0', '');
|
|
// XMLConfigMain.SetDeleteValue('FontName', string(grdVoyage.Font.Name), '');
|
|
// XMLConfigMain.SetDeleteValue('FontSize', IntToStr(grdVoyage.Font.Size), '');
|
|
// XMLConfigMain.SetDeleteValue('FontColor', grdVoyage.Font.Color, '');
|
|
}
|
|
XMLConfigMain.Flush;
|
|
XMLConfigMain.Free;
|
|
|
|
CloseAction := caFree;
|
|
end;
|
|
|
|
procedure TfrmMain.vsBorderResize(Sender: TObject);
|
|
begin
|
|
{Reducing flicker when Form is resized}
|
|
Repaint;
|
|
end;
|
|
|
|
procedure TfrmMain.vsBodyRedraw(Sender: TObject; Bitmap: TBGRABitmap);
|
|
begin
|
|
DrawBodyGradient(Bitmap);
|
|
end;
|
|
|
|
procedure TfrmMain.vsFormRedraw(Sender: TObject; Bitmap: TBGRABitmap);
|
|
begin
|
|
DrawFormGradient(Bitmap)
|
|
end;
|
|
|
|
procedure TfrmMain.vsTitleRedraw(Sender: TObject; Bitmap: TBGRABitmap);
|
|
begin
|
|
DrawTitleGradient(Bitmap);
|
|
end;
|
|
|
|
procedure TfrmMain.vsTabRedraw(Sender: TObject; Bitmap: TBGRABitmap);
|
|
begin
|
|
DrawTabGradient(Bitmap);
|
|
end;
|
|
|
|
procedure TfrmMain.vsTabMouseDown(Sender: TObject; Button: TMouseButton;
|
|
Shift: TShiftState; X, Y: integer);
|
|
begin
|
|
{Hide Menu if not fixed}
|
|
if vsBody.Tag = 1 then
|
|
vsBody.Hide;
|
|
end;
|
|
|
|
procedure TfrmMain.vsTitleDblClick(Sender: TObject);
|
|
begin
|
|
{$ifdef Windows}
|
|
{ Helper - Sleep 180ms, otherwise its not possible to distinguish
|
|
between Single- and Doubleclick event! }
|
|
Sleep(180);
|
|
{$else}
|
|
// Something to be done for OS <> Windows?
|
|
{$endif}
|
|
if WindowState = wsNormal then
|
|
begin
|
|
WindowState := wsMaximized;
|
|
{ Set Form size to fit on screen and not to hide the taskbar}
|
|
with Screen.WorkAreaRect do
|
|
SetBounds(Left, Top, Right - Left, Bottom - Top);
|
|
end
|
|
else
|
|
WindowState := wsNormal;
|
|
end;
|
|
|
|
procedure TfrmMain.vsTitleMouseDown(Sender: TObject; Button: TMouseButton;
|
|
Shift: TShiftState; X, Y: integer);
|
|
const
|
|
{ Undocument message ID }
|
|
WM_POPUPSYSTEMMENU = $313;
|
|
var
|
|
vs: TBGRAVirtualScreen;
|
|
begin
|
|
{$ifdef Windows}
|
|
{
|
|
How to popup the windows system menu?
|
|
Maybe you can use Keybd_event to eumlate ALT+SPACE
|
|
Maybe you can use a TPopupmenu.
|
|
But they always have some problem.
|
|
The method below is a perfect solution!
|
|
BTW: if your form has borderstyle = bsNone, Please do it like this:
|
|
Set forms style = bsSingle; and use the code below to set form boder:
|
|
SetWindowLong(Handle, GWL_STYLE,GetWindowLong(Handle, GWL_STYLE)
|
|
and (not WS_CAPTION) or WS_DLGFRAME or WS_OVERLAPPED);
|
|
}
|
|
{
|
|
if (Sender is TBGRAVirtualScreen) then
|
|
begin
|
|
vs := (Sender as TBGRAVirtualScreen);
|
|
if vs.Name = 'vsTitle' then // Show SystemMenu only on vsTitle
|
|
begin
|
|
} if ssRIGHT in Shift then
|
|
begin
|
|
SendMessage(Handle, WM_POPUPSYSTEMMENU, 0,
|
|
MakeLong(Mouse.CursorPos.X, Mouse.CursorPos.Y));
|
|
exit;
|
|
end;
|
|
{ end;
|
|
end;
|
|
} {$else}
|
|
// Something to be done for OS <> Windows?
|
|
{$endif}
|
|
|
|
{Hide Menu if not fixed}
|
|
if vsBody.Tag = 1 then
|
|
vsBody.Hide;
|
|
GetCursorPos(MausPos);
|
|
xx := mauspos.x - frmMain.Left;
|
|
yy := mauspos.y - frmMain.Top;
|
|
end;
|
|
|
|
procedure TfrmMain.vsTitleMouseMove(Sender: TObject; Shift: TShiftState; X, Y: integer);
|
|
begin
|
|
if ssLeft in Shift then
|
|
begin
|
|
GetCursorPos(MausPos);
|
|
frmMain.Left := mauspos.x - xx;
|
|
frmMain.Top := mauspos.y - yy;
|
|
end;
|
|
end;
|
|
|
|
procedure TfrmMain.btnHelpMouseDown(Sender: TObject; Button: TMouseButton;
|
|
Shift: TShiftState; X, Y: integer);
|
|
begin
|
|
{ User action }
|
|
MessageDlg('About',
|
|
'BGRA Ribbon' + Chr(13) + Chr(10) +
|
|
'Made with Lazarus' + Chr(13) + Chr(10) +
|
|
'Icons from www.icons8.com'+ Chr(13) + Chr(10) +
|
|
'SVG from www.clker.com/clipart-floral-circles.html'+ Chr(13) + Chr(10) +
|
|
'(c) 2016, coasting',
|
|
mtInformation, [mbOK], 0);
|
|
end;
|
|
|
|
{ User actions }
|
|
|
|
procedure TfrmMain.btnNewClick(Sender: TObject);
|
|
begin
|
|
{ User action }
|
|
Label2.Caption := TComponent(Sender).Name;
|
|
end;
|
|
|
|
procedure TfrmMain.btnClipboardClick(Sender: TObject);
|
|
begin
|
|
{ User action }
|
|
Label2.Caption := TComponent(Sender).Name;
|
|
end;
|
|
|
|
procedure TfrmMain.btnPrintClick(Sender: TObject);
|
|
begin
|
|
{ User action }
|
|
Label2.Caption := TComponent(Sender).Name;
|
|
end;
|
|
|
|
procedure TfrmMain.btnCopyClick(Sender: TObject);
|
|
begin
|
|
{ User action }
|
|
Label2.Caption := TComponent(Sender).Name;
|
|
end;
|
|
|
|
procedure TfrmMain.btnPasteClick(Sender: TObject);
|
|
begin
|
|
{ User action }
|
|
Label2.Caption := TComponent(Sender).Name;
|
|
end;
|
|
|
|
procedure TfrmMain.btnSaveClick(Sender: TObject);
|
|
begin
|
|
{ User action }
|
|
Label2.Caption := TComponent(Sender).Name;
|
|
end;
|
|
|
|
procedure TfrmMain.btnTool1Click(Sender: TObject);
|
|
begin
|
|
{ User action }
|
|
Label2.Caption := TComponent(Sender).Name;
|
|
end;
|
|
|
|
procedure TfrmMain.btnTool2Click(Sender: TObject);
|
|
begin
|
|
{ User action }
|
|
Label2.Caption := TComponent(Sender).Name;
|
|
end;
|
|
|
|
procedure TfrmMain.btnTool3Click(Sender: TObject);
|
|
begin
|
|
{ User action }
|
|
Label2.Caption := TComponent(Sender).Name;
|
|
end;
|
|
|
|
procedure TfrmMain.btnCutClick(Sender: TObject);
|
|
begin
|
|
{ User action }
|
|
Label2.Caption := TComponent(Sender).Name;
|
|
end;
|
|
|
|
procedure TfrmMain.btnPreviewClick(Sender: TObject);
|
|
begin
|
|
{ User action }
|
|
Label2.Caption := TComponent(Sender).Name;
|
|
end;
|
|
|
|
|
|
procedure TfrmMain.btnOpenClick(Sender: TObject);
|
|
begin
|
|
{ User action }
|
|
Label2.Caption := TComponent(Sender).Name;
|
|
end;
|
|
|
|
|
|
end.
|