1 unit uMain; 2 3 {$mode objfpc}{$H+} 4 5 interface 6 7 uses 8 BGRABitmap, BGRABitmapTypes, Classes, SysUtils, FileUtil, Forms, Controls, 9 Graphics, StdCtrls, ExtCtrls, Menus, Dialogs, ActnList, BGRAVirtualScreen, 10 BCButton, BCPanel, BGRAImageList, BGRAResizeSpeedButton, LCLType, LCLIntf, 11 {$ifdef Windows} 12 Windows, 13 {$endif} 14 XMLConf, SynMemo, SynEdit; 15 16 type 17 TBorderPos = (bpTopLeft, bpTopRight, bpBottomLeft, 18 bpBottomRight, bpTop, bpBottom,bpLeft,bpRight,bpnone); 19 20 { TfrmMain } 21 22 TfrmMain = class(TForm) 23 BCButton1: TBCButton; 24 BCButton13: TBCButton; 25 BCButton14: TBCButton; 26 BCButton15: TBCButton; 27 BCButton6: TBCButton; 28 BCButton8: TBCButton; 29 BCPanel1: TBCPanel; 30 BCPanel2: TBCPanel; 31 btnClipboard: TBCButton; 32 btnClose: TBCButton; 33 btnColors: TBCButton; 34 btnCopy: TBCButton; 35 btnCut: TBCButton; 36 btnExit: TBCButton; 37 btnFileMenu: TBCButton; 38 btnFileMenuClose: TBGRAResizeSpeedButton; 39 btnFileNew: TBCButton; 40 btnFileOpen: TBCButton; 41 btnFileSave: TBCButton; 42 btnHelp: TBCButton; 43 btnHide: TBCButton; 44 btnMaximize: TBCButton; 45 btnMinimize: TBCButton; 46 btnNew: TBCButton; 47 btnOpen: TBCButton; 48 btnPaste: TBCButton; 49 btnPreview: TBCButton; 50 btnPrint: TBCButton; 51 btnSave: TBCButton; 52 btnTabEdit: TBCButton; 53 btnTabHome: TBCButton; 54 btnTabSettings: TBCButton; 55 btnTool1: TBCButton; 56 btnTool2: TBCButton; 57 btnTool3: TBCButton; 58 FileMenu: TBCPanel; 59 ImageList16: TBGRAImageList; 60 ImageList16White: TBGRAImageList; 61 ImageList32: TBGRAImageList; 62 ImageListColors: TBGRAImageList; 63 imgResize: TImage; 64 Label2: TLabel; 65 lblTitle: TBCButton; 66 mnuColorChange: TMenuItem; 67 mnuColorGreen: TMenuItem; 68 mnuColorLiteBlue: TMenuItem; 69 mnuColorOrange: TMenuItem; 70 mnuColorPetrol: TMenuItem; 71 mnuColorPurple: TMenuItem; 72 mnuColorRed: TMenuItem; 73 pnlEdit2: TBCPanel; 74 pnlEditClipboard: TBCPanel; 75 pnlHomeCommand: TBCPanel; 76 pnlHomeExit: TBCPanel; 77 pnlSettings2: TBCPanel; 78 pnlSettingsUI: TBCPanel; 79 popColors: TPopupMenu; 80 Splitter1: TSplitter; 81 SynMemo1: TSynMemo; 82 vsBody: TBGRAVirtualScreen; 83 vsBorder: TBGRAVirtualScreen; 84 vsForm: TBGRAVirtualScreen; 85 vsTab: TBGRAVirtualScreen; 86 vsTitle: TBGRAVirtualScreen; 87 XMLConfigMain: TXMLConfig; 88 procedure btnTool1Click(Sender: TObject); 89 procedure btnTool2Click(Sender: TObject); 90 procedure btnTool3Click(Sender: TObject); 91 procedure SynMemo1MouseDown(Sender: TObject; Button: TMouseButton; 92 Shift: TShiftState; X, Y: Integer); 93 procedure btnHideClick(Sender: TObject); 94 procedure btnSaveClick(Sender: TObject); 95 procedure btnColorsMouseWheel(Sender: TObject; Shift: TShiftState; 96 WheelDelta: integer; MousePos: TPoint; var Handled: boolean); 97 procedure btnCutClick(Sender: TObject); 98 procedure btnPrintClick(Sender: TObject); 99 procedure btnCopyClick(Sender: TObject); 100 procedure btnPasteClick(Sender: TObject); 101 procedure btnPreviewClick(Sender: TObject); 102 procedure btnClipboardClick(Sender: TObject); 103 procedure btnCloseClick(Sender: TObject); 104 procedure btnExitClick(Sender: TObject); 105 procedure btnMaximizeClick(Sender: TObject); 106 procedure btnMinimizeClick(Sender: TObject); 107 procedure btnNewClick(Sender: TObject); 108 procedure btnFileMenuCloseMouseDown(Sender: TObject; Button: TMouseButton; 109 Shift: TShiftState; X, Y: integer); 110 procedure btnFileMenuMouseDown(Sender: TObject; Button: TMouseButton; 111 Shift: TShiftState; X, Y: integer); 112 procedure btnHelpMouseDown(Sender: TObject; Button: TMouseButton; 113 Shift: TShiftState; X, Y: integer); 114 procedure btnOpenClick(Sender: TObject); 115 procedure btnTabHomeMouseDown(Sender: TObject; Button: TMouseButton; 116 Shift: TShiftState; X, Y: integer); 117 procedure FormActivate(Sender: TObject); 118 procedure FormClose(Sender: TObject; var CloseAction: TCloseAction); 119 procedure FormCreate(Sender: TObject); 120 procedure FormWindowStateChange(Sender: TObject); 121 procedure imgResizeMouseDown(Sender: TObject; Button: TMouseButton; 122 Shift: TShiftState; X, Y: integer); 123 procedure imgResizeMouseMove(Sender: TObject; Shift: TShiftState; 124 X, Y: integer); 125 procedure Memo1MouseDown(Sender: TObject; Button: TMouseButton; 126 Shift: TShiftState; X, Y: integer); 127 procedure mnuColorChangeClick(Sender: TObject); 128 procedure vsBodyRedraw(Sender: TObject; Bitmap: TBGRABitmap); 129 procedure vsBorderResize(Sender: TObject); 130 procedure vsFormRedraw(Sender: TObject; Bitmap: TBGRABitmap); 131 procedure vsTabMouseDown(Sender: TObject; Button: TMouseButton; 132 Shift: TShiftState; X, Y: integer); 133 procedure vsTabRedraw(Sender: TObject; Bitmap: TBGRABitmap); 134 procedure vsTitleDblClick(Sender: TObject); 135 procedure vsTitleMouseDown(Sender: TObject; Button: TMouseButton; 136 Shift: TShiftState; X, Y: integer); 137 procedure vsTitleMouseMove(Sender: TObject; Shift: TShiftState; X, Y: integer); 138 procedure vsTitleRedraw(Sender: TObject; Bitmap: TBGRABitmap); 139 private 140 { private declarations } 141 FormStyleModifyDone: boolean; 142 // procedure CreateParams(VAR Params: TCreateParams); override; 143 // procedure WMNCHitTest(VAR Msg: TWMNcHitTest); message WM_NCHITTEST; 144 procedure ColorChange(Sender: TObject); 145 procedure MoveAnimation(moveobj: TComponent; leftfrom: integer; 146 leftto: integer; topfrom: integer; topto: integer); 147 public 148 { public declarations } 149 isFocused: Boolean; 150 procedure AppActivate(Sender: TObject); 151 procedure AppDeactivate(Sender: TObject); 152 constructor Create(TheOwner: TComponent); override; 153 end; 154 155 var 156 frmMain: TfrmMain; 157 TabColor: string; 158 MausPos: TPoint; 159 xx, yy: integer; 160 d: boolean = False; 161 162 PtSize: TPoint; 163 DoResize: boolean; 164 165 implementation 166 167 {$R *.lfm} 168 169 uses 170 uRibbon; {, uResize;} 171 172 { TfrmMain } 173 174 {procedure TfrmMain.CreateParams(VAR Params: TCreateParams); 175 begin 176 Inherited CreateParams(Params); 177 WITH Params DO 178 Style := (Style OR WS_POPUP) AND (NOT WS_DLGFRAME); 179 {or... Style := Style + WS_POPUP - WS_DLGFRAME; which is the 180 equivalent to the above statement} 181 end; 182 183 procedure TfrmMain.WMNCHitTest(var msg: TWMNCHitTest); 184 begin 185 inherited; 186 if (msg.Result = htClient) then 187 msg.Result := htCaption; 188 end; 189 } 190 191 { Dropshadow Function places a shadow behind a Form with Borderstyle=bsNone; } 192 {http://www.delphipraxis.net/32245-dropshadow.html 193 Am bestem im Konstruktor aufzurufen 194 ****Windows OS only!**** 195 196 function DropShadow(const Handle: THandle): boolean; 197 198 function IsXP: boolean; 199 begin 200 Result := (Win32Platform = VER_PLATFORM_WIN32_NT) and 201 ((Win32MajorVersion > 5) or ((Win32MajorVersion = 5) and 202 (Win32MinorVersion >= 1))); 203 end; 204 205 const 206 SPI_SETDROPSHADOW = $1025; 207 CS_DROPSHADOW = $00020000; 208 begin 209 Result := IsXP and SystemParametersInfo(SPI_SETDROPSHADOW, 0, Pointer(True), 0) and 210 (SetClassLong(Handle, GCL_STYLE, GetClassLong(Handle, GCL_STYLE) or 211 CS_DROPSHADOW) <> 0); 212 end; 213 } 214 215 { For whatever reason the following doesnt work? Form is still painted w/o shadow! 216 Function Dropshadow() works though! 217 218 procedure TfrmMain.CreateParams(var Params: TCreateParams); 219 const 220 SPI_SETDROPSHADOW = $1025; 221 CS_DROPSHADOW = $00020000; 222 begin 223 inherited; 224 if CheckWin32Version(5, 1) then 225 begin 226 SystemParametersInfo(SPI_SETDROPSHADOW, 0, Pointer(True), 0); 227 Params.WindowClass.style := Params.WindowClass.style or CS_DROPSHADOW; 228 end; 229 end; 230 } 231 232 constructor TfrmMain.Create(TheOwner: TComponent); 233 begin 234 inherited Create(TheOwner); 235 Application.OnDeactivate:=@AppDeactivate; 236 Application.OnActivate:=@AppActivate; 237 end; 238 239 procedure TfrmMain.AppDeactivate(Sender: TObject); 240 begin 241 isFocused := FALSE; 242 vsBorder.Color:=$00838383; 243 lblTitle.GlobalOpacity:=125; 244 btnMinimize.GlobalOpacity:=125; 245 btnMaximize.GlobalOpacity:=125; 246 btnClose.GlobalOpacity:=125; 247 btnTool1.GlobalOpacity:=125; 248 btnTool2.GlobalOpacity:=125; 249 btnTool3.GlobalOpacity:=125; 250 end; 251 252 procedure TfrmMain.AppActivate(Sender: TObject); 253 begin 254 isFocused := TRUE; 255 vsBorder.Color:=uRibbon.MainColor; 256 lblTitle.GlobalOpacity:=255; 257 btnMinimize.GlobalOpacity:=255; 258 btnMaximize.GlobalOpacity:=255; 259 btnClose.GlobalOpacity:=255; 260 btnTool1.GlobalOpacity:=255; 261 btnTool2.GlobalOpacity:=255; 262 btnTool3.GlobalOpacity:=255; 263 end; 264 265 266 procedure TfrmMain.FormCreate(Sender: TObject); 267 begin 268 { Features presently implemented as of 06.04.2016 269 - Moveable and Sizeable Form without Border and Caption 270 - Extended drag area 271 - Form has shadow (CS_DROPSHADOW) 272 - Max- / Minimizing of Form 273 - Doubleclick on Title maximizes / restores Form 274 - RightClick on Title shows Systemmenu 275 - Form indicates whether it has focus or not 276 - Quick Access Toolbuttons 277 - XML storage of some properties (Form size, position and colors) 278 - Custom painting of images and caption on Buttons (Windows ok, but not sure it works on Linux?) 279 - Slide-in and slide-out effect of Menu (Windows ok, needs finetuning on Linux, Z-Order?) 280 } 281 { TODO : Presently cant find a working way to use the sizeable system border } 282 { DONE : Rightclick on vsTitle to show SystemMenu } 283 { DONE : Replace Icon and Caption by customizable Quick Access Toolbuttons on vsTitle } 284 { DONE : Line break in custom drawn text on Buttons } 285 { TODO : Radio Button, Drop Down Example on vsBody } 286 { TODO : Implementation of File Menu } 287 { TODO : Offer classical menus as an option to user } 288 { TODO : All color definitions to be shifted to uRibbon.pas } 289 { TODO : Linux - Slide effect of Menu needs finetuning } 290 { TODO : Linux - Custom painting on Buttons needs to be verified } 291 292 { Create the XML config component to store some settings } 293 XMLConfigMain := TXMLConfig.Create(nil); 294 XMLConfigMain.Filename := ChangeFileExt(Application.ExeName, '.xml'); 295 296 { Set BorderStyle from bsSingle to bsNone to get a Form w/o Title Bar } 297 BorderStyle := bsNone; 298 299 { Place a shadow behind the Form } 300 {$ifdef Windows} 301 // DropShadow(Handle); // Better to use SetClasslong() as follows (Windows OS only): 302 {Handle = all Forms, frmMain.Handle = only frmMain Form 303 SetClassLong(Handle, GCL_STYLE, GetClassLong(Handle, GCL_STYLE) or CS_DROPSHADOW); 304 } 305 SetClassLong(frmMain.Handle, GCL_STYLE, GetClassLong(frmMain.Handle, GCL_STYLE) or CS_DROPSHADOW); 306 { Following can be used on Windows < 8 307 // Soner: Füge die nächsten 3 Zeilen hinzu ------------------------------------ 308 // vergiß uses LCLIntf; nicht. 309 SetWindowLong(Handle,GWL_STYLE, GetWindowLong(Handle, GWL_STYLE) or WS_THICKFRAME); 310 ClientHeight:=Height; 311 Refresh; 312 } 313 {$else} 314 // Something to be done for OS <> Windows? 315 {$endif} 316 317 { Set Doublebuffered property to reduce flicker. } 318 Doublebuffered := True; 319 // vsBody.DoubleBuffered:=True; 320 // vsTab.DoubleBuffered:=True; 321 // vsForm.DoubleBuffered:=True; 322 // vsTitle.DoubleBuffered:=True; 323 // vsBorder.DoubleBuffered:=True; 324 325 { Read and set the XML config values } 326 Position := poDesigned; 327 Top := StrToInt(XMLConfigMain.GetValue('FormTop', '250')); 328 Left := StrToInt(XMLConfigMain.GetValue('FormLeft', '550')); 329 Height := StrToInt(XMLConfigMain.GetValue('FormHeight', '350')); 330 Width := StrToInt(XMLConfigMain.GetValue('FormWidth', '600')); 331 332 { Set Min Height and Min Width of Form to prevent vanishing of Form } 333 Constraints.MinHeight := 200; 334 Constraints.MinWidth := 250; 335 336 { Set Colors } 337 338 { Colors of Body Buttons are the same for all styles } 339 uRibbon.BtnFntColor := $00696969; // Button Font Color 340 uRibbon.BtnNormalColor := $00F1F1F1; // Button Normal 341 uRibbon.BtnHoverColor := $00cdcdcd; // Button Hover 342 uRibbon.BtnClickedColor := $00b0b0b0; // Button Clicked 343 344 TabColor := XMLConfigMain.GetValue('Color', 'blue'); 345 346 { Call ColorChange() to set colors } 347 ColorChange(self); 348 349 StyleRibbonBody(pnlHomeCommand); 350 StyleRibbonBody(pnlHomeExit); 351 StyleRibbonBody(pnlSettingsUI); 352 StyleRibbonBody(pnlEditClipboard); 353 354 { to be done, let the user decide which UI he likes to use 355 // Set UI to Ribbon, otherwise use Classical Menus 356 if StrToInt(XMLConfigMain.GetValue('UI', ''))=1 then 357 SetUserInterface(false) 358 else 359 SetUserInterface(true); 360 } 361 362 { Showing Form.Caption in Title bar } 363 lblTitle.Caption := frmMain.Caption; 364 end; 365 366 procedure TfrmMain.FormWindowStateChange(Sender: TObject); 367 begin 368 if WindowState = wsMaximized then 369 begin 370 with Screen.WorkAreaRect do 371 SetBounds(Left, Top, Right - Left, Bottom - Top); 372 end; 373 end; 374 375 procedure TfrmMain.imgResizeMouseDown(Sender: TObject; Button: TMouseButton; 376 Shift: TShiftState; X, Y: integer); 377 begin 378 PtSize.y := Mouse.CursorPos.y - Top - Height; 379 PtSize.x := Mouse.CursorPos.x - Left - Width; 380 end; 381 382 procedure TfrmMain.imgResizeMouseMove(Sender: TObject; Shift: TShiftState; 383 X, Y: integer); 384 begin 385 if ssLeft in shift then 386 begin 387 Width := Mouse.CursorPos.x - Left - PtSize.x; 388 Height := Mouse.CursorPos.y - Top - PtSize.y; 389 end; 390 end; 391 392 procedure TfrmMain.Memo1MouseDown(Sender: TObject; Button: TMouseButton; 393 Shift: TShiftState; X, Y: integer); 394 begin 395 {Hide Menu if not fixed} 396 if vsBody.Tag = 1 then 397 vsBody.Hide; 398 end; 399 400 procedure TfrmMain.SynMemo1MouseDown(Sender: TObject; Button: TMouseButton; 401 Shift: TShiftState; X, Y: Integer); 402 begin 403 {Hide Menu if not fixed} 404 if vsBody.Tag = 1 then 405 vsBody.Hide; 406 end; 407 408 procedure TfrmMain.ColorChange(Sender: TObject); 409 begin 410 case TabColor of 411 'blue': 412 begin 413 // TabColor := 'blue'; 414 uRibbon.MainColor := $009A572A; 415 uRibbon.TabFntColor := $009A572A; 416 uRibbon.TabNormalColor := $009A572A; 417 uRibbon.TabHoverColor := $00b66d3e; 418 uRibbon.TabClickedColor := $00F1F1F1; 419 uRibbon.ToolNormalColor := $009A572A; 420 uRibbon.ToolHoverColor := $00b66d3e; 421 uRibbon.ToolClickedColor := $00784012; 422 end; 423 'green': 424 begin 425 // TabColor := 'green'; 426 uRibbon.MainColor := $00477422; 427 uRibbon.TabFntColor := $00477422; 428 uRibbon.TabNormalColor := $00477422; 429 uRibbon.TabHoverColor := $00679443; 430 uRibbon.TabClickedColor := $00F1F1F1; 431 uRibbon.ToolNormalColor := $00477422; 432 uRibbon.ToolHoverColor := $00679443; 433 uRibbon.ToolClickedColor := $00395d1b; 434 end; 435 'red': 436 begin 437 // TabColor := 'red'; 438 uRibbon.MainColor := $003a37a4; 439 uRibbon.TabFntColor := $003a37a4; 440 uRibbon.TabNormalColor := $003a37a4; 441 uRibbon.TabHoverColor := $005956c7; 442 uRibbon.TabClickedColor := $00F1F1F1; 443 uRibbon.ToolNormalColor := $003a37a4; 444 uRibbon.ToolHoverColor := $005956c7; 445 uRibbon.ToolClickedColor := $002e2c83; 446 end; 447 'orange': 448 begin 449 // TabColor := 'orange'; 450 uRibbon.MainColor := $002a47b7; 451 uRibbon.TabFntColor := $002a47b7; 452 uRibbon.TabNormalColor := $002a47b7; 453 uRibbon.TabHoverColor := $003959dc; 454 uRibbon.TabClickedColor := $00F1F1F1; 455 uRibbon.ToolNormalColor := $002a47b7; 456 uRibbon.ToolHoverColor := $003959dc; 457 uRibbon.ToolClickedColor := $00223992; 458 end; 459 'liteblue': 460 begin 461 // TabColor := 'lightblue'; 462 uRibbon.MainColor := $00c77301; 463 uRibbon.TabFntColor := $00c77301; 464 uRibbon.TabNormalColor := $00c77301; 465 uRibbon.TabHoverColor := $00d48a2a; 466 uRibbon.TabClickedColor := $00F1F1F1; 467 uRibbon.ToolNormalColor := $00c77301; 468 uRibbon.ToolHoverColor := $00d48a2a; 469 uRibbon.ToolClickedColor := $009f5c01; 470 end; 471 'petrol': 472 begin 473 // TabColor := 'petrol'; 474 uRibbon.MainColor := $00728200; 475 uRibbon.TabFntColor := $00728200; 476 uRibbon.TabNormalColor := $00728200; 477 uRibbon.TabHoverColor := $00839900; 478 uRibbon.TabClickedColor := $00F1F1F1; 479 uRibbon.ToolNormalColor := $00728200; 480 uRibbon.ToolHoverColor := $00839900; 481 uRibbon.ToolClickedColor := $005f6b1a; 482 end; 483 'purple': 484 begin 485 // TabColor := 'purple'; 486 uRibbon.MainColor := $007b3980; 487 uRibbon.TabFntColor := $007b3980; 488 uRibbon.TabNormalColor := $007b3980; 489 uRibbon.TabHoverColor := $009e56a3; 490 uRibbon.TabClickedColor := $00F1F1F1; 491 uRibbon.ToolNormalColor := $007b3980; 492 uRibbon.ToolHoverColor := $009e56a3; 493 uRibbon.ToolClickedColor := $00622e66; 494 end; 495 end; 496 RibbonMenu(btnFileMenu); 497 498 RibbonTab(btnTabHome); 499 RibbonTab(btnTabEdit); 500 RibbonTab(btnTabSettings); 501 502 RibbonTool(btnHelp); 503 504 {Setting colors of Title Bar, Title Buttons and Tool Buttons} 505 vsTitle.Color := MainColor; 506 btnClose.StateNormal.Background.Color := uRibbon.ToolNormalColor; 507 btnMaximize.StateNormal.Background.Color := uRibbon.ToolNormalColor; 508 btnMaximize.StateHover.Background.Color := uRibbon.ToolHoverColor; 509 btnMaximize.StateClicked.Background.Color := uRibbon.ToolClickedColor; 510 btnMinimize.StateNormal.Background.Color := uRibbon.ToolNormalColor; 511 btnMinimize.StateHover.Background.Color := uRibbon.ToolHoverColor; 512 btnMinimize.StateClicked.Background.Color := uRibbon.ToolClickedColor; 513 btnTool1.StateNormal.Background.Color := uRibbon.ToolNormalColor; 514 btnTool1.StateHover.Background.Color := uRibbon.ToolHoverColor; 515 btnTool1.StateClicked.Background.Color := uRibbon.ToolClickedColor; 516 btnTool2.StateNormal.Background.Color := uRibbon.ToolNormalColor; 517 btnTool2.StateHover.Background.Color := uRibbon.ToolHoverColor; 518 btnTool2.StateClicked.Background.Color := uRibbon.ToolClickedColor; 519 btnTool3.StateNormal.Background.Color := uRibbon.ToolNormalColor; 520 btnTool3.StateHover.Background.Color := uRibbon.ToolHoverColor; 521 btnTool3.StateClicked.Background.Color := uRibbon.ToolClickedColor; 522 523 vsBorder.Color:=MainColor; 524 525 {Redraw all Objects} 526 vsTab.RedrawBitmap; 527 vsForm.RedrawBitmap; 528 vsBody.RedrawBitmap; 529 btnFileMenu.Repaint; 530 531 { TODO : Applying color settings to file menu 532 // FileMenu.Background.Color:=uRibbon.MainColor; 533 // Splitter1.Color:=uRibbon.MainColor; 534 } 535 536 end; 537 538 procedure TfrmMain.mnuColorChangeClick(Sender: TObject); 539 var 540 mnu: TMenuItem; 541 begin 542 if (Sender is TMenuItem) then 543 begin 544 mnu := (Sender as TMenuItem); 545 case mnu.Name of 546 'mnuColorChange': TabColor := 'blue'; 547 'mnuColorGreen': TabColor := 'green'; 548 'mnuColorRed': TabColor := 'red'; 549 'mnuColorOrange': TabColor := 'orange'; 550 'mnuColorLiteBlue': TabColor := 'liteblue'; 551 'mnuColorPetrol': TabColor := 'petrol'; 552 'mnuColorPurple': TabColor := 'purple'; 553 end; 554 ColorChange(self); 555 end; 556 557 end; 558 559 { Animation of objects (c) Lazplanet 560 http://lazplanet.blogspot.de/2013/05/animate-move-of-object.html 561 Presently not used} 562 procedure TfrmMain.MoveAnimation(moveobj: TComponent; leftfrom: integer; 563 leftto: integer; topfrom: integer; topto: integer); 564 var 565 i: integer; 566 step: integer = 5; 567 moveareax, moveareay: integer; 568 begin 569 i := 1; 570 moveareax := leftto - leftfrom; 571 moveareay := topto - topfrom; 572 while i <= 100 do 573 begin 574 TButton(moveobj).Left := round(leftfrom + (moveareax * i / 100)); 575 TButton(moveobj).Top := round(topfrom + (moveareay * i / 100)); 576 Repaint; 577 Sleep(1); 578 // we exit the while...do loop when our work is done 579 if i >= 100 then 580 Exit; 581 Inc(i, step); 582 if (100 - i) < step then 583 i := 100; 584 end; 585 end; 586 587 procedure TfrmMain.btnExitClick(Sender: TObject); 588 begin 589 Close; 590 end; 591 592 procedure TfrmMain.btnMaximizeClick(Sender: TObject); 593 begin 594 if WindowState = wsNormal then 595 begin 596 WindowState := wsMaximized; 597 { Set Form size to fit on screen and not to hide the taskbar} 598 with Screen.WorkAreaRect do 599 SetBounds(Left, Top, Right - Left, Bottom - Top); 600 end 601 else 602 WindowState := wsNormal; 603 end; 604 605 procedure TfrmMain.btnMinimizeClick(Sender: TObject); 606 begin 607 { TODO : LINUX Application.Minimize; 608 Doesnt seem to work with Linux? Borderless forms apparently cannot be minimized 609 by design. Only way would be to use SW_HIDE, but then APP isnt shown on launch 610 pad. Another possibility would be a complete redesign of the application by 611 using TrayIcon, or use some normal form as mainform and keep it minimized all 612 the time (so it's visible in tray) } 613 {$ifdef Windows} 614 Application.Minimize; 615 {$else} 616 // Something to be done for OS <> Windows? 617 if MessageDlg('Warning', 'Hide application? It wont be shown on launch pad.', 618 mtWarning, [mbOK, mbCancel], 0) = mrOK then 619 ShowWindow(frmMain.Handle, SW_HIDE); 620 {$endif} 621 // Application.ProcessMessages; 622 end; 623 624 procedure TfrmMain.btnCloseClick(Sender: TObject); 625 begin 626 Close; 627 end; 628 629 procedure TfrmMain.btnHideClick(Sender: TObject); 630 var 631 i: integer = 66; // vsBody.Top := 66 // needs to be replaced by variable 632 step: integer = 10; 633 begin 634 if vsBody.Tag = 0 then //0 = Visible and Docked 635 begin 636 vsBody.Align := alNone; 637 vsBody.Width := vsBorder.Width-2; 638 ; 639 vsBody.Anchors := [akTop, akLeft, akRight]; 640 vsForm.Width := frmMain.Width; 641 { Animation / Slide in of vsBody } 642 while i >= 0 do 643 begin 644 vsbody.Top := i; 645 Repaint; 646 // We spare some time... 647 Sleep(1); 648 Dec(i, step); 649 end; 650 vsBody.Hide; 651 vsBody.Tag := 1; // undocked 652 btnHide.ImageIndex := 1; 653 btnHide.Hint := 'Fix Menu'; 654 end 655 else 656 begin 657 vsForm.Align := alNone; 658 vsBody.Align := alTop; 659 vsForm.Align := alClient; 660 vsBody.Tag := 0; 661 btnHide.ImageIndex := 0; 662 btnHide.Hint := 'Hide Menu'; 663 end; 664 end; 665 666 {// A more advanced way to resize the Form. 667 // Unit uResize is needed as well. 668 procedure TfrmMain.FormMouseMove(Sender: TObject; Shift: TShiftState; X, 669 Y: Integer); 670 671 var LeftEdge,RightEdge,TopEdge,BottomEdge: Boolean; 672 BorderPosition: TBorderPos; 673 BW: Integer; 674 fRect: TRect; 675 fPos: TPoint; 676 begin 677 BW := 20; 678 LeftEdge := False; 679 RightEdge := False; 680 TopEdge := False; 681 BottomEdge := False; 682 //Check if mouse cursor is on left or right edge 683 if X < BW then 684 begin 685 LeftEdge := True; 686 end 687 else if X > Self.Width-BW then 688 begin 689 RightEdge := True; 690 end; 691 692 //Check if mouse cursor is on top or bottom edge 693 if Y < BorderWidth then 694 begin 695 TopEdge := True; 696 end 697 else if Y > Self.Height-BW then 698 begin 699 BottomEdge := True; 700 end; 701 702 //Get border position by using if..else if..else clause in order for if block 703 //to break as soon as one of the conditions is met 704 //First check for corners 705 if TopEdge and LeftEdge then BorderPosition := bpTopLeft 706 else if TopEdge and RightEdge then BorderPosition := bpTopRight 707 else if BottomEdge and LeftEdge then BorderPosition := bpBottomLeft 708 else if BottomEdge and RightEdge then BorderPosition := bpBottomRight 709 //and only then check for individual edges 710 else if TopEdge then BorderPosition := bpTop 711 else if BottomEdge then BorderPosition := bpBottom 712 else if LeftEdge then BorderPosition := bpLeft 713 else if RightEdge then BorderPosition := bpRight 714 //mouse cursor is not on any border edge 715 else BorderPosition := bpNone; 716 717 // fPos := Point(X, Y); 718 719 //Finally you can use case statement to execute needed code based on which 720 //border edge is your mouse cursor positioned 721 case BorderPosition of 722 bpNone: Cursor:=crDefault;//Label1.Caption := 'Not on border'; 723 bpLeft: 724 begin 725 Cursor:=crSizeWE; //.Caption := 'Left border'; 726 if ssLeft in shift then 727 ResizeForm.SetMouseDown( self, 5 ); 728 end; 729 bpRight: 730 begin 731 Cursor := crSizeWE;//Label1.Caption := 'Right border'; 732 if ssLeft in Shift then 733 ResizeForm.SetMouseDown( self, 4 ); 734 end; 735 736 bpTop: Cursor:=crSizeNS;//Label1.Caption := 'Top border'; 737 bpBottom: 738 begin 739 Cursor:=crSizeNS;//Label1.Caption := 'Bottom border'; 740 if ssLeft in Shift then 741 ResizeForm.SetMouseDown( self, 8 ); 742 end; 743 // bpTopLeft: Label1.Caption := 'Top Left corner'; 744 // bpTopRight: Label1.Caption := 'Top Right corner'; 745 bpBottomLeft: 746 begin 747 Cursor:=crSizeNESW;//Label1.Caption := 'Bottom Left corner'; 748 if ssLeft in Shift then 749 ResizeForm.SetMouseDown( self, 13 ); 750 end; 751 bpBottomRight: 752 begin 753 Cursor:=crSizeNWSE;//Label1.Caption := 'Bottom Right corner'; 754 if ssLeft in Shift then 755 ResizeForm.SetMouseDown( self, 12 ); 756 end; 757 end; 758 759 760 end; 761 } 762 763 764 procedure TfrmMain.btnColorsMouseWheel(Sender: TObject; Shift: TShiftState; 765 WheelDelta: integer; MousePos: TPoint; var Handled: boolean); 766 begin 767 { TODO : Mousewheel to change Colors } 768 end; 769 770 procedure TfrmMain.btnFileMenuMouseDown(Sender: TObject; Button: TMouseButton; 771 Shift: TShiftState; X, Y: integer); 772 begin 773 Label2.Caption := 'File Menu clicked'; 774 { TODO : Implemantation of File Menu 775 FileMenu.Show; 776 MoveAnimation(FileMenu, -FileMenu.Width, vsTitle.Height, 1, 0); 777 // MoveAnimation(FileMenu, -FileMenu.Width, 0, 1, 0); 778 } 779 end; 780 781 procedure TfrmMain.btnFileMenuCloseMouseDown(Sender: TObject; 782 Button: TMouseButton; Shift: TShiftState; X, Y: integer); 783 begin 784 FileMenu.Hide; 785 end; 786 787 procedure TfrmMain.btnTabHomeMouseDown(Sender: TObject; Button: TMouseButton; 788 Shift: TShiftState; X, Y: integer); 789 var 790 tab: TBCButton; 791 i: integer = 1; 792 step: integer = 5; 793 begin 794 if (Sender is TBCButton) then 795 begin 796 tab := (Sender as TBCButton); 797 frmMain.DisableAutoSizing; //reduce flicker 798 case tab.Name of 799 'btnTabHome': 800 begin 801 btnTabHome.Down := True; 802 btnTabEdit.Down := False; 803 btnTabSettings.Down := False; 804 pnlHomeCommand.Show; 805 pnlHomeExit.Show; 806 pnlEditClipboard.Hide; 807 pnlEdit2.Hide; 808 pnlSettingsUI.Hide; 809 pnlSettings2.Hide; 810 end; 811 'btnTabEdit': 812 begin 813 btnTabHome.Down := False; 814 btnTabEdit.Down := True; 815 btnTabSettings.Down := False; 816 pnlHomeCommand.Hide; 817 pnlHomeExit.Hide; 818 pnlSettingsUI.Hide; 819 pnlSettings2.Hide; 820 pnlEditClipboard.Show; 821 pnlEdit2.Show; 822 end; 823 'btnTabSettings': 824 begin 825 btnTabHome.Down := False; 826 btnTabEdit.Down := False; 827 btnTabSettings.Down := True; 828 pnlHomeCommand.Hide; 829 pnlHomeExit.Hide; 830 pnlEditClipboard.Hide; 831 pnlEdit2.Hide; 832 pnlSettingsUI.Show; 833 pnlSettings2.Show; 834 end; 835 end; 836 frmMain.EnableAutoSizing; //reduce flicker 837 838 if not (vsBody.Visible) then 839 begin 840 vsBody.Show; 841 vsForm.Top := vsBody.Top; 842 { Animation / Slide-out of vsBody } 843 while i <= 66 do 844 begin //66 = vsBody.Top // needs to be replaced by variable 845 vsbody.Top := i; 846 Repaint; 847 // We spare some time... 848 Sleep(1); 849 Inc(i, step); 850 end; 851 vsBody.Anchors := [akTop, akLeft, akRight]; 852 end; 853 end; 854 end; 855 856 procedure TfrmMain.FormActivate(Sender: TObject); 857 begin 858 {Setting Form style w/o Caption} 859 if not FormStyleModifyDone then 860 begin 861 {$ifdef Windows} 862 SetWindowLong(Handle, GWL_STYLE, GetWindowLong(Handle, GWL_STYLE) and 863 not WS_CAPTION); 864 {$else} 865 // Something to be done for OS <> Windows? 866 {$endif} 867 FormStyleModifyDone := True; 868 end; 869 end; 870 871 procedure TfrmMain.FormClose(Sender: TObject; var CloseAction: TCloseAction); 872 begin 873 { Set config values, store and free up the XMLConfig } 874 XMLConfigMain.SetDeleteValue('FormTop', IntToStr(frmMain.Top), ''); 875 XMLConfigMain.SetDeleteValue('FormLeft', IntToStr(frmMain.Left), ''); 876 XMLConfigMain.SetDeleteValue('FormHeight', IntToStr(frmMain.Height), ''); 877 XMLConfigMain.SetDeleteValue('FormWidth', IntToStr(frmMain.Width), ''); 878 XMLConfigMain.SetDeleteValue('Color', TabColor, 'blue'); 879 { TODO: Classical Menu 880 if ActClassicalUI.Checked then 881 XMLConfigMain.SetDeleteValue('UI', '1', '') 882 else 883 XMLConfigMain.SetDeleteValue('UI', '0', ''); 884 // XMLConfigMain.SetDeleteValue('FontName', string(grdVoyage.Font.Name), ''); 885 // XMLConfigMain.SetDeleteValue('FontSize', IntToStr(grdVoyage.Font.Size), ''); 886 // XMLConfigMain.SetDeleteValue('FontColor', grdVoyage.Font.Color, ''); 887 } 888 XMLConfigMain.Flush; 889 XMLConfigMain.Free; 890 891 CloseAction := caFree; 892 end; 893 894 procedure TfrmMain.vsBorderResize(Sender: TObject); 895 begin 896 {Reducing flicker when Form is resized} 897 Repaint; 898 end; 899 900 procedure TfrmMain.vsBodyRedraw(Sender: TObject; Bitmap: TBGRABitmap); 901 begin 902 DrawBodyGradient(Bitmap); 903 end; 904 905 procedure TfrmMain.vsFormRedraw(Sender: TObject; Bitmap: TBGRABitmap); 906 begin 907 DrawFormGradient(Bitmap) 908 end; 909 910 procedure TfrmMain.vsTitleRedraw(Sender: TObject; Bitmap: TBGRABitmap); 911 begin 912 DrawTitleGradient(Bitmap); 913 end; 914 915 procedure TfrmMain.vsTabRedraw(Sender: TObject; Bitmap: TBGRABitmap); 916 begin 917 DrawTabGradient(Bitmap); 918 end; 919 920 procedure TfrmMain.vsTabMouseDown(Sender: TObject; Button: TMouseButton; 921 Shift: TShiftState; X, Y: integer); 922 begin 923 {Hide Menu if not fixed} 924 if vsBody.Tag = 1 then 925 vsBody.Hide; 926 end; 927 928 procedure TfrmMain.vsTitleDblClick(Sender: TObject); 929 begin 930 {$ifdef Windows} 931 { Helper - Sleep 180ms, otherwise its not possible to distinguish 932 between Single- and Doubleclick event! } 933 Sleep(180); 934 {$else} 935 // Something to be done for OS <> Windows? 936 {$endif} 937 if WindowState = wsNormal then 938 begin 939 WindowState := wsMaximized; 940 { Set Form size to fit on screen and not to hide the taskbar} 941 with Screen.WorkAreaRect do 942 SetBounds(Left, Top, Right - Left, Bottom - Top); 943 end 944 else 945 WindowState := wsNormal; 946 end; 947 948 procedure TfrmMain.vsTitleMouseDown(Sender: TObject; Button: TMouseButton; 949 Shift: TShiftState; X, Y: integer); 950 const 951 { Undocument message ID } 952 WM_POPUPSYSTEMMENU = $313; 953 var 954 vs: TBGRAVirtualScreen; 955 begin 956 {$ifdef Windows} 957 { 958 How to popup the windows system menu? 959 Maybe you can use Keybd_event to eumlate ALT+SPACE 960 Maybe you can use a TPopupmenu. 961 But they always have some problem. 962 The method below is a perfect solution! 963 BTW: if your form has borderstyle = bsNone, Please do it like this: 964 Set forms style = bsSingle; and use the code below to set form boder: 965 SetWindowLong(Handle, GWL_STYLE,GetWindowLong(Handle, GWL_STYLE) 966 and (not WS_CAPTION) or WS_DLGFRAME or WS_OVERLAPPED); 967 } 968 { 969 if (Sender is TBGRAVirtualScreen) then 970 begin 971 vs := (Sender as TBGRAVirtualScreen); 972 if vs.Name = 'vsTitle' then // Show SystemMenu only on vsTitle 973 begin 974 } if ssRIGHT in Shift then 975 begin 976 SendMessage(Handle, WM_POPUPSYSTEMMENU, 0, 977 MakeLong(Mouse.CursorPos.X, Mouse.CursorPos.Y)); 978 exit; 979 end; 980 { end; 981 end; 982 } {$else} 983 // Something to be done for OS <> Windows? 984 {$endif} 985 986 {Hide Menu if not fixed} 987 if vsBody.Tag = 1 then 988 vsBody.Hide; 989 GetCursorPos(MausPos); 990 xx := mauspos.x - frmMain.Left; 991 yy := mauspos.y - frmMain.Top; 992 end; 993 994 procedure TfrmMain.vsTitleMouseMove(Sender: TObject; Shift: TShiftState; X, Y: integer); 995 begin 996 if ssLeft in Shift then 997 begin 998 GetCursorPos(MausPos); 999 frmMain.Left := mauspos.x - xx; 1000 frmMain.Top := mauspos.y - yy; 1001 end; 1002 end; 1003 1004 procedure TfrmMain.btnHelpMouseDown(Sender: TObject; Button: TMouseButton; 1005 Shift: TShiftState; X, Y: integer); 1006 begin 1007 { User action } 1008 MessageDlg('About', 1009 'BGRA Ribbon' + Chr(13) + Chr(10) + 1010 'Made with Lazarus' + Chr(13) + Chr(10) + 1011 'Icons from www.icons8.com'+ Chr(13) + Chr(10) + 1012 'SVG from www.clker.com/clipart-floral-circles.html'+ Chr(13) + Chr(10) + 1013 '(c) 2016, coasting', 1014 mtInformation, [mbOK], 0); 1015 end; 1016 1017 { User actions } 1018 1019 procedure TfrmMain.btnNewClick(Sender: TObject); 1020 begin 1021 { User action } 1022 Label2.Caption := TComponent(Sender).Name; 1023 end; 1024 1025 procedure TfrmMain.btnClipboardClick(Sender: TObject); 1026 begin 1027 { User action } 1028 Label2.Caption := TComponent(Sender).Name; 1029 end; 1030 1031 procedure TfrmMain.btnPrintClick(Sender: TObject); 1032 begin 1033 { User action } 1034 Label2.Caption := TComponent(Sender).Name; 1035 end; 1036 1037 procedure TfrmMain.btnCopyClick(Sender: TObject); 1038 begin 1039 { User action } 1040 Label2.Caption := TComponent(Sender).Name; 1041 end; 1042 1043 procedure TfrmMain.btnPasteClick(Sender: TObject); 1044 begin 1045 { User action } 1046 Label2.Caption := TComponent(Sender).Name; 1047 end; 1048 1049 procedure TfrmMain.btnSaveClick(Sender: TObject); 1050 begin 1051 { User action } 1052 Label2.Caption := TComponent(Sender).Name; 1053 end; 1054 1055 procedure TfrmMain.btnTool1Click(Sender: TObject); 1056 begin 1057 { User action } 1058 Label2.Caption := TComponent(Sender).Name; 1059 end; 1060 1061 procedure TfrmMain.btnTool2Click(Sender: TObject); 1062 begin 1063 { User action } 1064 Label2.Caption := TComponent(Sender).Name; 1065 end; 1066 1067 procedure TfrmMain.btnTool3Click(Sender: TObject); 1068 begin 1069 { User action } 1070 Label2.Caption := TComponent(Sender).Name; 1071 end; 1072 1073 procedure TfrmMain.btnCutClick(Sender: TObject); 1074 begin 1075 { User action } 1076 Label2.Caption := TComponent(Sender).Name; 1077 end; 1078 1079 procedure TfrmMain.btnPreviewClick(Sender: TObject); 1080 begin 1081 { User action } 1082 Label2.Caption := TComponent(Sender).Name; 1083 end; 1084 1085 1086 procedure TfrmMain.btnOpenClick(Sender: TObject); 1087 begin 1088 { User action } 1089 Label2.Caption := TComponent(Sender).Name; 1090 end; 1091 1092 1093 end. 1094