├── Icons.dcr ├── CodrutVisual.res ├── Demo ├── CodDemo.res ├── CodDemo.dpr └── Demo_u.pas ├── Images ├── winreg.png ├── CButton.bmp ├── CProgress.bmp └── CStandardIcon.bmp ├── Dependencies ├── Cod.MesssageConst.pas ├── Cod.Version.pas ├── Cod.ByteUtils.pas ├── Cod.VarHelpers.pas ├── Cod.Windows.ThemeApi.pas └── Cod.ColorUtils.pas ├── Source ├── Cod.Visual.CPSharedLib.pas ├── Cod.Visual.CTransparentUI.pas ├── Cod.Components.Register.pas ├── Cod.Visual.Labels.pas ├── Cod.Visual.LoadIco.pas ├── Cod.AudioBox.pas ├── Cod.Components.pas ├── Cod.Dialogs.PrintDlg.pas ├── Cod.Component.HotKey.pas ├── Cod.Visual.ColorBox.pas ├── Cod.Visual.StarRate.pas ├── Cod.Visual.ColorBright.pas ├── Cod.Visual.StandardIcons.pas ├── Cod.Visual.Panels.pas ├── Cod.Visual.SplashScreen.pas ├── Cod.Visual.ColorWheel.pas └── Cod.Visual.Chart.pas ├── VisualToolMake.groupproj ├── .gitignore ├── CodrutVisual.dpk └── README.md /Icons.dcr: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Codrax/CodrutsVisualLibrary/HEAD/Icons.dcr -------------------------------------------------------------------------------- /CodrutVisual.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Codrax/CodrutsVisualLibrary/HEAD/CodrutVisual.res -------------------------------------------------------------------------------- /Demo/CodDemo.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Codrax/CodrutsVisualLibrary/HEAD/Demo/CodDemo.res -------------------------------------------------------------------------------- /Images/winreg.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Codrax/CodrutsVisualLibrary/HEAD/Images/winreg.png -------------------------------------------------------------------------------- /Images/CButton.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Codrax/CodrutsVisualLibrary/HEAD/Images/CButton.bmp -------------------------------------------------------------------------------- /Images/CProgress.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Codrax/CodrutsVisualLibrary/HEAD/Images/CProgress.bmp -------------------------------------------------------------------------------- /Images/CStandardIcon.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Codrax/CodrutsVisualLibrary/HEAD/Images/CStandardIcon.bmp -------------------------------------------------------------------------------- /Demo/CodDemo.dpr: -------------------------------------------------------------------------------- 1 | program CodDemo; 2 | 3 | uses 4 | Vcl.Forms, 5 | Demo_u in 'Demo_u.pas' {Form1}; 6 | 7 | {$R *.res} 8 | 9 | begin 10 | Application.Initialize; 11 | Application.MainFormOnTaskbar := True; 12 | Application.CreateForm(TForm1, Form1); 13 | Application.Run; 14 | end. 15 | -------------------------------------------------------------------------------- /Dependencies/Cod.MesssageConst.pas: -------------------------------------------------------------------------------- 1 | unit Cod.MesssageConst; 2 | 3 | interface 4 | 5 | resourcestring 6 | // Value 7 | NOT_NUMBER = 'NaN'; // do not localise 8 | STRING_UNKNOWN = 'Unknown'; 9 | NOT_FOUND = 'Not Found'; 10 | NOT_DEFINED = 'Not Defined'; 11 | STRING_YES = 'yes'; 12 | STRING_NO = 'no'; 13 | 14 | // General 15 | DEFAULT_COMPANY = 'Codrut Software'; // do not localise 16 | 17 | // Errors 18 | ERROR_MANIFEST_NOTFOUND = 'Manifest for "%S" not found.'; 19 | ERROR_SET_WALLPAPER = 'Failed to set wallpaper.'; 20 | ERROR_OUT_OF_RANGE = 'The index "%U" exceeds the bounds of the the array.'; 21 | 22 | implementation 23 | 24 | end. -------------------------------------------------------------------------------- /Source/Cod.Visual.CPSharedLib.pas: -------------------------------------------------------------------------------- 1 | unit Cod.Visual.CPSharedLib; 2 | 3 | interface 4 | uses 5 | UITypes, 6 | Classes, 7 | Vcl.Forms, 8 | Vcl.Controls, 9 | Vcl.Graphics, 10 | SysUtils, 11 | Vcl.Styles, 12 | Vcl.Themes, 13 | Types; 14 | 15 | const 16 | nothemes: TArray = ['Windows', 'Mountain_Mist']; 17 | 18 | function StrInArray(const Value : String;const ArrayOfString : Array of String) : Boolean; 19 | function GetFormColor(component: TControl): TColor; 20 | 21 | implementation 22 | 23 | function GetFormColor(component: TControl): TColor; 24 | begin 25 | if StrInArray(TStyleManager.ActiveStyle.Name, nothemes) then begin 26 | try 27 | Result := GetParentForm(component).Color; 28 | except 29 | Result := TStyleManager.ActiveStyle.GetSystemColor(clBtnFace); 30 | end; 31 | end else 32 | Result := TStyleManager.ActiveStyle.GetSystemColor(clBtnFace); 33 | end; 34 | 35 | function StrInArray(const Value : String;const ArrayOfString : Array of String) : Boolean; 36 | var 37 | Loop : String; 38 | begin 39 | for Loop in ArrayOfString do 40 | begin 41 | if Value = Loop then 42 | begin 43 | Exit(true); 44 | end; 45 | end; 46 | result := false; 47 | end; 48 | 49 | end. 50 | -------------------------------------------------------------------------------- /Source/Cod.Visual.CTransparentUI.pas: -------------------------------------------------------------------------------- 1 | unit Cod.Visual.CTransparentUI; 2 | 3 | interface 4 | 5 | uses 6 | SysUtils, 7 | Classes, 8 | Vcl.Controls, 9 | Vcl.Graphics, 10 | Vcl.ExtCtrls, 11 | Cod.Components; 12 | 13 | type 14 | CTestTr = class(TCustomTransparentControl) 15 | constructor Create(AOwner : TComponent); override; 16 | destructor Destroy; override; 17 | private 18 | 19 | protected 20 | procedure Paint; override; 21 | published 22 | property OnMouseEnter; 23 | property OnMouseLeave; 24 | property OnMouseDown; 25 | property OnMouseUp; 26 | property OnMouseMove; 27 | property OnClick; 28 | 29 | property Align; 30 | property Anchors; 31 | property Cursor; 32 | property Visible; 33 | property Enabled; 34 | property Constraints; 35 | property DoubleBuffered; 36 | end; 37 | 38 | implementation 39 | 40 | { CProgress } 41 | 42 | constructor CTestTr.Create(AOwner: TComponent); 43 | begin 44 | inherited; 45 | interceptmouse:=True; 46 | 47 | Width := 100; 48 | Height := 100; 49 | end; 50 | 51 | destructor CTestTr.Destroy; 52 | begin 53 | 54 | inherited; 55 | end; 56 | 57 | 58 | procedure CTestTr.Paint; 59 | begin 60 | inherited; 61 | with canvas do begin 62 | TextOut(10,10,'Hello!'); 63 | 64 | 65 | end; 66 | 67 | end; 68 | 69 | end. 70 | -------------------------------------------------------------------------------- /VisualToolMake.groupproj: -------------------------------------------------------------------------------- 1 | 2 | 3 | {F0B08606-188D-4228-9301-9491A2BB5852} 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | Default.Personality.12 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | -------------------------------------------------------------------------------- /Source/Cod.Components.Register.pas: -------------------------------------------------------------------------------- 1 | unit Cod.Components.Register; 2 | 3 | interface 4 | uses 5 | Classes, 6 | 7 | // Components 8 | Cod.Visual.GlassBlur, 9 | Cod.Visual.ColorBox, 10 | Cod.Visual.ColorBright, 11 | Cod.Visual.ColorWheel, 12 | Cod.Visual.Panels, 13 | Cod.Visual.CPSharedLib, 14 | Cod.Visual.CheckBox, 15 | Cod.Visual.Chart, 16 | Cod.Visual.Labels, 17 | Cod.Visual.StandardIcons, 18 | Cod.Visual.Image, 19 | Cod.Visual.Button, 20 | Cod.Visual.StarRate, 21 | Cod.Visual.SplashScreen, 22 | Cod.Visual.Progress, 23 | Cod.Visual.Slider, 24 | Cod.Visual.LoadIco, 25 | Cod.Visual.Scrollbar, 26 | 27 | // Dialogs 28 | Cod.Dialogs.ColorDialog, 29 | Cod.Dialogs.IconPicker, 30 | Cod.Dialogs.PrintDlg, 31 | 32 | // Non-Visual Components 33 | Cod.Component.HotKey; 34 | 35 | procedure Register; 36 | 37 | const 38 | CATEGORY_VISUAL = 'Codrut Components'; 39 | CATEGORY_TOOL = 'Cod Utils'; 40 | 41 | implementation 42 | 43 | procedure Register; 44 | begin 45 | // UI 46 | RegisterComponents( CATEGORY_VISUAL, [CButton, CGlassBlur, CColorBox, 47 | CColorBright, CColorWheel, CPanel, CMinimisePanel, CCheckBox, CChart, 48 | CLabel, CStandardIcon, CImage, CStarRate, CSplashScreen, CProgress, 49 | CSlider, CLoadAnim, CScrollbar] ); 50 | 51 | // Components 52 | RegisterComponents( CATEGORY_TOOL, [CColorDialog, CIconPicker, CHotKey, 53 | CPrintDialog, CPrintDialog{, TAudioBox}] ); 54 | end; 55 | 56 | end. 57 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Uncomment these types if you want even more clean repository. But be careful. 2 | # It can make harm to an existing project source. Read explanations below. 3 | # 4 | # Resource files are binaries containing manifest, project icon and version info. 5 | # They can not be viewed as text or compared by diff-tools. Consider replacing them with .rc files. 6 | #*.res 7 | # 8 | # Type library file (binary). In old Delphi versions it should be stored. 9 | # Since Delphi 2009 it is produced from .ridl file and can safely be ignored. 10 | #*.tlb 11 | # 12 | # Diagram Portfolio file. Used by the diagram editor up to Delphi 7. 13 | # Uncomment this if you are not using diagrams or use newer Delphi version. 14 | #*.ddp 15 | # 16 | # Visual LiveBindings file. Added in Delphi XE2. 17 | # Uncomment this if you are not using LiveBindings Designer. 18 | #*.vlb 19 | # 20 | # Deployment Manager configuration file for your project. Added in Delphi XE2. 21 | # Uncomment this if it is not mobile development and you do not use remote debug feature. 22 | #*.deployproj 23 | # 24 | # C++ object files produced when C/C++ Output file generation is configured. 25 | # Uncomment this if you are not using external objects (zlib library for example). 26 | #*.obj 27 | # 28 | 29 | # Delphi compiler-generated binaries (safe to delete) 30 | *.exe 31 | *.dll 32 | *.bpl 33 | *.bpi 34 | *.dcp 35 | *.so 36 | *.apk 37 | *.drc 38 | *.map 39 | *.dres 40 | *.rsm 41 | *.tds 42 | *.dcu 43 | *.lib 44 | *.a 45 | *.o 46 | *.ocx 47 | 48 | # Delphi autogenerated files (duplicated info) 49 | *.cfg 50 | *.hpp 51 | *Resource.rc 52 | 53 | # Delphi local files (user-specific info) 54 | *.local 55 | *.identcache 56 | *.projdata 57 | *.tvsconfig 58 | *.dsk 59 | 60 | # Delphi history and backups 61 | __history/ 62 | __recovery/ 63 | *.~* 64 | 65 | # Castalia statistics file (since XE7 Castalia is distributed with Delphi) 66 | *.stat 67 | 68 | # Boss dependency manager vendor folder https://github.com/HashLoad/boss 69 | modules/ 70 | -------------------------------------------------------------------------------- /CodrutVisual.dpk: -------------------------------------------------------------------------------- 1 | package CodrutVisual; 2 | 3 | {$R *.res} 4 | {$R 'Icons.dcr'} 5 | {$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} 6 | {$ALIGN 8} 7 | {$ASSERTIONS ON} 8 | {$BOOLEVAL OFF} 9 | {$DEBUGINFO OFF} 10 | {$EXTENDEDSYNTAX ON} 11 | {$IMPORTEDDATA ON} 12 | {$IOCHECKS ON} 13 | {$LOCALSYMBOLS ON} 14 | {$LONGSTRINGS ON} 15 | {$OPENSTRINGS ON} 16 | {$OPTIMIZATION OFF} 17 | {$OVERFLOWCHECKS OFF} 18 | {$RANGECHECKS OFF} 19 | {$REFERENCEINFO ON} 20 | {$SAFEDIVIDE OFF} 21 | {$STACKFRAMES ON} 22 | {$TYPEDADDRESS OFF} 23 | {$VARSTRINGCHECKS ON} 24 | {$WRITEABLECONST OFF} 25 | {$MINENUMSIZE 1} 26 | {$IMAGEBASE $400000} 27 | {$DEFINE DEBUG} 28 | {$ENDIF IMPLICITBUILDING} 29 | {$IMPLICITBUILD ON} 30 | 31 | requires 32 | rtl, 33 | vcl, 34 | vclimg, 35 | vclwinx, 36 | PngComponents, 37 | IndySystem, 38 | IndyProtocols, 39 | IndyCore; 40 | 41 | contains 42 | Cod.Visual.Button in 'src\Cod.Visual.Button.pas', 43 | Cod.Visual.StarRate in 'src\Cod.Visual.StarRate.pas', 44 | Cod.Visual.SplashScreen in 'src\Cod.Visual.SplashScreen.pas', 45 | Cod.Visual.Progress in 'src\Cod.Visual.Progress.pas', 46 | Cod.Visual.Slider in 'src\Cod.Visual.Slider.pas', 47 | Cod.Visual.CTransparentUI in 'src\Cod.Visual.CTransparentUI.pas', 48 | Cod.Visual.LoadIco in 'src\Cod.Visual.LoadIco.pas', 49 | Cod.Visual.Image in 'src\Cod.Visual.Image.pas', 50 | Cod.Visual.StandardIcons in 'src\Cod.Visual.StandardIcons.pas', 51 | Cod.Visual.Labels in 'src\Cod.Visual.Labels.pas', 52 | Cod.Visual.Chart in 'src\Cod.Visual.Chart.pas', 53 | Cod.Visual.CheckBox in 'src\Cod.Visual.CheckBox.pas', 54 | Cod.Visual.ColorWheel in 'src\Cod.Visual.ColorWheel.pas', 55 | Cod.Visual.ColorBright in 'src\Cod.Visual.ColorBright.pas', 56 | Cod.Visual.ColorBox in 'src\Cod.Visual.ColorBox.pas', 57 | Cod.Visual.Panels in 'src\Cod.Visual.Panels.pas', 58 | Cod.Visual.GlassBlur in 'src\Cod.Visual.GlassBlur.pas', 59 | Cod.Visual.CPSharedLib in 'src\Cod.Visual.CPSharedLib.pas', 60 | Cod.Components.Register in 'src\Cod.Components.Register.pas', 61 | Cod.Visual.Scrollbar in 'src\Cod.Visual.Scrollbar.pas', 62 | Cod.Dialogs.ColorDialog in 'src\Cod.Dialogs.ColorDialog.pas', 63 | Cod.Dialogs.IconPicker in 'src\Cod.Dialogs.IconPicker.pas', 64 | Cod.Dialogs.PrintDlg in 'src\Cod.Dialogs.PrintDlg.pas', 65 | Cod.Components in 'src\Cod.Components.pas', 66 | Cod.Component.HotKey in 'src\Cod.Component.HotKey.pas'; 67 | 68 | end. 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | -------------------------------------------------------------------------------- /Source/Cod.Visual.Labels.pas: -------------------------------------------------------------------------------- 1 | unit Cod.Visual.Labels; 2 | 3 | interface 4 | 5 | uses 6 | SysUtils, 7 | Classes, 8 | Vcl.Controls, 9 | Vcl.Graphics, 10 | Vcl.ExtCtrls, 11 | Cod.Components; 12 | 13 | type 14 | 15 | CLabelHorizontalAllign = (chalLeft, chalRight, chalCenter); 16 | CLabelVerticalAllign = (cvalLeft, cvalRight, cvalCenter); 17 | 18 | CCodFont = class(TMPersistent) 19 | private 20 | FFName: TFontName; 21 | FFSize, 22 | FFOrientation: integer; 23 | FFColor: TColor; 24 | FFStyle: TFontStyles; 25 | FSolidback: boolean; 26 | published 27 | property FontName: TFontName read FFName write FFName; 28 | property Size: integer read FFSize write FFSize; 29 | property Orientation: integer read FFOrientation write FFOrientation; 30 | property Color: TColor read FFColor write FFColor; 31 | property Style: TFontStyles read FFStyle write FFStyle; 32 | property SolidBack: boolean read FSolidback write FSolidback; 33 | end; 34 | 35 | CCustomAlign = class(TMPersistent) 36 | private 37 | FEnablCAlign: boolean; 38 | FCaX, 39 | FCaY: integer; 40 | published 41 | property Enable : boolean read FEnablCAlign write FEnablCAlign; 42 | property CustomX : integer read FCaX write FCaX; 43 | property CustomY : integer read FCaY write FCaY; 44 | end; 45 | 46 | CLabel = class(TCustomTransparentControl) 47 | constructor Create(AOwner : TComponent); override; 48 | destructor Destroy; override; 49 | private 50 | FAuthor, FSite, FVersion: string; 51 | FText: string; 52 | FFont : CCodFont; 53 | FCAlign : CCustomAlign; 54 | FVertAlign : CLabelVerticalAllign; 55 | FHorzAlign : CLabelHorizontalAllign; 56 | FPropFont: boolean; 57 | procedure SetText(const Value: string); 58 | protected 59 | procedure Paint; override; 60 | published 61 | property OnMouseEnter; 62 | property OnMouseLeave; 63 | property OnMouseDown; 64 | property OnMouseUp; 65 | property OnMouseMove; 66 | property OnClick; 67 | 68 | property ShowHint; 69 | property Align; 70 | property Anchors; 71 | property Cursor; 72 | property Visible; 73 | property Enabled; 74 | property Constraints; 75 | property DoubleBuffered; 76 | 77 | property ProportionalFont: boolean read FPropFont write FPropFont; 78 | property AllignCustomized : CCustomAlign read FCAlign write FCAlign; 79 | property AlignVertival : CLabelVerticalAllign read FVertAlign write FVertAlign; 80 | property AlignHorizontal : CLabelHorizontalAllign read FHorzAlign write FHorzAlign; 81 | property Font : CCodFont read FFont write FFont; 82 | property Text : string read FText write SetText; 83 | 84 | property &&&Author: string Read FAuthor; 85 | property &&&Site: string Read FSite; 86 | property &&&Version: string Read FVersion; 87 | end; 88 | 89 | implementation 90 | 91 | { CProgress } 92 | 93 | constructor CLabel.Create(AOwner: TComponent); 94 | begin 95 | inherited; 96 | FAuthor := 'Petculescu Codrut'; 97 | FSite := 'https://www.codrutsoftware.cf'; 98 | FVersion := '0.1'; 99 | 100 | interceptmouse:=True; 101 | 102 | FFont := CCodFont.Create; 103 | with FFOnt do begin 104 | FFName := 'Segoe UI'; 105 | FFSize := 10; 106 | FFOrientation := 0; 107 | FFColor := clBlack; 108 | FSolidback := false; 109 | end; 110 | 111 | FCAlign := CCustomAlign.Create; 112 | with FCAlign do begin 113 | FEnablCAlign := false; 114 | FCaX := 0; 115 | FCaY := 0; 116 | end; 117 | 118 | FText := 'Hello World!'; 119 | 120 | Width := 50; 121 | Height := 20; 122 | end; 123 | 124 | destructor CLabel.Destroy; 125 | begin 126 | FreeAndNil(FFont); 127 | FreeAndNil(AllignCustomized); 128 | inherited; 129 | end; 130 | 131 | 132 | procedure CLabel.Paint; 133 | begin 134 | inherited; 135 | with canvas do begin 136 | if NOT FFont.FSolidback then Brush.Style := bsClear else Brush.Style := bsSolid; 137 | 138 | TextOut(10,10,FText); 139 | end; 140 | 141 | end; 142 | 143 | procedure CLabel.SetText(const Value: string); 144 | begin 145 | FText := Value; 146 | Invalidate; 147 | CLabel(Self.Owner).Paint; 148 | end; 149 | 150 | { CodFont } 151 | 152 | end. 153 | -------------------------------------------------------------------------------- /Source/Cod.Visual.LoadIco.pas: -------------------------------------------------------------------------------- 1 | unit Cod.Visual.LoadIco; 2 | 3 | interface 4 | 5 | uses 6 | SysUtils, 7 | Classes, 8 | Vcl.Controls, 9 | Vcl.Graphics, 10 | Vcl.ExtCtrls, 11 | Cod.Components; 12 | 13 | type 14 | 15 | CAnimType = (canimSpinny, canimDots, canimJustRing, canimCircleRing); 16 | 17 | CLoadAnim = class(TCustomTransparentControl) 18 | constructor Create(AOwner : TComponent); override; 19 | destructor Destroy; override; 20 | private 21 | FAuthor, FSite, FVersion: string; 22 | FSelect: CAnimType; 23 | FAnimate, 24 | FProportional: boolean; 25 | FAnimationSpeed, 26 | CFrame: integer; 27 | FAnimateTimer: TTimer; 28 | procedure FAnimateTimerEvent(Sender: TObject); 29 | procedure SetTimerEnable(const Value: boolean); 30 | procedure SetAnimSpeed(const Value: integer); 31 | protected 32 | procedure Paint; override; 33 | published 34 | property OnMouseEnter; 35 | property OnMouseLeave; 36 | property OnMouseDown; 37 | property OnMouseUp; 38 | property OnMouseMove; 39 | property OnClick; 40 | 41 | property Color; 42 | property ParentColor; 43 | 44 | property ShowHint; 45 | property Align; 46 | property Anchors; 47 | property Cursor; 48 | property Visible; 49 | property Enabled; 50 | property Constraints; 51 | property DoubleBuffered; 52 | 53 | property Animation : CAnimType read FSelect write FSelect; 54 | property Animate : boolean read FAnimate write SetTimerEnable; 55 | property AnimateSpeed : integer read FAnimationSpeed write SetAnimSpeed; 56 | 57 | property &&&Author: string Read FAuthor; 58 | property &&&Site: string Read FSite; 59 | property &&&Version: string Read FVersion; 60 | end; 61 | 62 | implementation 63 | 64 | { CProgress } 65 | 66 | constructor CLoadAnim.Create(AOwner: TComponent); 67 | begin 68 | inherited; 69 | FAuthor := 'Petculescu Codrut'; 70 | FSite := 'https://www.codrutsoftware.cf'; 71 | FVersion := '0.2'; 72 | 73 | interceptmouse:=True; 74 | 75 | FAnimateTImer := TTimer.Create(nil); 76 | with FAnimateTimer do begin 77 | Interval := 10; 78 | OnTimer := FAnimateTimerEvent; 79 | Enabled := true; 80 | end; 81 | 82 | FAnimationSpeed := 10; 83 | 84 | FAnimate := true; 85 | FSelect := canimSpinny; 86 | CFrame := 1; 87 | 88 | Width := 40; 89 | Height := 40; 90 | 91 | FProportional := true; 92 | FAnimate := true; 93 | end; 94 | 95 | destructor CLoadAnim.Destroy; 96 | begin 97 | FAnimateTimer.Enabled := false; 98 | FreeAndNil(FAnimateTimer); 99 | inherited; 100 | end; 101 | 102 | 103 | procedure CLoadAnim.FAnimateTimerEvent(Sender: TObject); 104 | begin 105 | CFrame := CFrame + 1; 106 | if CFrame > 100 then CFrame := 1; 107 | // 108 | Paint; 109 | end; 110 | 111 | procedure CLoadAnim.Paint; 112 | var 113 | w, h, i,a,b,c,d: integer; 114 | Bitmap: TBitMap; 115 | begin 116 | inherited; 117 | if FProportional then if Height < Width then Height := Width else Width := Height; 118 | 119 | // Create 120 | Bitmap := TBitmap.Create(Width, Height); 121 | 122 | // Fill 123 | with Bitmap.Canvas do begin 124 | Brush.Color := Self.Color; 125 | FillRect(ClipRect); 126 | end; 127 | 128 | // Draw 129 | case Animation of 130 | canimSpinny: begin 131 | with Bitmap.Canvas do begin 132 | Pen.Width := 2; 133 | Pen.Color := 12893892; 134 | Brush.Style := bsClear; 135 | w := trunc(width / 10); 136 | h := trunc(height / 10); 137 | for I := 1 to w do 138 | Ellipse( w + i, h + i, width - i - w, height - i - h ); 139 | 140 | pen.Color := clAqua; 141 | brush.Color := clAqua; 142 | a := trunc( cos(CFrame/100 * 360 * pi/180) * (width / 2 - 2 * w) + width / 2 + w ); 143 | b := trunc( sin(CFrame/100 * 360 * pi/180) * (height / 2 - 2 * h) + height / 2 + h ); 144 | c := trunc( cos(CFrame/100 * 360 * pi/180) * (width / 2 - 2 * w) + width / 2 - w ); 145 | d := trunc( sin(CFrame/100 * 360 * pi/180) * (height / 2 - 2 * h) + height / 2 - h ); 146 | Ellipse( a, b,c,d ); 147 | end; 148 | end; 149 | end; 150 | 151 | // Free 152 | Canvas.Draw(0, 0, Bitmap); 153 | Bitmap.Free; 154 | end; 155 | 156 | procedure CLoadAnim.SetAnimSpeed(const Value: integer); 157 | begin 158 | FAnimationSpeed := Value; 159 | FAnimateTimer.Interval := FAnimationSpeed; 160 | Invalidate; 161 | end; 162 | 163 | procedure CLoadAnim.SetTimerEnable(const Value: boolean); 164 | begin 165 | FAnimate := Value; 166 | FAnimateTimer.Enabled := FAnimate; 167 | end; 168 | 169 | end. 170 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # CodrutsVisualLibrary 2 | A suite of component similar to the Fluent Design System in Microsoft Windows 11. Components & Units are made in Delphi 3 | 4 | This Delphi library was made in Embarcadero Delphi Community Edition 10.4. 5 | 6 | You may fork this branch as long as as the original source is propperly credited 7 | 8 | ### Disclaimer 9 | While these components are very powerfull, customizable, and are still in use by lot of projects, please be advised this library is a project I started many years ago and the code I've written is not the best. While I ocasionally update the library to fix bugs, make some patches and maybe add something new, this library is not in active development anymore. Currently, my primary visual-library project I have is the [Codrut-Fluent-Design-System](https://github.com/Codrax/Codrut-Fluent-Design-System). Which is another visual library with more up-to-date code and consistent design. The controls are a little bit less customizable as they follow a certain design guideline, the Windows 11 WinUI3 design specifically. 10 | 11 | ## Components 12 | - CButton - a powerfull extremely customizable button 13 | - CStarRate - a rating item with stars, values can be set to any maximum and minimum value 14 | - CSplashScreen - a splash screen for programs, similar to the UWP app one 15 | - CProgress - a customizable progressbar with multiple states & animations 16 | - CSlider - a integer value slider 17 | - CImage - a image viewing component with image smoothing, gif playback and picture fit settings(Fill, Center, Fit, etc.) 18 | - CStandardIcon - a component displaying a collection of icons such as a checkmark, a star, a red x, etc. 19 | - CChart - a animated pie chart with many customizabilit options 20 | - CCheckbox - a animated checkbox with multiple styles, 3 states support and customizable colors / borders / radius / etc. 21 | - CColorWheel - a color wheel for picking a color 22 | - CColorBright - a brightness slider that works with the CColorWheel 23 | - CColorBox - a box displaying a static color 24 | - CPanel - a panel that can be synced to the accent color 25 | - CMinimisePanel - a panel that can be minimised to take up less space 26 | - CGlassBlur - a Aero effect that works with low-end machines and no external APIs required, supports real-time blur for drawing on top of other apps (like in the Popupmenu in the picture below) 27 | 28 | ## Dependencies 29 | - PNGComponents by TurboPack. From the [GetIT Package Manager](https://getitnow.embarcadero.com/PNGComponents-1.4-Sydney/) 30 | - Units in the dependencies folder 31 | 32 | ## Example programs: 33 | 34 | ![Screenshot_1](https://user-images.githubusercontent.com/68193064/215807786-963e0cbc-4600-4fa1-9694-f26c8b0d1cff.png) 35 | ![Screenshot_5](https://user-images.githubusercontent.com/68193064/215809496-91324da4-2479-43a9-a44c-4b808d8e9010.png) 36 | ![Screenshot_2](https://user-images.githubusercontent.com/68193064/215807797-fdd72be0-c2da-4c78-bc7d-348989d2773d.png) 37 | ![Screenshot_4](https://user-images.githubusercontent.com/68193064/215809550-efaf1530-c8df-4dfe-8404-1b6838cc4240.png) 38 | ![Screenshot_3](https://user-images.githubusercontent.com/68193064/215809562-19ac2a8c-1190-44e7-9c24-43895364023d.png) 39 | ![Screenshot_2](https://user-images.githubusercontent.com/68193064/215809579-7547e477-006e-4baa-95bb-238f85d3d362.png) 40 | ![Screenshot_1](https://user-images.githubusercontent.com/68193064/215809592-9896863c-c7f1-42e1-8950-fc1e73ee4f2c.png) 41 | 42 | 43 | 44 | #### The following 2 pictures represent some upcoming components to the suite of components, which is just a context menu build with the already existing components 45 | 46 | ![Screenshot_1](https://user-images.githubusercontent.com/68193064/215798628-e69d95e7-494c-4ec0-a204-203033d0b471.png) 47 | ![Screenshot_2](https://user-images.githubusercontent.com/68193064/215798691-356545a9-25ec-4fe9-b855-33056815403a.png) 48 | 49 | 50 | ## Component Demo: 51 | 52 | ![Screenshot_3](https://user-images.githubusercontent.com/68193064/215806936-9b5c80da-d022-416d-9a63-87999be5e9e1.png) 53 | ![Screenshot_4](https://user-images.githubusercontent.com/68193064/215806967-bd53ccf1-b385-4b19-a996-0e6be3aa0ae4.png) 54 | !![Screenshot_6](https://user-images.githubusercontent.com/68193064/215806995-04e80a16-8013-4068-a237-c9b1bf119f1b.png) 55 | [Screenshot_5](https://user-images.githubusercontent.com/68193064/215806982-bcf65527-43b9-4e93-8506-ba57bddb3380.png) 56 | ![Screenshot_7](https://user-images.githubusercontent.com/68193064/215807060-deb6d35f-8ad2-45b8-9127-65d35ec45074.png) 57 | ![Screenshot_10](https://user-images.githubusercontent.com/68193064/215807110-3fb6d75c-aa14-4b72-b1ad-1bd4fb856fe8.png) 58 | ![Screenshot_8](https://user-images.githubusercontent.com/68193064/215807117-1243f8e6-61a6-43e8-8fb1-6323298cf88e.png) 59 | ![Screenshot_11](https://user-images.githubusercontent.com/68193064/215807134-b89cbfe0-8730-4409-92c6-81ce5677ec56.png) 60 | -------------------------------------------------------------------------------- /Source/Cod.AudioBox.pas: -------------------------------------------------------------------------------- 1 | unit Cod.AudioBox; 2 | 3 | ///////////////////////////////////////////////////////////// 4 | /// /// 5 | /// /// 6 | /// ATTENTION! /// 7 | /// /// 8 | /// This component is based on the /// 9 | /// Bass Audio Library for Delphi (unofficial) /// 10 | /// /// 11 | /// If you do not have this library, please /// 12 | /// download it from: /// 13 | /// https://github.com/TDDung/Delphi-BASS /// 14 | /// /// 15 | /// Or alternatively.. /// 16 | /// Remove this unit from the project /// 17 | /// /// 18 | ///////////////////////////////////////////////////////////// 19 | 20 | interface 21 | uses 22 | Windows, Messages, SysUtils, Variants, Classes, Graphics, 23 | Controls, Dialogs, ExtCtrls, Menus, Cod.SysUtils, Cod.Audio; 24 | 25 | type 26 | TAudioBox = class(TComponent) 27 | private 28 | Player: TAudioPlayer; 29 | 30 | FFileName, 31 | FUrl: string; 32 | 33 | function GetPlayStat: TPlayStatus; 34 | 35 | function GetDuration: int64; 36 | function GetDurationSec: single; 37 | 38 | function GetPosition: int64; 39 | function GetPosSec: single; 40 | 41 | procedure SetPosition(const Value: int64); 42 | procedure SetPosSec(const Value: single); 43 | 44 | function GetLoop: boolean; 45 | procedure SetLoop(const Value: boolean); 46 | 47 | function GetVolume: single; 48 | procedure SetVolume(const Value: single); 49 | 50 | published 51 | property FileName: string read FFileName write FFileName; 52 | property UrlAdress: string read FUrl write FUrl; 53 | 54 | property PlayStatus: TPlayStatus read GetPlayStat; 55 | 56 | property Loop: boolean read GetLoop write SetLoop; 57 | 58 | property Volume: single read GetVolume write SetVolume; 59 | 60 | public 61 | constructor Create(AOwner: TComponent); override; 62 | destructor Destroy; override; 63 | 64 | // Non-Component properties 65 | property Duration: int64 read GetDuration; 66 | property DurationSec: single read GetDurationSec; 67 | 68 | property Position: int64 read GetPosition write SetPosition; 69 | property PositionSeconds: single read GetPosSec write SetPosSec; 70 | 71 | // Public Proc 72 | procedure Play; 73 | procedure Pause; 74 | procedure Stop; 75 | 76 | procedure OpenFile; 77 | procedure OpenURL; 78 | procedure CloseFile; 79 | 80 | function IsFileOpened: boolean; 81 | function GetCPUUsage: single; 82 | function GetAudioStream: cardinal; 83 | 84 | end; 85 | 86 | implementation 87 | 88 | { TAudioBox } 89 | 90 | procedure TAudioBox.CloseFile; 91 | begin 92 | Player.CloseFile; 93 | end; 94 | 95 | constructor TAudioBox.Create(AOwner: TComponent); 96 | begin 97 | inherited; 98 | Player := TAudioPlayer.Create; 99 | end; 100 | 101 | destructor TAudioBox.Destroy; 102 | begin 103 | Player.Free; 104 | inherited; 105 | end; 106 | 107 | function TAudioBox.GetAudioStream: cardinal; 108 | begin 109 | Result := Player.Stream; 110 | end; 111 | 112 | function TAudioBox.GetCPUUsage: single; 113 | begin 114 | Result := Player.GetCPUUsage; 115 | end; 116 | 117 | function TAudioBox.GetDuration: int64; 118 | begin 119 | Result := Player.Duration; 120 | end; 121 | 122 | function TAudioBox.GetDurationSec: single; 123 | begin 124 | Result := Player.DurationSeconds; 125 | end; 126 | 127 | function TAudioBox.GetLoop: boolean; 128 | begin 129 | Result := Player.Loop; 130 | end; 131 | 132 | function TAudioBox.GetPlayStat: TPlayStatus; 133 | begin 134 | Result := Player.PlayStatus; 135 | end; 136 | 137 | function TAudioBox.GetPosition: int64; 138 | begin 139 | Result := Player.Position; 140 | end; 141 | 142 | function TAudioBox.GetPosSec: single; 143 | begin 144 | Result := Player.PositionSeconds; 145 | end; 146 | 147 | function TAudioBox.GetVolume: single; 148 | begin 149 | Result := Player.Volume; 150 | end; 151 | 152 | function TAudioBox.IsFileOpened: boolean; 153 | begin 154 | Result := Player.IsFileOpen; 155 | end; 156 | 157 | procedure TAudioBox.OpenFile; 158 | begin 159 | Player.OpenFile( FFileName ); 160 | end; 161 | 162 | procedure TAudioBox.OpenURL; 163 | begin 164 | Player.OpenURL( FURL ); 165 | end; 166 | 167 | procedure TAudioBox.Pause; 168 | begin 169 | Player.Pause; 170 | end; 171 | 172 | procedure TAudioBox.Play; 173 | begin 174 | Player.Play; 175 | end; 176 | 177 | procedure TAudioBox.SetLoop(const Value: boolean); 178 | begin 179 | Player.Loop := Value; 180 | end; 181 | 182 | procedure TAudioBox.SetPosition(const Value: int64); 183 | begin 184 | Player.Position := Value; 185 | end; 186 | 187 | procedure TAudioBox.SetPosSec(const Value: single); 188 | begin 189 | Player.PositionSeconds := Value; 190 | end; 191 | 192 | procedure TAudioBox.SetVolume(const Value: single); 193 | begin 194 | Player.Volume := Value; 195 | end; 196 | 197 | procedure TAudioBox.Stop; 198 | begin 199 | Player.Stop 200 | end; 201 | 202 | end. 203 | -------------------------------------------------------------------------------- /Source/Cod.Components.pas: -------------------------------------------------------------------------------- 1 | unit Cod.Components; 2 | 3 | {$SCOPEDENUMS ON} 4 | 5 | interface 6 | 7 | uses 8 | Types, UITypes, Classes, System.UIConsts, Vcl.Graphics, 9 | Variants, System.Win.Registry, Winapi.Windows, SysUtils, System.DateUtils, 10 | Cod.Registry, TypInfo; 11 | 12 | type 13 | CAccentColor = (None, Accent, AccentAdjust, AccentCustom); 14 | CCurrentTheme = (Auto, Light, Dark); 15 | CControlState = (Leave, Enter, Down); 16 | 17 | CComponentOnPaint = procedure(Sender: TObject) of object; 18 | 19 | CControl = interface 20 | //['{5098EF5C-0451-490D-A0B2-24C414F21A24}'] 21 | 22 | procedure UpdateAccent; 23 | end; 24 | 25 | TMPersistent = class(TPersistent) 26 | Owner : TPersistent; 27 | constructor Create(AOwner : TPersistent); overload; virtual; 28 | 29 | procedure Assign(Source: TPersistent); override; 30 | end; 31 | 32 | function GetColorSat(color: TColor; ofing: integer = 255): integer; 33 | function ChangeColorSat(clr: TColor; perc: integer): TColor; 34 | 35 | function GetAccentColor(Accent: CAccentColor): TColor; 36 | function GetTheme: CCurrentTheme; 37 | procedure SetTheme(ChangeTo: CCurrentTheme); 38 | procedure SyncAccentColor; 39 | function IsAppsUseDarkTheme: Boolean; 40 | 41 | procedure CheckForUpdateAccent; 42 | 43 | var 44 | CurrentTheme: CCurrentTheme; 45 | AccentColor: TColor; 46 | AdjustedAccentColor: TColor; 47 | CustomAccentColor: TColor = $00C57517; 48 | 49 | OnUpdateAccentColor: procedure; 50 | 51 | LastCheck: TDateTime; 52 | JustStarted: boolean; 53 | 54 | implementation 55 | 56 | function IsAppsUseDarkTheme: Boolean; 57 | var 58 | R: TRegistry; 59 | begin 60 | Result := False; 61 | R := TRegistry.Create; 62 | try 63 | R.RootKey := HKEY_CURRENT_USER; 64 | if R.OpenKeyReadOnly('Software\Microsoft\Windows\CurrentVersion\Themes\Personalize\') and R.ValueExists('AppsUseLightTheme') then begin 65 | Result := R.ReadInteger('AppsUseLightTheme') <> 1; 66 | end; 67 | finally 68 | R.Free; 69 | end; 70 | end; 71 | 72 | function GetColorSat(color: TColor; ofing: integer): integer; 73 | var 74 | l1, l2, l3: real; 75 | R, G, B: integer; 76 | begin 77 | R := GetRValue(color); 78 | G := GetGValue(color); 79 | B := GetBValue(color); 80 | 81 | l1 := R / 255 * ofing; 82 | l2 := G / 255 * ofing; 83 | l3 := B / 255 * ofing; 84 | 85 | Result := trunc((l1 + l2 + l3)/3); 86 | end; 87 | 88 | function ChangeColorSat(clr: TColor; perc: integer): TColor; 89 | var 90 | RBGval: longint; 91 | R, G, B: integer; 92 | begin 93 | RBGval := ColorToRGB(clr); 94 | R := GetRValue(RBGval); 95 | G := GetGValue(RBGval); 96 | B := GetBValue(RBGval); 97 | 98 | R := R + perc; 99 | G := G + perc; 100 | B := B + perc; 101 | 102 | if R < 0 then R := 0; 103 | if G < 0 then G := 0; 104 | if B < 0 then B := 0; 105 | 106 | if R > 255 then R := 255; 107 | if G > 255 then G := 255; 108 | if B > 255 then B := 255; 109 | 110 | Result := RGB(r,g,b); 111 | end; 112 | 113 | procedure CheckForUpdateAccent; 114 | begin 115 | if JustStarted or (SecondsBetween(Now, LastCheck) > 30) then 116 | SyncAccentColor 117 | end; 118 | 119 | function GetAccentColor(Accent: CAccentColor): TColor; 120 | begin 121 | Result := 13924352; 122 | CheckForUpdateAccent; 123 | 124 | case Accent of 125 | CAccentColor.Accent: Result := AccentColor; 126 | CAccentColor.AccentAdjust: Result := AdjustedAccentColor; 127 | CAccentColor.AccentCustom: Result := CustomAccentColor; 128 | end; 129 | end; 130 | 131 | function GetTheme: CCurrentTheme; 132 | begin 133 | Result := CurrentTheme; 134 | end; 135 | 136 | procedure SetTheme(ChangeTo: CCurrentTheme); 137 | begin 138 | if changeto = CurrentTheme then 139 | Exit; 140 | 141 | CurrentTheme := changeto; 142 | 143 | SyncAccentColor; 144 | end; 145 | 146 | procedure SyncAccentColor; 147 | var 148 | R: TRegistry; 149 | Value: Cardinal; 150 | CSat: integer; 151 | //themedark: boolean; 152 | begin 153 | LastCheck := Now; 154 | 155 | AccentColor := $D77800; // Default value on error 156 | R := TRegistry.Create; 157 | try 158 | R.RootKey := HKEY_CURRENT_USER; 159 | if R.OpenKeyReadOnly('Software\Microsoft\Windows\DWM\') and R.ValueExists('AccentColor') then begin 160 | Value := R.ReadCardinal('AccentColor'); 161 | 162 | AccentColor := Value mod $FF000000; // ARGB to RGB 163 | AdjustedAccentColor := AccentColor; 164 | end; 165 | finally 166 | R.Free; 167 | end; 168 | 169 | CSat := GetColorSat(AccentColor, 255); 170 | 171 | {themedark := false; 172 | if CurrentTheme = ctAuto then 173 | themedark := IsAppsUseDarkTheme 174 | else 175 | if CurrentTheme = ctDark then 176 | themedark := true; } 177 | 178 | 179 | //if themedark then 180 | if CSat < 110 then 181 | AdjustedAccentColor := ChangeColorSat(AccentColor, 110 - CSat); 182 | 183 | if CSat > 155 then 184 | AdjustedAccentColor := ChangeColorSat(AccentColor, (CSat - 155) * -1); 185 | 186 | // Prop 187 | if Assigned(OnUpdateAccentColor) then 188 | OnUpdateAccentColor; 189 | end; 190 | 191 | { TMPersistent } 192 | 193 | function PropertyExists(Instance: TObject; const PropName: string): boolean; overload; 194 | var 195 | AProp: PPropInfo; 196 | begin 197 | AProp := GetPropInfo(PTypeInfo(Instance.ClassInfo), PropName); 198 | 199 | Result := AProp <> nil; 200 | end; 201 | 202 | procedure TMPersistent.Assign(Source: TPersistent); 203 | var 204 | APropName: string; 205 | PropList: PPropList; 206 | PropCount, i: Integer; 207 | begin 208 | if Source is TMPersistent then 209 | begin 210 | PropCount := GetPropList(Source.ClassInfo, tkProperties, nil); 211 | if PropCount > 0 then 212 | begin 213 | GetMem(PropList, PropCount * SizeOf(PPropInfo)); 214 | try 215 | GetPropList(Source.ClassInfo, tkProperties, PropList); 216 | for i := 0 to PropCount - 1 do 217 | begin 218 | APropName := string(PropList^[i]^.Name); 219 | if PropertyExists(Self, APropName) then 220 | SetPropValue(Self, APropName, GetPropValue(Source, string(PropList^[i]^.Name))); 221 | end; 222 | finally 223 | FreeMem(PropList); 224 | end; 225 | end; 226 | end 227 | else 228 | inherited Assign(Source); 229 | end; 230 | 231 | constructor TMPersistent.Create(AOwner: TPersistent); 232 | begin 233 | inherited Create; 234 | Owner := AOwner; 235 | end; 236 | 237 | end. 238 | -------------------------------------------------------------------------------- /Source/Cod.Dialogs.PrintDlg.pas: -------------------------------------------------------------------------------- 1 | unit Cod.Dialogs.PrintDlg; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, Winapi.Messages, SysUtils, Classes, Graphics, CommDlg, 7 | Cod.Graphics, Vcl.Dialogs, Vcl.Controls, Vcl.Forms; 8 | 9 | type 10 | CPrintDialog = class(TComponent) 11 | private 12 | FModal: boolean; 13 | FCollate: boolean; 14 | FCopies, 15 | FFromPage, 16 | FToPage, 17 | FMaxPage, 18 | FMinPage: integer; 19 | FPrintRange: TPrintRange; 20 | FPrintToFile: boolean; 21 | FDocumentName: string; 22 | FShowPrintToFile: boolean; 23 | FPageSetup: boolean; 24 | 25 | FPageSize: TRect; 26 | ADocInfo: TDocInfo; 27 | 28 | function GetCanvas: TCanvas; 29 | 30 | published 31 | property Collate: boolean read FCollate write FCollate default false; 32 | property Copies: integer read FCopies write FCopies default 0; 33 | property FromPage: integer read FFromPage write FFromPage default 0; 34 | property ToPage: integer read FToPage write FToPage default 0; 35 | property MaxPage: integer read FMaxPage write FMaxPage default 0; 36 | property MinPage: integer read FMinPage write FMinPage default 0; 37 | property PrintRange: TPrintRange read FPrintRange write FPrintRange default prAllPages; 38 | property PrintToFile: boolean read FPrintToFile write FPrintToFile default false; 39 | property ShowPrintToFile: boolean read FShowPrintToFile write FShowPrintToFile default true; 40 | property DocumentName: string read FDocumentName write FDocumentName; 41 | property Modal: boolean read FModal write FModal default true; 42 | property PageSetup: boolean read FPageSetup write FPageSetup default false; 43 | 44 | property Canvas: TCanvas read GetCanvas; 45 | 46 | public 47 | constructor Create(AOwner: TComponent); override; 48 | destructor Destroy; override; 49 | 50 | // Dialog 51 | function Execute: boolean; 52 | procedure FreeDialogHDC; 53 | 54 | // Page Info 55 | function PageSize: TRect; 56 | procedure StartDocument; 57 | procedure EndDocument; 58 | procedure NewPage; 59 | procedure ClosePage; 60 | 61 | var 62 | DialogHDC: HDC; 63 | end; 64 | 65 | implementation 66 | 67 | constructor CPrintDialog.Create(AOwner: TComponent); 68 | begin 69 | inherited Create(AOwner); 70 | 71 | DocumentName := 'Print Document'; 72 | 73 | FModal := true; 74 | FShowPrintToFile := true; 75 | end; 76 | 77 | destructor CPrintDialog.Destroy; 78 | begin 79 | inherited; 80 | end; 81 | 82 | procedure CPrintDialog.EndDocument; 83 | begin 84 | EndDoc( DialogHDC ); 85 | end; 86 | 87 | procedure CPrintDialog.ClosePage; 88 | begin 89 | EndPage( DialogHDC ); 90 | end; 91 | 92 | function CPrintDialog.Execute: boolean; 93 | var 94 | PrintDlgRec: TPrintDlgW; 95 | begin 96 | Result := false; 97 | 98 | FillChar(ADocInfo, SizeOf(DocInfo), 0); 99 | with ADocInfo do 100 | begin 101 | cbSize := SizeOf(DocInfo); 102 | lpszDocName := PChar(DocumentName); 103 | lpszOutput := nil; 104 | lpszDatatype := nil; 105 | fwType := 0; 106 | end; 107 | FillChar(PrintDlgRec, SizeOf(PrintDlgRec), 0); 108 | 109 | with PrintDlgRec do 110 | begin 111 | nCopies := Copies; 112 | nFromPage := FromPage; 113 | nToPage := ToPage; 114 | nMaxPage := MaxPage; 115 | nMinPage := MinPage; 116 | 117 | // Print Range 118 | case PrintRange of 119 | prAllPages: Flags := Flags or PD_ALLPAGES; 120 | prSelection: Flags := Flags or PD_SELECTION; 121 | prPageNums: Flags := Flags or PD_PAGENUMS; 122 | end; 123 | 124 | // Options 125 | if Collate then 126 | Flags := Flags or PD_COLLATE; 127 | 128 | if PrintToFile then 129 | Flags := Flags or PD_PRINTTOFILE; 130 | 131 | // Configure Dialog 132 | if not FShowPrintToFile then 133 | Flags := Flags or PD_HIDEPRINTTOFILE; 134 | 135 | if FPageSetup then 136 | Flags := Flags or PD_PRINTSETUP; 137 | 138 | // Config 139 | lStructSize := SizeOf(PrintDlgRec); 140 | if Modal then 141 | hwndOwner := Application.MainForm.Handle 142 | else 143 | hwndOwner := Application.Handle; 144 | Flags := Flags or PD_RETURNDC; 145 | end; 146 | 147 | if PrintDlgW(PrintDlgRec) then 148 | begin 149 | Result := true; 150 | 151 | DialogHDC := PrintDlgRec.hDC; 152 | 153 | // Use the GetDeviceCaps function to retrieve information about the printer 154 | GetDeviceCaps(DialogHDC, TECHNOLOGY); 155 | GetDeviceCaps(DialogHDC, DC_COLORDEVICE); 156 | GetDeviceCaps(DialogHDC, BITSPIXEL); 157 | GetDeviceCaps(DialogHDC, PLANES); 158 | GetDeviceCaps(DialogHDC, NUMCOLORS); 159 | GetDeviceCaps(DialogHDC, LOGPIXELSX); 160 | GetDeviceCaps(DialogHDC, LOGPIXELSY); 161 | 162 | // Get Size 163 | FPageSize := Rect(0, 0, GetDeviceCaps(DialogHDC, PHYSICALWIDTH), 164 | GetDeviceCaps(DialogHDC, PHYSICALHEIGHT)); 165 | 166 | // Get Data 167 | with PrintDlgRec do 168 | begin 169 | // Pages 170 | Copies := nCopies; 171 | FromPage := nFromPage; 172 | ToPage := nToPage; 173 | MaxPage := nMaxPage; 174 | MinPage := nMinPage; 175 | 176 | // Flags 177 | if (Flags and PD_PAGENUMS) <> 0 then 178 | PrintRange := prPageNums 179 | else 180 | if (Flags and PD_SELECTION) <> 0 then 181 | PrintRange := prSelection 182 | else 183 | PrintRange := prAllPages; 184 | 185 | // All Pages 186 | if PrintRange = prAllPages then 187 | begin 188 | FromPage := MinPage; 189 | ToPage := MaxPage; 190 | end; 191 | end; 192 | end; 193 | end; 194 | 195 | 196 | procedure CPrintDialog.FreeDialogHDC; 197 | begin 198 | DeleteDC(Self.DialogHDC); 199 | end; 200 | 201 | function CPrintDialog.GetCanvas: TCanvas; 202 | begin 203 | Result := TCanvas.Create; 204 | Result.Handle := DialogHDC; 205 | end; 206 | 207 | procedure CPrintDialog.NewPage; 208 | begin 209 | StartPage( DialogHDC ); 210 | end; 211 | 212 | function CPrintDialog.PageSize: TRect; 213 | begin 214 | Result := FPageSize; 215 | end; 216 | 217 | procedure CPrintDialog.StartDocument; 218 | begin 219 | StartDoc( DialogHDC, ADocInfo); 220 | end; 221 | 222 | end. 223 | -------------------------------------------------------------------------------- /Source/Cod.Component.HotKey.pas: -------------------------------------------------------------------------------- 1 | {***********************************************************} 2 | { Codrut HotHey } 3 | { } 4 | { version 0.1 } 5 | { ALPHA } 6 | { } 7 | { } 8 | { } 9 | { } 10 | { } 11 | { -- WORK IN PROGRESS -- } 12 | {***********************************************************} 13 | 14 | unit Cod.Component.HotKey; 15 | 16 | interface 17 | uses 18 | Windows, Messages, SysUtils, Variants, Classes, Graphics, 19 | Controls, Dialogs, ExtCtrls, Menus, Cod.SysUtils, Forms; 20 | 21 | type 22 | CHotKey = class; 23 | 24 | CHKeyFocusMode = (chfFormFocused, chfControlFocused, chfApplicationFocused, chfGlobal); 25 | 26 | CHOnExecute = procedure(Sender: CHotKey; Mode: CHKeyFocusMode; Shortcut: string) of object; 27 | 28 | CHotKey = class(TComponent) 29 | public 30 | constructor Create(AOwner: TComponent); override; 31 | destructor Destroy; override; 32 | 33 | private 34 | FAuthor, FSite, FVersion: string; 35 | FShortCut: string; 36 | FEnable, 37 | FRepeatUntilNot, 38 | FExecOnce: boolean; 39 | FFocusMode: CHKeyFocusMode; 40 | FOnExecute: CHOnExecute; 41 | FCheckTimer: TTimer; 42 | FLegShortCut: TShortCut; 43 | FInterval: integer; 44 | LastValue: boolean; 45 | Componen: TComponent; 46 | 47 | procedure FTimerAct(Sender: TObject); 48 | procedure SetEnable(const Value: boolean); 49 | function GetKeyCode(text: string): integer; 50 | procedure SetShortLegCut(const Value: TShortCut); 51 | function GetTNext(text: string): string; 52 | procedure SetInterval(const Value: integer); 53 | procedure SetNotExecMode(const Value: boolean); 54 | function GetOwningForm(Control: TComponent): TForm; 55 | 56 | published 57 | property ShortCut: string read FShortCut write FShortCut; 58 | property Mode: CHKeyFocusMode read FFocusMode write FFocusMode; 59 | property Enabled: boolean read FEnable write SetEnable; 60 | 61 | property RepeatUntilNot: boolean read FRepeatUntilNot write SetNotExecMode; 62 | 63 | property ParentComponent: TComponent read Componen write Componen; 64 | 65 | property VerifyInterval: integer read FInterval write SetInterval; 66 | property ExecuteOnce: boolean read FExecOnce write FExecOnce; 67 | property OnExecute: CHOnExecute read FOnExecute write FOnExecute; 68 | 69 | property LegacyShortCut: TShortCut read FLegShortCut write SetShortLegCut; 70 | 71 | property Author: string Read FAuthor; 72 | property Site: string Read FSite; 73 | property Version: string Read FVersion; 74 | end; 75 | 76 | implementation 77 | 78 | { CodHotKey } 79 | 80 | constructor CHotKey.Create(AOwner: TComponent); 81 | begin 82 | inherited Create(AOwner); 83 | FAuthor := 'Petculescu Codrut'; 84 | FSite := 'https://www.codrutsoftware.cf'; 85 | FVersion := '1.0'; 86 | 87 | FCheckTimer := TTImer.Create(Self); 88 | with FCheckTimer do begin 89 | Enabled := false; 90 | Interval := 1; 91 | OnTimer := FTimerAct; 92 | end; 93 | 94 | FInterval := 1; 95 | 96 | FRepeatUntilNot := false; 97 | FExecOnce := true; 98 | 99 | FFocusMode := chfFormFocused; 100 | 101 | FEnable := false; 102 | end; 103 | 104 | destructor CHotKey.Destroy; 105 | begin 106 | FCheckTimer.Enabled := false; 107 | FreeAndNil( FCheckTimer ); 108 | 109 | inherited Destroy; 110 | end; 111 | 112 | function CHotKey.GetOwningForm(Control: TComponent): TForm; 113 | var 114 | LOwner: TComponent; 115 | begin 116 | LOwner:= Control.Owner; 117 | while Assigned(LOwner) and not(LOwner is TCustomForm) do begin 118 | LOwner:= LOwner.Owner; 119 | end; {while} 120 | Result:= TForm(LOwner); 121 | end; 122 | 123 | procedure CHotKey.FTimerAct(Sender: TObject); 124 | var 125 | ps, tx: string; 126 | arepressed, 127 | focusmode: boolean; 128 | value: integer; 129 | begin 130 | if (FShortCut = '') or (IsInIDE) then Exit; 131 | //ps := ShortCutToText(FShortCut); 132 | focusmode := false; 133 | 134 | case FFocusMode of 135 | chfFormFocused: try focusmode := GetOwningForm(Self).Active; except end; 136 | chfControlFocused: if Assigned(Componen) then try focusmode := TWinControl(Componen).Focused; except end else focusmode := false; 137 | chfApplicationFocused: focusmode := Application.Active; 138 | chfGlobal: focusmode := true; 139 | end; 140 | 141 | if NOT focusmode then Exit; 142 | 143 | 144 | arepressed := true; 145 | 146 | tx := FShortCut; 147 | tx := tx.Replace(' ', ''); 148 | 149 | repeat 150 | ps := GetTNext(tx); 151 | tx := Copy(tx, Length(ps) + 2, tx.Length ); 152 | 153 | value := GetKeyCode(ps); 154 | 155 | if (NOT GetKeyState(value) < 0) and (value <> 0) then arepressed := false; 156 | until (value = 0); 157 | 158 | if FRepeatUntilNot then arepressed := NOT arepressed; 159 | 160 | 161 | if arepressed then 162 | if Assigned(OnExecute) and NOT (ExecuteOnce and lastvalue) then OnExecute(Self, FFocusMode, FShortCut); 163 | 164 | lastvalue := arepressed; 165 | end; 166 | 167 | function CHotKey.GetKeyCode(text: string): integer; 168 | begin 169 | Result := 0; 170 | if Length (text) > 1 then begin 171 | if (ANSILowerCase(text) = 'ctrl') or (ANSILowerCase(text) = 'control') then Result := 17; 172 | if (ANSILowerCase(text) = 'esc') or (ANSILowerCase(text) = 'escape') then Result := 27; 173 | if ANSILowerCase(text) = 'shift' then Result := 16; 174 | if ANSILowerCase(text) = 'alt' then Result := 18; 175 | 176 | if ANSILowerCase(text) = 'home' then Result := 36; 177 | if ANSILowerCase(text) = 'menu' then Result := 93; 178 | if (ANSILowerCase(text) = 'del') or (ANSILowerCase(text) = 'delete') then Result := 46; 179 | 180 | if ANSILowerCase(text) = 'enter' then Result := 13; 181 | if ANSILowerCase(text) = 'tab' then Result := VK_TAB; 182 | 183 | if ANSILowerCase(text) = 'left' then Result := 37; 184 | if ANSILowerCase(text) = 'up' then Result := 38; 185 | if ANSILowerCase(text) = 'right' then Result := 39; 186 | if ANSILowerCase(text) = 'down' then Result := 40; 187 | 188 | if ANSILowerCase(text) = '/' then Result := 191; 189 | 190 | if ANSILowerCase(text) = 'prntscrn' then Result := VK_SNAPSHOT; 191 | end; 192 | 193 | if (Result = 0) and (text <> '') then 194 | Result := integer(text[1]); 195 | end; 196 | 197 | function CHotKey.GetTNext(text: string): string; 198 | begin 199 | Result := Copy(text, 1, pos('+',text) - 1); 200 | 201 | if Result = '' then 202 | Result := text; 203 | end; 204 | 205 | procedure CHotKey.SetEnable(const Value: boolean); 206 | begin 207 | FEnable := Value; 208 | FCheckTimer.Enabled := Value; 209 | end; 210 | 211 | procedure CHotKey.SetInterval(const Value: integer); 212 | begin 213 | FInterval := Value; 214 | if FInterval < 1 then FInterval := 1; 215 | 216 | FCheckTimer.Interval := Value; 217 | end; 218 | 219 | procedure CHotKey.SetNotExecMode(const Value: boolean); 220 | begin 221 | FRepeatUntilNot := Value; 222 | 223 | if Value then 224 | FExecOnce := false; 225 | end; 226 | 227 | procedure CHotKey.SetShortLegCut(const Value: TShortCut); 228 | begin 229 | if Value <> 0 then 230 | FShortCut := ShortCutToText(Value); 231 | end; 232 | 233 | end. 234 | -------------------------------------------------------------------------------- /Dependencies/Cod.Version.pas: -------------------------------------------------------------------------------- 1 | unit Cod.Version; 2 | 3 | interface 4 | uses 5 | System.SysUtils, System.Classes, IdSNTP, 6 | System.Types, DateUtils, IdHTTP, Math, Cod.Math, Cod.Types, 7 | JSON, IdSSLOpenSSL; 8 | 9 | type 10 | TVersion = record 11 | Major, 12 | Minor, 13 | Maintenance, 14 | Build: cardinal; 15 | 16 | APIResponse: TJsonObject; 17 | 18 | // Main 19 | constructor Create(AMajor, AMinor, AMaintenance: cardinal; ABuild: cardinal=0); overload; 20 | constructor Create(AString: string); overload; 21 | procedure Clear; 22 | 23 | // Load 24 | procedure Parse(From: string); 25 | procedure NetworkLoad(URL: string); 26 | procedure HtmlLoad(URL: string); 27 | procedure APILoad(AppName: string; Endpoint: string = 'https://api.codrutsoft.com/'); overload; 28 | procedure APILoad(AppName: string; Current: TVersion; Endpoint: string = 'https://api.codrutsoft.com/'); overload; 29 | 30 | // Utils 31 | function GetDownloadLink(JSONValue: string = 'updateurl'): string; 32 | 33 | // Comparation 34 | function Empty: boolean; 35 | function CompareTo(Version: TVersion): TValueRelationship; 36 | function NewerThan(Version: TVersion): boolean; 37 | function OlderThan(Version: TVersion): boolean; 38 | 39 | // Conversion 40 | function ToString: string; overload; 41 | function ToString(IncludeBuild: boolean): string; overload; 42 | function ToString(Separator: char; IncludeBuild: boolean = false): string; overload; 43 | 44 | // Operators 45 | class operator Equal(A, B: TVersion): Boolean; 46 | class operator NotEqual(A, B: TVersion): Boolean; 47 | end; 48 | 49 | function MakeVersion(Major, Minor, Maintenance: cardinal; Build: cardinal = 0): TVersion; 50 | 51 | const 52 | VERSION_EMPTY: TVersion = (Major:0; Minor:0; Maintenance:0; Build:0); 53 | 54 | implementation 55 | 56 | function MakeVersion(Major, Minor, Maintenance: cardinal; Build: cardinal = 0): TVersion; 57 | begin 58 | Result.Major := Major; 59 | Result.Minor := Minor; 60 | Result.Maintenance := Maintenance; 61 | Result.Build := Build; 62 | end; 63 | 64 | 65 | { TVersion } 66 | 67 | procedure TVersion.NetworkLoad(URL: string); 68 | var 69 | IdHttp: TIdHTTP; 70 | HTML: string; 71 | begin 72 | IdHttp := TIdHTTP.Create(nil); 73 | try 74 | HTML := IdHttp.Get(URL); 75 | 76 | Parse(HTML); 77 | finally 78 | IdHttp.Free; 79 | end; 80 | end; 81 | 82 | 83 | function TVersion.NewerThan(Version: TVersion): boolean; 84 | begin 85 | Result := CompareTo(Version) = TValueRelationship.Greater; 86 | end; 87 | 88 | class operator TVersion.NotEqual(A, B: TVersion): Boolean; 89 | begin 90 | Result := A.CompareTo(B) <> TValueRelationship.Equal; 91 | end; 92 | 93 | function TVersion.OlderThan(Version: TVersion): boolean; 94 | begin 95 | Result := CompareTo(Version) = TValueRelationship.Less; 96 | end; 97 | 98 | procedure TVersion.APILoad(AppName: string; Current: TVersion; Endpoint: string); 99 | var 100 | HTTP: TIdHTTP; 101 | SSLIOHandler: TIdSSLIOHandlerSocketOpenSSL; 102 | Request: TJSONObject; 103 | RequestStream: TStringStream; 104 | Result: string; 105 | begin 106 | // Create HTTP and SSLIOHandler components 107 | HTTP := TIdHTTP.Create(nil); 108 | SSLIOHandler := TIdSSLIOHandlerSocketOpenSSL.Create(HTTP); 109 | Request := TJSONObject.Create; 110 | 111 | // Build Request 112 | Request.AddPair('mode', 'getversion'); 113 | Request.AddPair('app', AppName); 114 | if not Current.Empty then 115 | Request.AddPair('client-version', Current.ToString(true)); 116 | 117 | // Request 118 | RequestStream := TStringStream.Create(Request.ToJSON, TEncoding.UTF8); 119 | try 120 | // Set SSL/TLS options 121 | SSLIOHandler.SSLOptions.SSLVersions := [sslvTLSv1_2]; 122 | HTTP.IOHandler := SSLIOHandler; 123 | 124 | // Set headers 125 | HTTP.Request.ContentType := 'application/json'; 126 | 127 | // Send POST 128 | Result := HTTP.Post(Endpoint, RequestStream); 129 | 130 | // Parse 131 | APIResponse := TJSONObject.ParseJSONValue( Result ) as TJSONObject; 132 | 133 | // Parse response 134 | if not APIResponse.GetValue('result') then 135 | raise Exception.Create( APIResponse.GetValue('message') ); 136 | Parse(APIResponse.GetValue('version')); 137 | finally 138 | // Free 139 | HTTP.Free; 140 | Request.Free; 141 | RequestStream.Free; 142 | end; 143 | end; 144 | 145 | procedure TVersion.APILoad(AppName, Endpoint: string); 146 | begin 147 | APILoad(AppName, VERSION_EMPTY, EndPoint); 148 | end; 149 | 150 | procedure TVersion.Clear; 151 | begin 152 | Major := 0; 153 | Minor := 0; 154 | Maintenance := 0; 155 | Build := 0; 156 | end; 157 | 158 | function TVersion.CompareTo(Version: TVersion): TValueRelationship; 159 | begin 160 | Result := GetNumberRelation(Major, Version.Major); 161 | if Result <> TValueRelationship.Equal then 162 | Exit; 163 | 164 | Result := GetNumberRelation(Minor, Version.Minor); 165 | if Result <> TValueRelationship.Equal then 166 | Exit; 167 | 168 | Result := GetNumberRelation(Maintenance, Version.Maintenance); 169 | if Result <> TValueRelationship.Equal then 170 | Exit; 171 | 172 | Result := GetNumberRelation(Build, Version.Build); 173 | end; 174 | 175 | constructor TVersion.Create(AString: string); 176 | begin 177 | Parse( AString ); 178 | end; 179 | 180 | constructor TVersion.Create(AMajor, AMinor, AMaintenance, ABuild: cardinal); 181 | begin 182 | Major := AMajor; 183 | Minor := AMinor; 184 | Maintenance := AMaintenance; 185 | Build := ABuild; 186 | end; 187 | 188 | function TVersion.Empty: boolean; 189 | begin 190 | Result := CompareTo(VERSION_EMPTY) = TValueRelationship.Equal; 191 | end; 192 | 193 | class operator TVersion.Equal(A, B: TVersion): Boolean; 194 | begin 195 | Result := A.CompareTo(B) = TValueRelationship.Equal; 196 | end; 197 | 198 | function TVersion.GetDownloadLink(JSONValue: string): string; 199 | begin 200 | if not APIResponse.TryGetValue(JSONValue, Result) then 201 | Result := ''; 202 | end; 203 | 204 | procedure TVersion.HtmlLoad(URL: string); 205 | var 206 | IdHttp: TIdHTTP; 207 | HTML: string; 208 | begin 209 | IdHttp := TIdHTTP.Create(nil); 210 | try 211 | IdHttp.Request.CacheControl := 'no-cache'; 212 | HTML := IdHttp.Get(URL); 213 | 214 | HTML := Trim(HTML).Replace(#13, '').DeQuotedString; 215 | 216 | Parse(HTML); 217 | finally 218 | IdHttp.Free; 219 | end; 220 | end; 221 | 222 | procedure TVersion.Parse(From: string); 223 | var 224 | Separator: char; 225 | Splitted: TArray; 226 | I: Integer; 227 | Value: cardinal; 228 | AVersions: integer; 229 | begin 230 | // Separator 231 | if From.IndexOf('.') <> -1 then 232 | Separator := '.' 233 | else 234 | if From.IndexOf(',') <> -1 then 235 | Separator := ',' 236 | else 237 | if From.IndexOf('-') <> -1 then 238 | Separator := '-' 239 | else 240 | Separator := #0; 241 | 242 | // Values 243 | Splitted := From.Split(Separator); 244 | 245 | AVersions := Length(Splitted); 246 | if AVersions < 0 then 247 | Exit; 248 | 249 | // Write 250 | Clear; 251 | 252 | for I := 0 to AVersions-1 do 253 | begin 254 | Value := Splitted[I].ToInteger; 255 | case I of 256 | 0: Major := Value; 257 | 1: Minor := Value; 258 | 2: Maintenance := Value; 259 | 3: Build := Value; 260 | else Break; 261 | end; 262 | end; 263 | end; 264 | 265 | function TVersion.ToString: string; 266 | begin 267 | Result := ToString(false); 268 | end; 269 | 270 | function TVersion.ToString(IncludeBuild: boolean): string; 271 | begin 272 | Result := ToString('.', IncludeBuild); 273 | end; 274 | 275 | function TVersion.ToString(Separator: char; IncludeBuild: boolean): string; 276 | begin 277 | Result := Major.ToString + Separator + Minor.ToString + Separator + Maintenance.ToString; 278 | 279 | if IncludeBuild then 280 | Result := Result + Separator + Build.ToString; 281 | end; 282 | 283 | end. -------------------------------------------------------------------------------- /Source/Cod.Visual.ColorBox.pas: -------------------------------------------------------------------------------- 1 | unit Cod.Visual.ColorBox; 2 | 3 | interface 4 | 5 | uses 6 | SysUtils, 7 | Classes, 8 | Winapi.Windows, 9 | Vcl.Controls, 10 | Vcl.Graphics, 11 | Vcl.ExtCtrls, 12 | Cod.Components, 13 | System.Math, 14 | Vcl.Styles, 15 | Vcl.Forms, 16 | System.Messaging, 17 | UITypes, 18 | Cod.Visual.CPSharedLib, 19 | Vcl.Themes, 20 | Vcl.Imaging.pngimage; 21 | 22 | type 23 | CColorBox = class; 24 | 25 | CColorBoxPresets = (clpNone, clpFluent, clpMetro, clpWin32); 26 | 27 | CColorBoxPreset = class(TMPersistent) 28 | private 29 | FpKind: CColorBoxPresets; 30 | FrColor: TColor; 31 | function Paint: Boolean; 32 | published 33 | property Color : TColor read FrColor write FrColor stored Paint; 34 | property Kind : CColorBoxPresets read FpKind write FpKind stored Paint; 35 | end; 36 | 37 | CColorBox = class(TCustomTransparentControl) 38 | constructor Create(AOwner : TComponent); override; 39 | destructor Destroy; override; 40 | private 41 | FColor, 42 | FBorderColor: TColor; 43 | FRound, 44 | FInnerRound, 45 | FThick: integer; 46 | FPreset: CColorBoxPreset; 47 | FTransparent: boolean; 48 | 49 | //FFormSync: boolean; 50 | 51 | FAnim: TTimer; 52 | FAnimTo, 53 | FAN: integer; 54 | 55 | procedure InitAnim(tovalue: integer); 56 | procedure AnimExecute(Sender: TObject); 57 | procedure SetColor(const Value: TColor); 58 | procedure SetRound(const Value: integer); 59 | procedure SetThick(const Value: integer); 60 | procedure SetPenColor(const Value: TColor); 61 | function ChangeColorSat(clr: TColor; perc: integer): TColor; 62 | procedure ApplyPreset(const Value: CColorBoxPresets); 63 | procedure SetInRound(const Value: integer); 64 | procedure SetTransparent(const Value: boolean); 65 | protected 66 | procedure Paint; override; 67 | procedure MouseDown(Button : TMouseButton; Shift: TShiftState; X, Y : integer); override; 68 | procedure MouseUp(Button : TMouseButton; Shift: TShiftState; X, Y : integer); override; 69 | procedure CMMouseEnter(var Message : TMessage); message CM_MOUSEENTER; 70 | procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE; 71 | procedure KeyPress(var Key: Char); override; 72 | published 73 | property OnMouseEnter; 74 | property OnMouseLeave; 75 | property OnMouseDown; 76 | property OnMouseUp; 77 | property OnMouseMove; 78 | property OnClick; 79 | 80 | property Align; 81 | property Anchors; 82 | property Cursor; 83 | property Visible; 84 | property Enabled; 85 | property Constraints; 86 | property DoubleBuffered; 87 | property TabStop; 88 | property TabOrder; 89 | 90 | property ParentColor; 91 | property Color; 92 | 93 | property Transparent: boolean read FTransparent write SetTransparent; 94 | //property FormColorSync: boolean read FFormSync write FFormSync; 95 | property Preset : CColorBoxPreset read FPreset Write FPreset; 96 | property ItemColor : TColor read FColor write SetColor; 97 | property PenRound : integer read FRound write SetRound; 98 | property PenInnerRound : integer read FInnerRound write SetInRound; 99 | property PenThick : integer read FThick write SetThick; 100 | property PenColor : TColor read FBorderColor write SetPenColor; 101 | public 102 | procedure Invalidate; override; 103 | end; 104 | 105 | implementation 106 | 107 | { CColorBright } 108 | 109 | procedure CColorBox.ApplyPreset(const Value: CColorBoxPresets); 110 | begin 111 | FPreset.Kind := Value; 112 | 113 | if FPreset.Kind = clpNone then Exit; 114 | 115 | FBorderColor := FPreset.FrColor; 116 | 117 | case FPreset.Kind of 118 | clpFluent: begin 119 | FRound := 10; 120 | FInnerRound := 10; 121 | FThick := 5; 122 | Height := 40; 123 | Width := 40; 124 | end; 125 | clpWin32: begin 126 | FRound := 0; 127 | FInnerRound := 2; 128 | FThick := 3; 129 | Height := 30; 130 | Width := 30; 131 | end; 132 | clpMetro: begin 133 | FRound := 0; 134 | FInnerRound := 0; 135 | FThick := 5; 136 | Height := 40; 137 | Width := 40; 138 | end; 139 | end; 140 | end; 141 | 142 | function CColorBox.ChangeColorSat(clr: TColor; perc: integer): TColor; 143 | var 144 | RBGval: longint; 145 | R, G, B: integer; 146 | begin 147 | RBGval := ColorToRGB(clr); 148 | R := GetRValue(RBGval); 149 | G := GetGValue(RBGval); 150 | B := GetBValue(RBGval); 151 | 152 | R := R + perc; 153 | G := G + perc; 154 | B := B + perc; 155 | 156 | if R < 0 then R := 0; 157 | if G < 0 then G := 0; 158 | if B < 0 then B := 0; 159 | 160 | if R > 255 then R := 255; 161 | if G > 255 then G := 255; 162 | if B > 255 then B := 255; 163 | 164 | Result := RGB(r,g,b); 165 | end; 166 | 167 | procedure CColorBox.MouseDown(Button: TMouseButton; Shift: TShiftState; X, 168 | Y: integer); 169 | begin 170 | inherited; 171 | InitAnim(-30); 172 | end; 173 | 174 | procedure CColorBox.MouseUp(Button: TMouseButton; Shift: TShiftState; X, 175 | Y: integer); 176 | begin 177 | inherited; 178 | InitAnim(20); 179 | end; 180 | 181 | 182 | procedure CColorBox.AnimExecute(Sender: TObject); 183 | begin 184 | if FAN < FAnimTo then inc(FAN, 2); 185 | if FAN > FAnimTo then dec(FAN, 2); 186 | 187 | if FAN = FAnimTo then FAnim.Enabled := false; 188 | 189 | Paint; 190 | end; 191 | 192 | procedure CColorBox.CMMouseEnter(var Message: TMessage); 193 | begin 194 | InitAnim(20); 195 | end; 196 | 197 | procedure CColorBox.CMMouseLeave(var Message: TMessage); 198 | begin 199 | InitAnim(0); 200 | end; 201 | 202 | constructor CColorBox.Create(AOwner: TComponent); 203 | begin 204 | inherited; 205 | interceptmouse:=True; 206 | 207 | FPreset := CColorBoxPreset.Create(Self); 208 | with FPreset do begin 209 | FpKind := clpNone; 210 | FrColor := $00313131; 211 | end; 212 | 213 | TabStop := true; 214 | 215 | FAnim := TTimer.Create(Self); 216 | with FAnim do begin 217 | Interval := 1; 218 | Enabled := false; 219 | OnTimer := AnimExecute; 220 | end; 221 | 222 | FAN := 0; 223 | 224 | FTransparent := true; 225 | 226 | FColor := clAqua; 227 | FThick := 5; 228 | FRound := 10; 229 | FInnerRound := 10; 230 | FBorderColor := $00313131; 231 | 232 | Width := 40; 233 | Height := 40; 234 | end; 235 | 236 | destructor CColorBox.Destroy; 237 | begin 238 | FreeANdNil(FPreset); 239 | FAnim.Enabled := false; 240 | FreeAndNil(FAnim); 241 | inherited; 242 | end; 243 | 244 | 245 | procedure CColorBox.InitAnim(tovalue: integer); 246 | begin 247 | FAnimTo := tovalue; 248 | 249 | FAnim.Interval := 1; 250 | 251 | FAnim.Enabled := true; 252 | end; 253 | 254 | procedure CColorBox.Invalidate; 255 | begin 256 | inherited; 257 | 258 | Paint; 259 | end; 260 | 261 | procedure CColorBox.KeyPress(var Key: Char); 262 | begin 263 | inherited; 264 | if key = #13 then begin 265 | FAN := -30; 266 | Sleep(50); 267 | if Assigned(OnClick) then OnClick(Self); 268 | FAN := 0; 269 | Click; 270 | end; 271 | end; 272 | 273 | procedure CColorBox.Paint; 274 | begin 275 | inherited; 276 | 277 | ApplyPreset(FPreset.Kind); 278 | 279 | Canvas.Brush.Color := TStyleManager.ActiveStyle.GetSystemColor(Self.Color); 280 | 281 | if NOT FTransparent then 282 | Canvas.FillRect(canvas.cliprect); 283 | 284 | with inherited canvas do begin 285 | {Pen.Color := FBorderColor; 286 | Pen.Width := FThick; 287 | if FThick = 0 then 288 | Pen.Style := psClear 289 | else 290 | Pen.Style := psSolid; } 291 | 292 | Pen.Style := psClear; 293 | 294 | Brush.Color := ChangeColorSat(FBorderColor, FAN); 295 | 296 | RoundRect(0, 0, Width, Height, FRound, FRound); 297 | 298 | Brush.Color := FColor; 299 | 300 | RoundRect(FThick, FThick, Width - FThick, Height - FThick, FInnerRound, FInnerRound); 301 | end; 302 | end; 303 | 304 | procedure CColorBox.SetColor(const Value: TColor); 305 | begin 306 | FColor := Value; 307 | Paint; 308 | end; 309 | 310 | procedure CColorBox.SetInRound(const Value: integer); 311 | begin 312 | FInnerRound := Value; 313 | Paint; 314 | end; 315 | 316 | procedure CColorBox.SetPenColor(const Value: TColor); 317 | begin 318 | FBorderColor := Value; 319 | Paint; 320 | end; 321 | 322 | procedure CColorBox.SetRound(const Value: integer); 323 | begin 324 | FRound := Value; 325 | Paint; 326 | end; 327 | 328 | procedure CColorBox.SetThick(const Value: integer); 329 | begin 330 | FThick := Value; 331 | Paint; 332 | end; 333 | 334 | procedure CColorBox.SetTransparent(const Value: boolean); 335 | begin 336 | FTransparent := Value; 337 | 338 | Invalidate; 339 | end; 340 | 341 | { CColorBoxPreset } 342 | 343 | function CColorBoxPreset.Paint: Boolean; 344 | begin 345 | if Self.Owner is CColorBox then begin 346 | CColorBox(Self.Owner).Paint; 347 | Result := True; 348 | end else Result := False; 349 | end; 350 | 351 | end. 352 | -------------------------------------------------------------------------------- /Source/Cod.Visual.StarRate.pas: -------------------------------------------------------------------------------- 1 | unit Cod.Visual.StarRate; 2 | 3 | interface 4 | 5 | uses 6 | SysUtils, 7 | Classes, 8 | Vcl.Controls, 9 | Cod.Components, 10 | Messaging, 11 | Types, 12 | Vcl.Styles, 13 | Vcl.Themes, 14 | Cod.Graphics, 15 | Vcl.Graphics; 16 | 17 | type 18 | CStarRate = class; 19 | 20 | 21 | CStarRateStar = class(TMPersistent) 22 | private 23 | FColor, FBorderColor, FInaColor, FInaBorderColor: TColor; 24 | FBorder: boolean; 25 | FBorderThickness: integer; 26 | 27 | function Paint: boolean; 28 | 29 | published 30 | property Color : TColor read FColor write FColor stored Paint; 31 | property BorderColor : TColor read FBorderColor write FBorderColor stored Paint; 32 | property InactiveColor : TColor read FInaColor write FInaColor stored Paint; 33 | property InactiveBorderColor : TColor read FInaBorderColor write FInaBorderColor stored Paint; 34 | 35 | property Border : boolean read FBorder write FBorder stored Paint; 36 | property BorderThickness : integer read FBorderThickness write FBorderThickness stored Paint; 37 | end; 38 | 39 | CStarRate = class(TCustomControl) 40 | private 41 | FAuthor, FSite, FVersion: string; 42 | 43 | FStarsDrawn: integer; 44 | FRating: integer; 45 | FMinRating: integer; 46 | FMaxRating: integer; 47 | FSpacing: integer; 48 | FViewOnly: boolean; 49 | FStar: CStarRateStar; 50 | FOnChange: TNotifyEvent; 51 | FOnSelect: TNotifyEvent; 52 | 53 | mouseisdown: boolean; 54 | 55 | procedure SetMaxRating(const Value: integer); 56 | procedure SetRating(const Value: integer); 57 | procedure SetStars(const Value: integer); 58 | procedure SetSpacing(const Value: integer); 59 | 60 | procedure DrawStars(useinactiveset: boolean; var BitMap: TBitMap); 61 | 62 | procedure SetMinRating(const Value: integer); 63 | 64 | protected 65 | procedure Paint; override; 66 | 67 | procedure MouseDown(Button : TMouseButton; State: TShiftState; X, Y: integer); override; 68 | procedure MouseMove(State: TShiftState; X, Y: integer); override; 69 | procedure MouseUp(Button : TMouseButton; State: TShiftState; X, Y: integer); override; 70 | 71 | public 72 | constructor Create(AOwner : TComponent); override; 73 | destructor Destroy; override; 74 | 75 | published 76 | property OnMouseEnter; 77 | property OnMouseLeave; 78 | property OnMouseDown; 79 | property OnMouseUp; 80 | property OnMouseMove; 81 | property OnClick; 82 | 83 | property Color; 84 | property ParentColor; 85 | 86 | property ShowHint; 87 | property Align; 88 | property Anchors; 89 | property Cursor; 90 | property Visible; 91 | property Enabled; 92 | property Constraints; 93 | property DoubleBuffered; 94 | 95 | property ViewOnly : boolean read FViewOnly write FViewOnly; 96 | property Spacing : integer read FSpacing write SetSpacing; 97 | property StarDesign : CStarRateStar read FStar write FStar; 98 | property StarsDrawn : integer read FStarsDrawn write SetStars; 99 | property Rating : integer read FRating write SetRating; 100 | property MaximumRating : integer read FMaxRating write SetMaxRating; 101 | property MinimumRating : integer read FMinRating write SetMinRating; 102 | property OnChange: TNotifyEvent read FOnChange write FOnChange; 103 | property OnSelect: TNotifyEvent read FOnSelect write FOnSelect; 104 | 105 | property &&&Author: string Read FAuthor; 106 | property &&&Site: string Read FSite; 107 | property &&&Version: string Read FVersion; 108 | public 109 | procedure Invalidate; override; 110 | 111 | end; 112 | 113 | implementation 114 | 115 | { CProgress } 116 | 117 | constructor CStarRate.Create(AOwner: TComponent); 118 | begin 119 | inherited; 120 | FAuthor := 'Petculescu Codrut'; 121 | FSite := 'https://www.codrutsoftware.cf'; 122 | FVersion := '1.1'; 123 | 124 | FStar := CStarRateStar.Create(Self); 125 | with FStar do begin 126 | FColor := clYellow; 127 | FBorderColor := $0044ADFB; 128 | 129 | FInaColor := clGray; 130 | FInaBorderColor := clWindowFrame; 131 | 132 | FBorder := true; 133 | FBorderThickness := 10; 134 | end; 135 | 136 | FViewOnly := false; 137 | 138 | FStarsDrawn := 5; 139 | FRating := 0; 140 | FMaxRating := 10; 141 | FMinRating := 0; 142 | FSpacing := 5; 143 | 144 | Width := 200; 145 | Height := 40; 146 | end; 147 | 148 | destructor CStarRate.Destroy; 149 | begin 150 | FreeAndNil(FStar); 151 | 152 | inherited; 153 | end; 154 | 155 | procedure CStarRate.Invalidate; 156 | begin 157 | inherited; 158 | Paint; 159 | end; 160 | 161 | 162 | procedure CStarRate.MouseDown(Button: TMouseButton; State: TShiftState; X, 163 | Y: integer); 164 | begin 165 | inherited; 166 | 167 | mouseisdown := true; 168 | MouseMove([], X, Y); 169 | end; 170 | 171 | procedure CStarRate.MouseMove(State: TShiftState; X, Y: integer); 172 | var 173 | PreviousRating, Rate: integer; 174 | Changed: boolean; 175 | begin 176 | inherited; 177 | 178 | if (not FViewOnly) and mouseisdown then 179 | begin 180 | PreviousRating := Rating; 181 | 182 | Rate := round(X / Width * FMaxRating); 183 | Changed := Rate <> Rating; 184 | Rating := Rate; 185 | 186 | if Changed and Assigned(OnSelect) then 187 | OnSelect(Self); 188 | 189 | if Rating <> PreviousRating then 190 | Paint; 191 | end; 192 | end; 193 | 194 | procedure CStarRate.MouseUp(Button: TMouseButton; State: TShiftState; X, 195 | Y: integer); 196 | begin 197 | inherited; 198 | 199 | mouseisdown := false; 200 | end; 201 | 202 | procedure CStarRate.DrawStars(useinactiveset: boolean; var BitMap: TBitMap); 203 | var 204 | I, size, bsize, itemw: integer; 205 | color, bcolor: TColor; 206 | Points: TArray; 207 | begin 208 | // Create bitmap 209 | BitMap := TBitMap.Create; 210 | 211 | BitMap.Height := Height; 212 | BitMap.Width := Width; 213 | 214 | if FStar.FBorder then 215 | bsize := FStar.FBorderThickness 216 | else 217 | bsize := 0; 218 | 219 | if not useinactiveset then 220 | begin 221 | color := FStar.FColor; 222 | bcolor := FStar.FBorderColor; 223 | end 224 | else 225 | begin 226 | color := FStar.FInaColor; 227 | bcolor := FStar.FInaBorderColor; 228 | end; 229 | 230 | // Clear Canvas 231 | with BitMap.Canvas do 232 | begin 233 | Brush.Color := TStyleManager.ActiveStyle.GetSystemColor(Self.color); 234 | 235 | FillRect(cliprect); 236 | end; 237 | 238 | // Calculate Locations 239 | SetLength(Points, FStarsDrawn); 240 | 241 | itemw := round(Width / FStarsDrawn); 242 | 243 | size := itemw div 2 - FSpacing; 244 | 245 | for I := 0 to FStarsDrawn - 1 do 246 | begin 247 | Points[I].X := I * itemw + itemw div 2; 248 | Points[I].Y := Height div 2 - round(size * (2/3)); 249 | end; 250 | 251 | // Draw Stars 252 | for I := 0 to FStarsDrawn - 1 do 253 | MakeStar(BitMap.Canvas, Points[I].X, Points[I].Y, size, color, bsize, bcolor); 254 | end; 255 | 256 | procedure CStarRate.Paint; 257 | var 258 | workon, overlay: TBitMap; 259 | ActiveRect: TRect; 260 | begin 261 | inherited; 262 | 263 | if not Visible then Exit; 264 | 265 | DrawStars(true, workon); 266 | DrawStars(false, overlay); 267 | 268 | // Draw 269 | with canvas do begin 270 | CopyRect(cliprect, workon.Canvas, cliprect); 271 | 272 | ActiveRect := cliprect; 273 | ActiveRect.Width := trunc(FRating / FMaxRating * ActiveRect.Width); 274 | 275 | CopyRect(ActiveRect, overlay.Canvas, ActiveRect); 276 | end; 277 | 278 | // Free 279 | workon.Free; 280 | overlay.Free; 281 | end; 282 | 283 | procedure CStarRate.SetMaxRating(const Value: integer); 284 | begin 285 | FMaxRating := Value; 286 | 287 | if FRating > FMaxRating then 288 | FRating := FMaxRating; 289 | 290 | Paint; 291 | end; 292 | 293 | procedure CStarRate.SetMinRating(const Value: integer); 294 | begin 295 | FMinRating := Value; 296 | 297 | if FRating < FMinRating then 298 | FRating := FMinRating; 299 | end; 300 | 301 | procedure CStarRate.SetRating(const Value: integer); 302 | begin 303 | if (Value <= FMaxRating) 304 | and (Value >= FMinRating) 305 | and (Value <> FRating) then 306 | begin 307 | FRating := Value; 308 | if Assigned(OnChange) then 309 | OnChange(Self); 310 | end; 311 | 312 | Paint; 313 | end; 314 | 315 | procedure CStarRate.SetSpacing(const Value: integer); 316 | begin 317 | FSpacing := Value; 318 | 319 | Paint; 320 | end; 321 | 322 | procedure CStarRate.SetStars(const Value: integer); 323 | begin 324 | if Value > 0 then 325 | FStarsDrawn := Value; 326 | 327 | Paint; 328 | end; 329 | 330 | { CStarRateStar } 331 | 332 | function CStarRateStar.Paint: boolean; 333 | begin 334 | if Self.Owner is CStarRate then begin 335 | CStarRate(Self.Owner).Paint; 336 | Result := True; 337 | end else Result := False; 338 | end; 339 | 340 | end. 341 | 342 | -------------------------------------------------------------------------------- /Dependencies/Cod.ByteUtils.pas: -------------------------------------------------------------------------------- 1 | {***********************************************************} 2 | { Codruts ByteUtils Utilities } 3 | { } 4 | { version 0.2 } 5 | { ALPHA } 6 | { } 7 | { } 8 | { } 9 | { } 10 | { } 11 | { -- WORK IN PROGRESS -- } 12 | {***********************************************************} 13 | 14 | unit Cod.ByteUtils; 15 | 16 | interface 17 | uses 18 | Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, IOUTils, 19 | Cod.Types, Cod.StringUtils, Cod.MesssageConst; 20 | 21 | function GetFileBytes(FileName: string): TArray; 22 | function GetFileBytesString(FileName: string; FirstCount: integer = -1): TArray; 23 | 24 | function ReadFileSignature(FileName: string): TFileType; 25 | 26 | function GetFileTypeDefaultExt(FileType: TFileType): string; (* Do not localise *) 27 | function GetFileTypeDescription(FileType: TFileType): string; 28 | 29 | implementation 30 | 31 | function GetFileBytes(FileName: string): TArray; 32 | begin 33 | // Get File 34 | Result := TFile.ReadAllBytes(FileName); 35 | end; 36 | 37 | function GetFileBytesString(FileName: string; FirstCount: integer): TArray; 38 | var 39 | Bytes: TBytes; 40 | I, Total: Integer; 41 | begin 42 | // Get File 43 | Bytes := TFile.ReadAllBytes(FileName); 44 | Total := Length( Bytes ); 45 | 46 | // Total Items 47 | if (FirstCount = -1) or (FirstCount > Total) then 48 | FirstCount := Total; 49 | 50 | // Size 51 | SetLength( Result, FirstCount ); 52 | 53 | // Convert 54 | for I := 0 to FirstCount - 1 do 55 | Result[I] := DecToHex( Bytes[I] ); 56 | end; 57 | 58 | function GetFileTypeDefaultExt(FileType: TFileType): string; 59 | begin 60 | case FileType of 61 | TFileType.Text: Result := 'txt'; 62 | 63 | TFileType.BMP: Result := 'bmp'; 64 | TFileType.PNG: Result := 'png'; 65 | TFileType.JPEG: Result := 'jpeg'; 66 | TFileType.GIF: Result := 'gif'; 67 | TFileType.HEIC: Result := 'heif'; 68 | TFileType.TIFF: Result := 'tiff'; 69 | 70 | TFileType.MP3: Result := 'mp3'; 71 | TFileType.MP4: Result := 'mp4'; 72 | TFileType.MKV: Result := 'mkv'; 73 | TFileType.FLAC: Result := 'flac'; 74 | TFileType.MDI: Result := 'mdi'; 75 | TFileType.OGG: Result := 'ogg'; 76 | TFileType.SND: Result := 'snd'; 77 | 78 | TFileType.M3U8: Result := 'm3u8'; 79 | 80 | TFileType.EXE: Result := 'exe'; 81 | TFileType.MSI: Result := 'msi'; 82 | 83 | TFileType.Zip: Result := 'zip'; 84 | TFileType.GZip: Result := 'gzip'; 85 | TFileType.Zip7: Result := '7z'; 86 | TFileType.Cabinet: Result := 'cab'; 87 | TFileType.TAR: Result := 'tar'; 88 | TFileType.RAR: Result := 'rar'; 89 | TFileType.LZIP: Result := 'lzip'; 90 | TFileType.ISO: Result := 'iso'; 91 | 92 | TFileType.PDF: Result := 'pdf'; 93 | 94 | TFileType.HLP: Result := 'hlp'; 95 | TFileType.CHM: Result := 'chm'; 96 | 97 | else Result := STRING_UNKNOWN; 98 | end; 99 | 100 | end; 101 | 102 | function GetFileTypeDescription(FileType: TFileType): string; 103 | begin 104 | case FileType of 105 | TFileType.Text: Result := 'Text document'; 106 | 107 | TFileType.BMP: Result := 'Bitmap'; 108 | TFileType.PNG: Result := 'Portable Network Graphic'; 109 | TFileType.JPEG: Result := 'Joint Photography Experts Group'; 110 | TFileType.GIF: Result := 'Graphics Interchange Format'; 111 | TFileType.HEIC: Result := 'High Efficency Image Codec'; 112 | TFileType.TIFF: Result := 'Tagged Image File Format'; 113 | 114 | TFileType.MP3: Result := 'MPEG Layer-3'; 115 | TFileType.MP4: Result := 'MPEG Layer-4'; 116 | TFileType.MKV: Result := 'Matroska Video Container'; 117 | TFileType.FLAC: Result := 'Free Lossless Audio Codec'; 118 | TFileType.MDI: Result := 'MDI'; 119 | TFileType.OGG: Result := 'OGG Vorbis'; 120 | TFileType.SND: Result := 'Sound'; 121 | 122 | TFileType.M3U8: Result := 'Text Playlist file'; 123 | 124 | TFileType.EXE: Result := 'Executable'; 125 | TFileType.MSI: Result := 'Microsoft Installer'; 126 | 127 | TFileType.Zip: Result := 'Zipped Archive'; 128 | TFileType.GZip: Result := 'GZipped Archive'; 129 | TFileType.Zip7: Result := '7Zip Archive'; 130 | TFileType.Cabinet: Result := 'Windows Cabinet Archive'; 131 | TFileType.TAR: Result := 'Tarred Archive'; 132 | TFileType.RAR: Result := 'RAR Archive'; 133 | TFileType.LZIP: Result := 'LZIP Archive'; 134 | TFileType.ISO: Result := 'Disk Image'; 135 | 136 | TFileType.PDF: Result := 'Portable Document Format'; 137 | 138 | TFileType.HLP: Result := 'Windows Help File'; 139 | TFileType.CHM: Result := 'Windows Help File'; 140 | 141 | else Result := STRING_UNKNOWN; 142 | end; 143 | end; 144 | 145 | function ReadFileSignature(FileName: string): TFileType; 146 | const 147 | MAX_READ_BUFF = 16; 148 | 149 | FTYP = '66 74 79 70'; 150 | 151 | BMP_SIGN: TArray = ['42 4D']; 152 | PNG_SIGN: TArray = ['89 50 4E 47 0D 0A 1A 0A']; 153 | GIF_SIGN: TArray = ['47 49 46']; 154 | JPEG_SIGN: TArray = ['FF D8 FF', '49 46 00 01']; 155 | HEIF_SIGN: TArray = [FTYP + '68 65 69 63']; 156 | TIFF_SIGN: TArray = ['49 49 2A 00', '4D 4D 00 2A']; 157 | 158 | MP3_SIGN: TArray = ['49 44 33', 'FF FB', 'FF F3', 'FF F2']; 159 | MP4_SIGN: TArray> = [ 160 | [FTYP + '69 73 6F 6D'], // ftypisom (ISO Base Media file (MPEG-4)) 161 | [FTYP + '4D 53 4E 56'], // ftypMSNV MPEG-4 video file 162 | [FTYP + '6D 70 34 32'] // ftypmp42 163 | ]; 164 | MKV_SIGN: TArray = ['1A 45 DF A3']; 165 | FLAC_SIGN: TArray = ['66 4C 61 43']; 166 | MDI_SIGN: TArray = ['4D 54 68 64']; 167 | OGG_SIGN: TArray = ['4F 67 67 53']; 168 | SND_SIGN: TArray = ['2E 73 6E 64']; 169 | M3U8_SIGN: TArray = ['23 45 58 54 4D 33 55']; 170 | 171 | EXE_SIGN: TArray = ['4D 5A']; 172 | MSI_SIGN: TArray = ['D0 CF 11 E0 A1 B1 1A E1']; 173 | 174 | ZIP_SIGN: TArray = ['50 4B 03 04', '50 4B 05 06', '50 4B 07 08']; 175 | GZIP_SIGN: TArray = ['1F 8B']; 176 | ZIP7_SIGN: TArray = ['37 7A BC AF 27 1C']; 177 | CABINET_SIGN: TArray = ['4D 53 43 46']; 178 | TAR_SIGN: TArray = ['75 73 74 61 72 00 30 30', '75 73 74 61 72 20 20 00']; 179 | RAR_SIGN: TArray = ['52 61 72 21 1A 07 00', '52 61 72 21 1A 07 01 00']; 180 | LZIP_SIGN: TArray = ['4C 5A 49 50']; 181 | 182 | ISO_SIGN: TArray = ['43 44 30 30 31', '49 73 5A 21']; 183 | 184 | PDF_SIGN: TArray = ['25 50 44 46 2D']; 185 | 186 | HLP_SIGN: TArray = ['3F 5F']; 187 | 188 | CHM_SIGN: TArray = ['49 54 53 46 03 00 00 00']; 189 | var 190 | HexArray: TArray; 191 | HEX: string; 192 | I: Integer; 193 | 194 | function HasSignature(HEX: string; ValidSign: TArray): boolean; 195 | var 196 | I: integer; 197 | begin 198 | Result := false; 199 | for I := 0 to High(ValidSign) do 200 | begin 201 | ValidSign[I] := ValidSign[I].Replace(' ', ''); 202 | 203 | if StrFirst( HEX, Length(ValidSign[I]) ) = ValidSign[I] then 204 | Exit(True); 205 | end; 206 | end; 207 | begin 208 | Result := TFileType.Text; 209 | 210 | // Get File 211 | HexArray := GetFileBytesString( FileName, MAX_READ_BUFF ); 212 | 213 | HEX := ''; 214 | for I := 0 to High(HexArray) do 215 | HEX := HEX + HexArray[I]; 216 | 217 | SetLength(HexArray, 0); 218 | 219 | // Invalid 220 | if HEX = '' then 221 | Exit; 222 | 223 | // All Types Listed (not great) 224 | 225 | (* Picture Types *) 226 | if HasSignature(HEX, BMP_SIGN) then 227 | Exit( TFileType.BMP ); 228 | 229 | if HasSignature(HEX, PNG_SIGN) then 230 | Exit( TFileType.PNG ); 231 | 232 | if HasSignature(HEX, JPEG_SIGN) then 233 | Exit( TFileType.JPEG ); 234 | 235 | if HasSignature(HEX, GIF_SIGN) then 236 | Exit( TFileType.GIF ); 237 | 238 | if HasSignature(StrRemove(HEX, 1, 8), HEIF_SIGN) then 239 | Exit( TFileType.HEIC ); 240 | 241 | if HasSignature(HEX, TIFF_SIGN) then 242 | Exit( TFileType.TIFF ); 243 | 244 | (* Video/Audio Media *) 245 | if HasSignature(HEX, MP3_SIGN) then 246 | Exit( TFileType.MP3 ); 247 | 248 | for I := 0 to High(MP4_SIGN) do 249 | if HasSignature(StrRemove(HEX, 1, 8), MP4_SIGN[I]) then 250 | Exit( TFileType.MP4 ); 251 | 252 | if HasSignature(HEX, MKV_SIGN) then 253 | Exit( TFileType.MKV ); 254 | 255 | if HasSignature(HEX, FLAC_SIGN) then 256 | Exit( TFileType.Flac ); 257 | 258 | if HasSignature(HEX, MDI_SIGN) then 259 | Exit( TFileType.MDI ); 260 | 261 | if HasSignature(HEX, OGG_SIGN) then 262 | Exit( TFileType.OGG ); 263 | 264 | if HasSignature(HEX, SND_SIGN) then 265 | Exit( TFileType.SND ); 266 | 267 | if HasSignature(HEX, M3U8_SIGN) then 268 | Exit( TFileType.M3U8 ); 269 | 270 | (* Executable *) 271 | if HasSignature(HEX, EXE_SIGN) then 272 | Exit( TFileType.EXE ); 273 | 274 | if HasSignature(HEX, MSI_SIGN) then 275 | Exit( TFileType.MSI ); 276 | 277 | (* Zip *) 278 | if HasSignature(HEX, ZIP_SIGN) then 279 | Exit( TFileType.Zip ); 280 | 281 | if HasSignature(HEX, GZIP_SIGN) then 282 | Exit( TFileType.GZip ); 283 | 284 | if HasSignature(HEX, ZIP7_SIGN) then 285 | Exit( TFileType.Zip7 ); 286 | 287 | if HasSignature(HEX, CABINET_SIGN) then 288 | Exit( TFileType.Cabinet ); 289 | 290 | if HasSignature(HEX, TAR_SIGN) then 291 | Exit( TFileType.TAR ); 292 | 293 | if HasSignature(HEX, RAR_SIGN) then 294 | Exit( TFileType.RAR ); 295 | 296 | if HasSignature(HEX, LZIP_SIGN) then 297 | Exit( TFileType.LZIP ); 298 | 299 | (* ISO *) 300 | if HasSignature(HEX, ISO_SIGN) then 301 | Exit( TFileType.ISO ); 302 | 303 | (* PDF *) 304 | if HasSignature(HEX, PDF_SIGN) then 305 | Exit( TFileType.PDF ); 306 | 307 | (* Help File *) 308 | if HasSignature(HEX, HLP_SIGN) then 309 | Exit( TFileType.HLP ); 310 | 311 | if HasSignature(HEX, CHM_SIGN) then 312 | Exit( TFileType.CHM ); 313 | end; 314 | 315 | end. -------------------------------------------------------------------------------- /Demo/Demo_u.pas: -------------------------------------------------------------------------------- 1 | unit Demo_u; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, 7 | Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls, 8 | Vcl.Imaging.GIFImg, Vcl.Imaging.pngimage, Cod.Dialogs, 9 | Cod.Visual.GlassBlur, Cod.Visual.Panels, Cod.Visual.Image, Cod.Visual.Slider, 10 | Cod.Visual.SplashScreen, Cod.Visual.StarRate, Cod.Visual.CheckBox, 11 | Cod.Visual.ColorWheel, Cod.Visual.ColorBright, Cod.Visual.ColorBox, 12 | Cod.Visual.Progress, Cod.Visual.StandardIcons, Cod.Visual.Chart, 13 | Cod.Visual.Button, Cod.Dialogs.ColorDialog; 14 | 15 | type 16 | TForm1 = class(TForm) 17 | Label1: TLabel; 18 | Timer1: TTimer; 19 | nxpg: CButton; 20 | pvpg: CButton; 21 | Label7: TLabel; 22 | pg2: TPanel; 23 | Label8: TLabel; 24 | CColorBox1: CColorBox; 25 | CColorBright1: CColorBright; 26 | CColorWheel1: CColorWheel; 27 | CCheckBox1: CCheckBox; 28 | CCheckBox2: CCheckBox; 29 | CCheckBox3: CCheckBox; 30 | CCheckBox4: CCheckBox; 31 | CCheckBox5: CCheckBox; 32 | CCheckBox6: CCheckBox; 33 | Label6: TLabel; 34 | CStarRate1: CStarRate; 35 | Label9: TLabel; 36 | CStarRate2: CStarRate; 37 | CStarRate3: CStarRate; 38 | Label10: TLabel; 39 | CSplashScreen1: CSplashScreen; 40 | CSlider1: CSlider; 41 | CSlider2: CSlider; 42 | CSlider3: CSlider; 43 | CSlider4: CSlider; 44 | pg1: TPanel; 45 | Label2: TLabel; 46 | Label3: TLabel; 47 | Label4: TLabel; 48 | Label5: TLabel; 49 | CButton1: CButton; 50 | CButton2: CButton; 51 | CButton3: CButton; 52 | CButton4: CButton; 53 | CButton5: CButton; 54 | CButton6: CButton; 55 | CButton7: CButton; 56 | CChart1: CChart; 57 | CChart2: CChart; 58 | CChart3: CChart; 59 | CChart4: CChart; 60 | CChart5: CChart; 61 | CStandardIcon1: CStandardIcon; 62 | CStandardIcon2: CStandardIcon; 63 | CStandardIcon3: CStandardIcon; 64 | CStandardIcon4: CStandardIcon; 65 | CStandardIcon5: CStandardIcon; 66 | CStandardIcon6: CStandardIcon; 67 | CButton8: CButton; 68 | CButton9: CButton; 69 | CButton10: CButton; 70 | CButton11: CButton; 71 | CButton13: CButton; 72 | CButton14: CButton; 73 | CButton15: CButton; 74 | CProgress1: CProgress; 75 | CProgress2: CProgress; 76 | CProgress3: CProgress; 77 | CProgress4: CProgress; 78 | pg3: TPanel; 79 | Label11: TLabel; 80 | CPanel1: CPanel; 81 | CPanel2: CPanel; 82 | CPanel3: CPanel; 83 | CPanel4: CPanel; 84 | Label12: TLabel; 85 | CMinimisePanel1: CMinimisePanel; 86 | CMinimisePanel2: CMinimisePanel; 87 | CMinimisePanel3: CMinimisePanel; 88 | CButton12: CButton; 89 | CButton16: CButton; 90 | CButton17: CButton; 91 | Label13: TLabel; 92 | pg4: TPanel; 93 | Label14: TLabel; 94 | CButton18: CButton; 95 | Edit1: TEdit; 96 | Edit2: TEdit; 97 | ComboBox1: TComboBox; 98 | CColorBox2: CColorBox; 99 | CheckBox1: TCheckBox; 100 | CColorBox3: CColorBox; 101 | CColorDialog1: CColorDialog; 102 | ComboBox2: TComboBox; 103 | CheckBox2: TCheckBox; 104 | CheckBox3: TCheckBox; 105 | CheckBox4: TCheckBox; 106 | CheckBox5: TCheckBox; 107 | aaaa: TLabel; 108 | CheckBox6: TCheckBox; 109 | CheckBox7: TCheckBox; 110 | Label15: TLabel; 111 | CButton19: CButton; 112 | CButton20: CButton; 113 | CheckBox9: TCheckBox; 114 | CheckBox10: TCheckBox; 115 | CheckBox11: TCheckBox; 116 | CColorDialog2: CColorDialog; 117 | Label16: TLabel; 118 | CButton21: CButton; 119 | Memo1: TMemo; 120 | CButton22: CButton; 121 | CButton23: CButton; 122 | pg5: TPanel; 123 | CGlassBlur: TLabel; 124 | CGlassBlur1: CGlassBlur; 125 | CGlassBlur2: CGlassBlur; 126 | CGlassBlur3: CGlassBlur; 127 | Label17: TLabel; 128 | Label18: TLabel; 129 | Label19: TLabel; 130 | Label26: TLabel; 131 | CImage11: CImage; 132 | CImage6: CImage; 133 | Label25: TLabel; 134 | Label24: TLabel; 135 | CImage10: CImage; 136 | Label23: TLabel; 137 | CImage9: CImage; 138 | Label22: TLabel; 139 | CImage8: CImage; 140 | Label21: TLabel; 141 | CImage7: CImage; 142 | procedure CProgress1MouseDown(Sender: TObject; Button: TMouseButton; 143 | Shift: TShiftState; X, Y: Integer); 144 | procedure CProgress1MouseLeave(Sender: TObject); 145 | procedure CProgress1MouseMove(Sender: TObject; Shift: TShiftState; X, 146 | Y: Integer); 147 | procedure CProgress1MouseUp(Sender: TObject; Button: TMouseButton; 148 | Shift: TShiftState; X, Y: Integer); 149 | procedure Timer1Timer(Sender: TObject); 150 | procedure CColorBright1ChangeItemColor(Sender: CColorBright; Color: TColor; 151 | X, Y: Integer); 152 | procedure nxpgClick(Sender: TObject); 153 | procedure pvpgClick(Sender: TObject); 154 | procedure FormCreate(Sender: TObject); 155 | procedure CButton18Click(Sender: TObject); 156 | procedure GetClr(Sender: TObject); 157 | procedure CButton19Click(Sender: TObject); 158 | procedure CButton20Click(Sender: TObject); 159 | procedure CButton21Click(Sender: TObject); 160 | procedure CButton22Click(Sender: TObject); 161 | procedure CButton23Click(Sender: TObject); 162 | private 163 | { Private declarations } 164 | procedure GoToPage(pg: integer); 165 | 166 | procedure FormMove(var Msg: TMsg); message WM_MOVE; 167 | public 168 | { Public declarations } 169 | end; 170 | 171 | const 172 | pages = 5; 173 | 174 | var 175 | Form1: TForm1; 176 | progmsdown: boolean; 177 | page: integer = 1; 178 | 179 | implementation 180 | 181 | {$R *.dfm} 182 | 183 | procedure TForm1.nxpgClick(Sender: TObject); 184 | begin 185 | GoToPage(page + 1); 186 | end; 187 | 188 | procedure TForm1.pvpgClick(Sender: TObject); 189 | begin 190 | GoToPage(page - 1); 191 | end; 192 | 193 | procedure TForm1.CButton18Click(Sender: TObject); 194 | var 195 | a: TMsgDlgButtons; 196 | BTCOLOR: integer; 197 | begin 198 | a := []; 199 | if CheckBOx2.Checked then 200 | a := a + [TMsgDlgBtn.mbOK]; 201 | if CheckBOx3.Checked then 202 | a := a + [TMsgDlgBtn.mbYes]; 203 | if CheckBOx4.Checked then 204 | a := a + [TMsgDlgBtn.mbNo]; 205 | if CheckBOx5.Checked then 206 | a := a + [TMsgDlgBtn.mbCancel]; 207 | 208 | if CheckBox7.Checked then 209 | BTCOLOR := -1 210 | else 211 | BTCOLOR := CColorBox3.ItemColor; 212 | 213 | CodDialog(Edit1.Text, Edit2.Text, CMessageType(ComboBox1.ItemIndex), 214 | a,CButtonPreset(ComboBox2.ItemIndex), CColorBox2.ItemColor, 215 | CheckBOx1.Checked, BTCOLOR, CheckBox6.Checked ); 216 | end; 217 | 218 | procedure TForm1.GetClr(Sender: TObject); 219 | begin 220 | CColorBox(Sender).ItemColor := CColorDialog1.GetColor(CColorBox(Sender).ItemColor); 221 | end; 222 | 223 | procedure TForm1.CButton19Click(Sender: TObject); 224 | var 225 | BTCOLOR: integer; 226 | begin 227 | if CheckBox7.Checked then 228 | BTCOLOR := -1 229 | else 230 | BTCOLOR := CColorBox3.ItemColor; 231 | 232 | CodMessage(Edit1.Text, Edit2.Text, CButtonPreset(ComboBox2.ItemIndex), CColorBox2.ItemColor, 233 | CheckBOx1.Checked, BTCOLOR, CheckBox6.Checked ); 234 | end; 235 | 236 | procedure TForm1.CButton20Click(Sender: TObject); 237 | var 238 | passchar: char; 239 | BTCOLOR: integer; 240 | begin 241 | passchar := #0; 242 | 243 | if CheckBox11.Checked then 244 | passchar := '*'; 245 | 246 | if CheckBox7.Checked then 247 | BTCOLOR := -1 248 | else 249 | BTCOLOR := CColorBox3.ItemColor; 250 | 251 | CodInput(Edit1.Text, Edit2.Text, 'pre data', CheckBox10.Checked, 252 | CheckBox9.Checked, passchar, CButtonPreset(ComboBox2.ItemIndex), 253 | CColorBox2.ItemColor, CheckBOx1.Checked, BTCOLOR, 254 | CheckBox6.Checked ); 255 | end; 256 | 257 | procedure TForm1.CButton21Click(Sender: TObject); 258 | begin 259 | CButton(Sender).Colors.Leave := CColorDialog1.GetColor(CButton(Sender).Colors.Leave); 260 | end; 261 | 262 | procedure TForm1.CButton22Click(Sender: TObject); 263 | var 264 | BTCOLOR: integer; 265 | begin 266 | if CheckBox7.Checked then 267 | BTCOLOR := -1 268 | else 269 | BTCOLOR := CColorBox3.ItemColor; 270 | 271 | CodDropDown(Edit1.Text, Edit2.Text, TStringList(Memo1.Lines), CheckBox10.Checked, 272 | CButtonPreset(ComboBox2.ItemIndex), CColorBox2.ItemColor, 273 | CheckBOx1.Checked, BTCOLOR, CheckBox6.Checked ); 274 | end; 275 | 276 | procedure TForm1.CButton23Click(Sender: TObject); 277 | var 278 | BTCOLOR: integer; 279 | begin 280 | if CheckBox7.Checked then 281 | BTCOLOR := -1 282 | else 283 | BTCOLOR := CColorBox3.ItemColor; 284 | 285 | CodRadioDialog(Edit1.Text, Edit2.Text, TStringList(Memo1.Lines), CheckBox10.Checked, 286 | CButtonPreset(ComboBox2.ItemIndex), CColorBox2.ItemColor, 287 | CheckBOx1.Checked, BTCOLOR, CheckBox6.Checked ); 288 | end; 289 | 290 | procedure TForm1.CColorBright1ChangeItemColor(Sender: CColorBright; 291 | Color: TColor; X, Y: Integer); 292 | begin 293 | try 294 | CColorBox1.ItemColor := CColorBright1.Color; 295 | except 296 | 297 | end; 298 | end; 299 | 300 | procedure TForm1.CProgress1MouseDown(Sender: TObject; Button: TMouseButton; 301 | Shift: TShiftState; X, Y: Integer); 302 | begin 303 | progmsdown := true; 304 | if progmsdown then 305 | CProgress1.Position := trunc(x/CProgress1.Width * 100) 306 | end; 307 | 308 | procedure TForm1.CProgress1MouseLeave(Sender: TObject); 309 | begin 310 | progmsdown := false; 311 | end; 312 | 313 | procedure TForm1.CProgress1MouseMove(Sender: TObject; Shift: TShiftState; X, 314 | Y: Integer); 315 | begin 316 | if progmsdown then 317 | CProgress1.Position := trunc(x/CProgress1.Width * 100) 318 | end; 319 | 320 | procedure TForm1.CProgress1MouseUp(Sender: TObject; Button: TMouseButton; 321 | Shift: TShiftState; X, Y: Integer); 322 | begin 323 | progmsdown := false; 324 | end; 325 | 326 | procedure TForm1.FormCreate(Sender: TObject); 327 | begin 328 | GoToPage(1); 329 | end; 330 | 331 | procedure TForm1.FormMove(var Msg: TMsg); 332 | begin 333 | // Manual Glass Blur Redraw 334 | if Self.Visible and pg5.Visible then 335 | begin 336 | CGlassBlur1.SyncroniseImage; 337 | CGlassBlur2.SyncroniseImage; 338 | CGlassBlur3.SyncroniseImage; 339 | end; 340 | end; 341 | 342 | procedure TForm1.GoToPage(pg: integer); 343 | var 344 | pan: TPanel; 345 | begin 346 | if pg > pages then pg := pages; 347 | 348 | page := pg; 349 | 350 | case pg of 351 | 1: pan := pg1; 352 | 2: pan := pg2; 353 | 3: pan := pg3; 354 | 4: pan := pg4; 355 | 5: pan := pg5; 356 | else Exit; 357 | end; 358 | 359 | pan.BringToFront; 360 | pan.Invalidate; 361 | 362 | if pg = 1 then pvpg.Enabled := false else pvpg.Enabled := true; 363 | if pg = pages then nxpg.Enabled := false else nxpg.Enabled := true; 364 | 365 | Label7.Caption := 'Page ' + pg.ToString + ' of ' + pages.ToString; 366 | end; 367 | 368 | procedure TForm1.Timer1Timer(Sender: TObject); 369 | begin 370 | CChart1.Position := Random(101); 371 | end; 372 | 373 | end. 374 | -------------------------------------------------------------------------------- /Source/Cod.Visual.ColorBright.pas: -------------------------------------------------------------------------------- 1 | unit Cod.Visual.ColorBright; 2 | 3 | interface 4 | 5 | uses 6 | SysUtils, 7 | Classes, 8 | Windows, 9 | Controls, 10 | Graphics, 11 | ExtCtrls, 12 | Math, 13 | Styles, 14 | Forms, 15 | Cod.Components, 16 | Cod.Visual.CPSharedLib, 17 | Themes, 18 | Types, 19 | Imaging.pngimage; 20 | 21 | type 22 | CColorBright = class; 23 | 24 | CColorBrightChangeColor = procedure(Sender: CColorBright; Color: TColor; X, Y: integer) of object; 25 | 26 | CColorBright = class(TCustomTransparentControl) 27 | constructor Create(AOwner : TComponent); override; 28 | destructor Destroy; override; 29 | private 30 | gradient: TBitMap; 31 | ColorBG: TColor; 32 | ColorCoord: TPoint; 33 | FColor, FMainColor: TColor; 34 | MouseIsDown: boolean; 35 | FTransparent: Boolean; 36 | FChangeColor: CColorBrightChangeColor; 37 | FSyncBgColor: boolean; 38 | 39 | procedure RedrawGradient; 40 | procedure ChangeColor(color: TColor; x, y: integer); 41 | procedure SetBGColor(const Value: TColor); 42 | procedure SetFormSync(const Value: boolean); 43 | procedure SetColor(const Value: TColor); 44 | procedure SetTransparent(const Value: boolean); 45 | procedure SetMainColor(const Value: TColor); 46 | protected 47 | procedure Paint; override; 48 | procedure MouseDown(Button : TMouseButton; Shift: TShiftState; X, Y : integer); override; 49 | procedure MouseUp(Button : TMouseButton; Shift: TShiftState; X, Y : integer); override; 50 | procedure MouseMove(Shift: TShiftState; X, Y : integer); override; 51 | procedure GradHorizontal(Canvas:TCanvas; Rect:TRect; FromColor, ToColor:TColor) ; 52 | procedure KeyPress(var Key: Char); override; 53 | procedure DoEnter; override; 54 | procedure DoExit; override; 55 | published 56 | property OnMouseEnter; 57 | property OnMouseLeave; 58 | property OnMouseDown; 59 | property OnMouseUp; 60 | property OnMouseMove; 61 | property OnClick; 62 | 63 | property TabStop; 64 | property TabOrder; 65 | 66 | property Align; 67 | property Anchors; 68 | property Cursor; 69 | property Visible; 70 | property Enabled; 71 | property Constraints; 72 | property DoubleBuffered; 73 | property ChangeItemColor: CColorBrightChangeColor read FChangeColor write FChangeColor; 74 | property FormSyncedColor : boolean read FSyncBgColor write SetFormSync; 75 | 76 | property Transparent: boolean read FTransparent write SetTransparent; 77 | property Color: TColor read FColor write SetColor; 78 | property PureColor: TColor read FMainColor write SetMainColor; 79 | property BackGroundColor: TColor read ColorBG write SetBGColor; 80 | public 81 | procedure SetFocus(); override; 82 | procedure ChangeX(x: integer); 83 | end; 84 | 85 | implementation 86 | 87 | function CalculateLight(col: TColor): integer; 88 | var 89 | l1, l2, l3: real; 90 | begin 91 | l1 := getRvalue(col); 92 | l2 := getGvalue(col); 93 | l3 := getBvalue(col); 94 | 95 | Result := trunc((l1 + l2 + l3)/3); 96 | end; 97 | 98 | 99 | { CColorBright } 100 | 101 | procedure CColorBright.GradHorizontal(Canvas:TCanvas; Rect:TRect; FromColor, ToColor:TColor); 102 | var 103 | X: integer; 104 | dr, dg, db:Extended; 105 | r1, r2, g1, g2, b1, b2:Byte; 106 | R, G, B:Byte; 107 | cnt, csize:integer; 108 | begin 109 | //Unpack Colors 110 | tocolor := ColorToRGB(tocolor); 111 | fromcolor := ColorToRGB(fromcolor); 112 | 113 | R1 := GetRValue(FromColor) ; 114 | G1 := GetGValue(FromColor) ; 115 | B1 := GetBValue(FromColor) ; 116 | 117 | R2 := GetRValue(ToColor) ; 118 | G2 := GetGValue(ToColor) ; 119 | B2 := GetBValue(ToColor) ; 120 | 121 | //Calculate Width 122 | csize := Rect.Right-Rect.Left; 123 | if csize <= 0 then Exit; 124 | 125 | //Get Color mdi 126 | dr := (R2-R1) / csize; 127 | dg := (G2-G1) / csize; 128 | db := (B2-B1) / csize; 129 | 130 | if dr < 0 then dr := dr * -1; 131 | if dg < 0 then dr := dg * -1; 132 | if db < 0 then dr := db * -1; 133 | 134 | //Start Draw 135 | cnt := 0; 136 | for X := Rect.Left to Rect.Right-1 do 137 | begin 138 | R := R1+Ceil(dr*cnt) ; 139 | G := G1+Ceil(dg*cnt) ; 140 | B := B1+Ceil(db*cnt) ; 141 | 142 | Canvas.Pen.Color := RGB(R,G,B) ; 143 | Canvas.MoveTo(X,Rect.Top) ; 144 | Canvas.LineTo(X,Rect.Bottom) ; 145 | inc(cnt) ; 146 | end; 147 | end; 148 | 149 | procedure CColorBright.KeyPress(var Key: Char); 150 | var 151 | x: integer; 152 | nr, v: integer; 153 | begin 154 | inherited; 155 | if (key = #37) or (key = '-') or (key = 'a') then begin 156 | x := colorcoord.X - 1; 157 | if (x > 0) and (x < width)then 158 | MouseDown(mbLeft,[], x, colorcoord.Y); 159 | MouseUp(mbLeft,[],x,colorcoord.Y); 160 | end; 161 | if (key = #39) or (key = '=') or (key = '+') or (key = 'd') then begin 162 | x := colorcoord.X + 1; 163 | if (x > 0) and (x < width)then 164 | MouseDown(mbLeft,[], x, colorcoord.Y); 165 | MouseUp(mbLeft,[],x,colorcoord.Y); 166 | end; 167 | 168 | val(char(key), nr, v); 169 | 170 | if key = 'm' then begin nr := 10; v := 0; end; 171 | 172 | 173 | if (nr >= 0) and (nr <= 10) and (v = 0) then begin 174 | x := trunc((nr * 10) / 100 * (width - 1)); 175 | if x = 0 then x := 1; 176 | if (x > 0) and (x <= width)then 177 | MouseDown(mbLeft,[], x, colorcoord.Y); 178 | MouseUp(mbLeft,[],x,colorcoord.Y); 179 | end; 180 | end; 181 | 182 | procedure CColorBright.MouseDown(Button: TMouseButton; Shift: TShiftState; X, 183 | Y: integer); 184 | begin 185 | inherited; 186 | MouseIsDown := true; 187 | MouseMove(Shift, X, Y); 188 | end; 189 | 190 | procedure CColorBright.MouseMove(Shift: TShiftState; X, Y: integer); 191 | begin 192 | inherited; 193 | if (gradient.Height <> self.Height) or (gradient.Width <> self.Width) then RedrawGradient; 194 | 195 | 196 | if MouseIsDown or (Shift = [ssShift]) then begin 197 | if Power((x - width div 2), 2) + Power((y - height div 2), 2) < Power(width div 2, 2) then begin 198 | ColorCoord.X := X; 199 | ColorCoord.Y := Y; 200 | 201 | ChangeColor(gradient.Canvas.Pixels[trunc(x), height div 3], x, y); 202 | end; 203 | Paint; 204 | end; 205 | end; 206 | 207 | procedure CColorBright.MouseUp(Button: TMouseButton; Shift: TShiftState; X, 208 | Y: integer); 209 | begin 210 | inherited; 211 | MouseIsDown := false; 212 | try 213 | Self.SetFocus; 214 | except 215 | end; 216 | end; 217 | 218 | procedure CColorBright.ChangeColor(color: TColor; x, y: integer); 219 | begin 220 | FColor := color; 221 | if Assigned(FChangeColor) then FChangeColor(Self, color, x, y); 222 | end; 223 | 224 | procedure CColorBright.ChangeX(x: integer); 225 | begin 226 | MouseMove([ssShift],x, 0); 227 | end; 228 | 229 | constructor CColorBright.Create(AOwner: TComponent); 230 | begin 231 | inherited; 232 | interceptmouse:=True; 233 | 234 | ColorBG := clWhite; 235 | 236 | FMainColor := clBlue; 237 | 238 | TabStop := true; 239 | 240 | if gradient = nil then RedrawGradient; 241 | 242 | colorcoord := Point(50, 50); 243 | 244 | FTransparent := false; 245 | FSyncBgColor := true; 246 | 247 | Width := 150; 248 | Height := 20; 249 | 250 | RedrawGradient; 251 | end; 252 | 253 | destructor CColorBright.Destroy; 254 | begin 255 | FreeAndNil(gradient); 256 | inherited; 257 | end; 258 | 259 | 260 | procedure CColorBright.DoEnter; 261 | begin 262 | inherited; 263 | 264 | end; 265 | 266 | procedure CColorBright.DoExit; 267 | begin 268 | inherited; 269 | Paint; 270 | end; 271 | 272 | procedure CColorBright.Paint; 273 | var 274 | pts: array[1..3] of TPoint; 275 | sz: integer; 276 | begin 277 | inherited; 278 | 279 | if (FTransparent) and (NOT gradient.Transparent) then 280 | begin 281 | gradient.Transparent := true; 282 | gradient.TransparentColor := colorbg; 283 | gradient.TransparentMode := tmAuto; 284 | end else if gradient.Transparent then gradient.Transparent := false; 285 | 286 | 287 | with canvas do begin 288 | StretchDraw(Rect(0, 0, width, height), gradient); 289 | 290 | 291 | Pen.Color := clWhite; 292 | if self.focused then 293 | Brush.Color := clWhite 294 | else 295 | Brush.Color := clBlack; 296 | 297 | sz := round(self.Height / 3.5); 298 | 299 | pts[1].Y := Height; 300 | pts[2].Y := Height; 301 | pts[1].X := ColorCoord.X - sz div 2; 302 | pts[2].X := pts[1].X + sz; 303 | 304 | pts[3].Y := pts[1].Y - sz; 305 | pts[3].X := ColorCoord.X; 306 | 307 | canvas.Polygon(pts); 308 | 309 | {Pen.Color := clBlack; 310 | Pen.Width := 1; 311 | Brush.Style := bsClear; 312 | Rectangle(ColorCoord.X - 2, ColorCoord.Y - 2, ColorCoord.X + 2, ColorCoord.Y + 2); } 313 | end; 314 | end; 315 | 316 | procedure CColorBright.RedrawGradient; 317 | var 318 | bgc: TColor; 319 | R1, R2: TRect; 320 | i: integer; 321 | begin 322 | if gradient = nil then 323 | gradient := TBitMap.Create; 324 | 325 | gradient.Width := Width; 326 | gradient.Height := Height; 327 | 328 | R1 := Rect(0, 0, round(width / 2), height); 329 | R2 := Rect(round(width / 2), 0, width, height); 330 | 331 | gradient.Canvas.Brush.Style := bsSolid; 332 | 333 | GradHorizontal(gradient.Canvas, R1, clBlack, FMainColor); 334 | GradHorizontal(gradient.Canvas, R2, FMainColor, clWhite); 335 | 336 | bgc := colorbg; 337 | 338 | if FSyncBgColor then 339 | begin 340 | if StrInArray(TStyleManager.ActiveStyle.Name, nothemes) then begin 341 | if GetParentForm(Self) <> nil then 342 | bgc := GetParentForm(Self).Color; 343 | end else begin 344 | bgc := TStyleManager.ActiveStyle.GetSystemColor(clBtnFace); 345 | end; 346 | end; 347 | 348 | gradient.Canvas.Pen.Color := bgc; 349 | gradient.Canvas.Brush.Style := bsClear; 350 | 351 | for I := 1 to self.Height div 4 do 352 | gradient.Canvas.RoundRect(0,0, width + 1, height, i, i); 353 | 354 | //gradient.Canvas.TextOut(0,0,TStyleManager.ActiveStyle.Name); 355 | end; 356 | 357 | procedure CColorBright.SetBGColor(const Value: TColor); 358 | begin 359 | ColorBG := Value; 360 | RedrawGradient; 361 | Paint; 362 | end; 363 | 364 | procedure CColorBright.SetColor(const Value: TColor); 365 | var 366 | I: Integer; 367 | begin 368 | FColor := Value; 369 | 370 | for I := 0 to width do 371 | if CalculateLight(Gradient.Canvas.Pixels[trunc(I / width * 500), trunc(height / 10)]) = CalculateLight(FColor) then 372 | begin 373 | ColorCoord.X := I; 374 | Break 375 | end; 376 | 377 | Paint; 378 | end; 379 | 380 | procedure CColorBright.SetFocus; 381 | begin 382 | inherited; 383 | Paint; 384 | end; 385 | 386 | procedure CColorBright.SetFormSync(const Value: boolean); 387 | begin 388 | FSyncBgColor := Value; 389 | RedrawGradient; 390 | Paint; 391 | end; 392 | 393 | procedure CColorBright.SetMainColor(const Value: TColor); 394 | begin 395 | FMainColor := Value; 396 | 397 | ColorCoord.X := width div 2; 398 | 399 | RedrawGradient; 400 | 401 | FColor := FMainColor; 402 | 403 | ChangeColor(gradient.Canvas.Pixels[width div 2, height div 3], ColorCoord.X, ColorCoord.Y); 404 | 405 | Paint; 406 | end; 407 | 408 | procedure CColorBright.SetTransparent(const Value: boolean); 409 | begin 410 | FTransparent := Value; 411 | end; 412 | 413 | end. 414 | -------------------------------------------------------------------------------- /Source/Cod.Visual.StandardIcons.pas: -------------------------------------------------------------------------------- 1 | unit Cod.Visual.StandardIcons; 2 | 3 | interface 4 | 5 | uses 6 | SysUtils, 7 | Classes, 8 | Vcl.Controls, 9 | Vcl.Graphics, 10 | Cod.Components, 11 | Messaging, 12 | Types, 13 | Vcl.Styles, 14 | Cod.VarHelpers, 15 | Vcl.Themes, 16 | Winapi.Windows; 17 | 18 | type 19 | CStandardIcon = class; 20 | CodIconType = (ciconCheckmark, ciconError, ciconStop, ciconQuestion, ciconInformation, ciconWarning, ciconStar, ciconNone); 21 | 22 | TPent = array[0..4] of TPoint; 23 | 24 | CStandardIcon = class(TCustomTransparentControl) 25 | constructor Create(AOwner : TComponent); override; 26 | destructor Destroy; override; 27 | private 28 | FAuthor, FSite, FVersion: string; 29 | FIcon : CodIconType; 30 | FProport: boolean; 31 | FWidth: integer; 32 | procedure SetIcon(const Value: CodIconType); 33 | procedure SetProport(const Value: boolean); 34 | procedure SetWid(const Value: integer); 35 | 36 | class procedure DrawPentacle(Canvas : TCanvas; Pent : TPent); 37 | class function MakePent(X, Y, L : integer) : TPent; 38 | class procedure MakeStar(Canvas : TCanvas; cX, cY, size : integer; Colour :TColor; bordersize: integer; bordercolor: TColor); 39 | protected 40 | procedure Paint; override; 41 | published 42 | property OnMouseEnter; 43 | property OnMouseLeave; 44 | property OnMouseDown; 45 | property OnMouseUp; 46 | property OnMouseMove; 47 | property OnClick; 48 | 49 | property Color; 50 | property ParentColor; 51 | property ParentBackground; 52 | 53 | property ShowHint; 54 | property Align; 55 | property Anchors; 56 | property Cursor; 57 | property Visible; 58 | property Enabled; 59 | property Constraints; 60 | property DoubleBuffered; 61 | 62 | property Proportional : boolean read FProport write SetProport; 63 | property SelectedIcon : CodIconType read FIcon write SetIcon; 64 | property PenWidth : integer read FWidth write SetWid; 65 | 66 | property &&&Author: string Read FAuthor; 67 | property &&&Site: string Read FSite; 68 | property &&&Version: string Read FVersion; 69 | public 70 | procedure Invalidate; override; 71 | end; 72 | 73 | implementation 74 | 75 | { CProgress } 76 | 77 | constructor CStandardIcon.Create(AOwner: TComponent); 78 | begin 79 | inherited; 80 | FAuthor := 'Petculescu Codrut'; 81 | FSite := 'https://www.codrutsoftware.cf'; 82 | FVersion := '1.1'; 83 | 84 | interceptmouse:=True; 85 | 86 | FProport := true; 87 | FIcon := ciconCheckMark; 88 | FWidth := 10; 89 | 90 | Width := 60; 91 | Height := 60; 92 | end; 93 | 94 | destructor CStandardIcon.Destroy; 95 | begin 96 | 97 | inherited; 98 | end; 99 | 100 | procedure CStandardIcon.Invalidate; 101 | begin 102 | inherited; 103 | Paint; 104 | end; 105 | 106 | class procedure CStandardIcon.MakeStar(Canvas : TCanvas; cX, cY, size : integer; Colour :TColor; bordersize: integer; bordercolor: TColor); 107 | var 108 | Pent : TPent; 109 | begin 110 | Pent := MakePent(cX, cY, size); 111 | BeginPath(Canvas.Handle); 112 | DrawPentacle(Canvas, Pent); 113 | EndPath(Canvas.Handle); 114 | SetPolyFillMode(Canvas.Handle, WINDING); 115 | if bordersize <> 0 then 116 | Canvas.Brush.Color := bordercolor 117 | else 118 | Canvas.Brush.Color := Colour; 119 | FillPath(Canvas.Handle); 120 | 121 | if bordersize <> 0 then begin 122 | Pent := MakePent(cX, cY + trunc(bordersize / 1.2), size - bordersize); 123 | BeginPath(Canvas.Handle); 124 | DrawPentacle(Canvas, Pent); 125 | EndPath(Canvas.Handle); 126 | SetPolyFillMode(Canvas.Handle, WINDING); 127 | Canvas.Brush.Color := Colour; 128 | FillPath(Canvas.Handle); 129 | end; 130 | end; 131 | 132 | class function CStandardIcon.MakePent(X, Y, L : integer) : TPent; 133 | var 134 | DX1, DY1, DX2, DY2 : integer; 135 | const 136 | Sin54 = 0.809; 137 | Cos54 = 0.588; 138 | Tan72 = 3.078; 139 | begin 140 | DX1 := trunc(L * Sin54); 141 | DY1 := trunc(L * Cos54); 142 | DX2 := L div 2; 143 | DY2 := trunc(L * Tan72 / 2); 144 | Result[0] := point(X, Y); 145 | Result[1] := point(X - DX1, Y + DY1); 146 | Result[2] := point(X - DX2, Y + DY2); 147 | Result[3] := point(X + DX2, Y + DY2); 148 | Result[4] := point(X + DX1, Y + DY1); 149 | end; 150 | 151 | class procedure CStandardIcon.DrawPentacle(Canvas : TCanvas; Pent : TPent); 152 | begin 153 | with Canvas do begin 154 | MoveTo(Pent[0].X, Pent[0].Y); 155 | LineTo(Pent[2].X, Pent[2].Y); 156 | LineTo(Pent[4].X, Pent[4].Y); 157 | LineTo(Pent[1].X, Pent[1].Y); 158 | LineTo(Pent[3].X, Pent[3].Y); 159 | LineTo(Pent[0].X, Pent[0].Y); 160 | end; 161 | end; 162 | 163 | procedure CStandardIcon.Paint; 164 | var 165 | s, Quater: integer; 166 | Text: string; 167 | R: TRect; 168 | begin 169 | inherited; 170 | if FProport then begin 171 | if width < height then 172 | height := width 173 | else 174 | width := height; 175 | end; 176 | 177 | if not Visible then Exit; 178 | 179 | // Draw 180 | with canvas do begin 181 | // Transparent 182 | if NOT ParentBackground then 183 | begin 184 | Brush.Color := TStyleManager.ActiveStyle.GetSystemColor(Self.Color); 185 | FillRect(cliprect); 186 | end; 187 | 188 | // Icon Selector 189 | case FIcon of 190 | CodIconType.ciconCheckmark: begin 191 | pen.Color := 1505536; 192 | brush.Color := 59648; 193 | pen.Width := (FWidth * width) div 100; 194 | Ellipse(Pen.Width div 2, Pen.Width div 2, width - Pen.Width div 2, height - Pen.Width div 2); 195 | 196 | pen.Width := 10; 197 | pen.Color := clWhite; 198 | 199 | pen.Width := (FWidth * width) div 100; 200 | 201 | moveto( trunc(clientwidth / 4.9), trunc(clientheight / 1.9) ); 202 | lineto( trunc(clientwidth / 2.5), trunc(clientheight / 1.4) ); 203 | lineto( trunc(clientwidth / 1.35), trunc(clientheight / 3.6) ); 204 | end; 205 | CodIconType.ciconError: begin 206 | pen.Color := 196741; 207 | brush.Color := 2363135; 208 | pen.Width := (FWidth * width) div 100; 209 | Ellipse(Pen.Width div 2, Pen.Width div 2, width - Pen.Width div 2, height - Pen.Width div 2); 210 | 211 | pen.Width := 10; 212 | pen.Color := clWhite; 213 | 214 | pen.Width := (FWidth * width) div 100; 215 | 216 | moveto( trunc(clientwidth / 3), trunc(clientheight / 3) ); 217 | lineto( clientwidth - trunc(clientwidth / 3), clientheight - trunc(clientheight / 3) ); 218 | 219 | moveto( clientwidth - trunc(clientwidth / 3), trunc(clientheight / 3) ); 220 | lineto( trunc(clientwidth / 3), clientheight - trunc(clientheight / 3) ); 221 | end; 222 | CodIconType.ciconInformation: begin 223 | pen.Color := 16716032; 224 | brush.Color := 16727571; 225 | pen.Width := (FWidth * width) div 100; 226 | Ellipse(Pen.Width div 2, Pen.Width div 2, width - Pen.Width div 2, height - Pen.Width div 2); 227 | 228 | pen.Width := 10; 229 | pen.Color := clWhite; 230 | 231 | font.Style := [fsBold]; 232 | font.Name := 'Segoe UI'; 233 | font.Color := clWhite; 234 | if clientwidth < clientheight then 235 | s := clientwidth 236 | else 237 | s := clientheight; 238 | Font.Size := trunc(s / 1.8); 239 | 240 | Brush.Style := bsClear; 241 | TextOut( (Width div 2) - ( TextWidth('i') div 2 ) , (Height div 2) - ( TextHeight('i') div 2 ) , 'i'); 242 | end; 243 | CodIconType.ciconQuestion: begin 244 | pen.Color := 16716032; 245 | brush.Color := 16727571; 246 | pen.Width := (FWidth * width) div 100; 247 | Ellipse(Pen.Width div 2, Pen.Width div 2, width - Pen.Width div 2, height - Pen.Width div 2); 248 | 249 | pen.Width := 10; 250 | pen.Color := clWhite; 251 | 252 | font.Style := [fsBold]; 253 | font.Name := 'Segoe UI'; 254 | font.Color := clWhite; 255 | if clientwidth < clientheight then 256 | s := clientwidth 257 | else 258 | s := clientheight; 259 | Font.Size := trunc(s / 1.8); 260 | 261 | Brush.Style := bsClear; 262 | TextOut( (Width div 2) - ( TextWidth('?') div 2 ) , (Height div 2) - ( TextHeight('?') div 2 ) , '?'); 263 | end; 264 | CodIconType.ciconWarning: begin 265 | pen.Color := clBlack; 266 | brush.Color := 63231; 267 | pen.Width := (FWidth * width) div 100; 268 | Self.Canvas.Polygon( [ 269 | Point(clientwidth div 2,Pen.Width div 2), 270 | Point(Pen.Width div 2, clientheight - Pen.Width div 2), 271 | Point(clientwidth - Pen.Width div 2, clientheight - Pen.Width div 2) 272 | ]); 273 | 274 | pen.Width := 10; 275 | pen.Color := clWhite; 276 | 277 | font.Style := [fsBold]; 278 | font.Name := 'Segoe UI'; 279 | font.Color := clBlack; 280 | if clientwidth < clientheight then 281 | s := clientwidth 282 | else 283 | s := clientheight; 284 | Font.Size := trunc(s / 2.4); 285 | 286 | Brush.Style := bsClear; 287 | TextOut( (Width div 2) - ( TextWidth('!') div 2 ) , trunc(Height / 1.7) - ( TextHeight('!') div 2 ) , '!'); 288 | end; 289 | CodIconType.ciconStop: begin 290 | pen.Color := 196741; 291 | brush.Color := 2363135; 292 | pen.Width := (FWidth * width) div 100; 293 | 294 | Quater := Width div 4; 295 | 296 | Self.Canvas.Polygon( [ 297 | Point(Quater, pen.Width div 2), 298 | Point(Quater * 3, pen.Width div 2), 299 | Point(Width - pen.Width div 2, Quater), 300 | Point(Width - pen.Width div 2, Quater * 3), 301 | Point(Quater * 3, Height - pen.Width div 2), 302 | Point(Quater, Height - pen.Width div 2), 303 | Point(pen.Width div 2, Quater * 3), 304 | Point(pen.Width div 2, Quater) 305 | ]); 306 | 307 | pen.Width := 10; 308 | pen.Color := clWhite; 309 | 310 | font.Style := [fsBold]; 311 | font.Name := 'Impact'; 312 | font.Color := clWhite; 313 | if clientwidth < clientheight then 314 | s := clientwidth 315 | else 316 | s := clientheight; 317 | Font.Size := trunc(s / 3.6); 318 | Font.Style := [fsBold]; 319 | 320 | Brush.Style := bsClear; 321 | 322 | Text := 'STOP'; 323 | R := Rect(0, Height div 2 - TextHeight(Text) div 2, Width, Height);; 324 | 325 | 326 | Canvas.TextRect(R, Text, [tfCenter]); 327 | end; 328 | CodIconType.ciconStar: begin 329 | MakeStar(Canvas, width div 2, height div 15, trunc(width / 1.75), clYellow, height div 20, $0001BAF8); 330 | end; 331 | end; 332 | end; 333 | end; 334 | 335 | procedure CStandardIcon.SetIcon(const Value: CodIconType); 336 | var 337 | nediv: boolean; 338 | begin 339 | nediv := false; 340 | 341 | if (value = ciconWarning) and (FIcon <> ciconWarning) then nediv := true; 342 | if (value <> ciconWarning) and (FIcon = ciconWarning) then nediv := true; 343 | 344 | if (value = ciconStar) and (FIcon <> ciconStar) then nediv := true; 345 | if (value <> ciconStar) and (FIcon = ciconStar) then nediv := true; 346 | 347 | if (value = ciconNone) and (FIcon <> ciconNone) then nediv := true; 348 | if (value <> ciconNone) and (FIcon = ciconNone) then nediv := true; 349 | 350 | 351 | FIcon := Value; 352 | 353 | Paint; 354 | if nediv then 355 | Repaint 356 | end; 357 | 358 | procedure CStandardIcon.SetProport(const Value: boolean); 359 | begin 360 | FProport := Value; 361 | Paint; 362 | end; 363 | 364 | procedure CStandardIcon.SetWid(const Value: integer); 365 | begin 366 | FWidth := Value; 367 | Paint; 368 | end; 369 | 370 | end. 371 | 372 | -------------------------------------------------------------------------------- /Dependencies/Cod.VarHelpers.pas: -------------------------------------------------------------------------------- 1 | {***********************************************************} 2 | { Codruts Variabile Helpers } 3 | { } 4 | { version 0.2 } 5 | { ALPHA } 6 | { } 7 | { } 8 | { } 9 | { } 10 | { } 11 | { -- WORK IN PROGRESS -- } 12 | {***********************************************************} 13 | 14 | {$SCOPEDENUMS ON} 15 | 16 | unit Cod.VarHelpers; 17 | 18 | interface 19 | uses 20 | System.SysUtils, System.Classes, IdHTTP, 21 | {$IFDEF MSWINDOWS} 22 | Windows, 23 | {$ENDIF} 24 | VCL.Graphics, Winapi.ActiveX, Winapi.URLMon, IOUtils, System.Generics.Collections, 25 | Cod.ColorUtils, System.Generics.Defaults, Vcl.Imaging.pngimage, 26 | WinApi.GdipObj, WinApi.GdipApi, Win.Registry, Cod.GDI, Cod.Types, 27 | DateUtils, Cod.Registry, UITypes, Vcl.Menus, Types, Vcl.Forms, Vcl.Controls; 28 | 29 | type 30 | // Color Helper 31 | TColorHelper = record helper for TColor 32 | public 33 | function ToString: string; overload; inline; 34 | function ToInteger: integer; overload; inline; 35 | function ToRGB: CRGB; overload; inline; 36 | end; 37 | 38 | // TRect Helper 39 | TRectHelper = record helper for TRect 40 | public 41 | function GetBottomLeft: TPoint; inline; 42 | function GetTopRight: TPoint; inline; 43 | function Normalised: boolean; inline; 44 | end; 45 | 46 | // TPoint Helper 47 | TPointHelper = record helper for TPoint 48 | public 49 | function ToString: string; 50 | constructor FromString(S: string); 51 | end; 52 | 53 | // Popup Menu Helper 54 | TPopupMenuHelper = class helper for TPopupMenu 55 | public 56 | procedure Popup(P: TPoint); overload; inline; 57 | procedure PopupAtMouseCursor; overload; inline; 58 | end; 59 | 60 | // TDateTime Helper 61 | TDateTimeHelper = record helper for TDateTime 62 | public 63 | function ToString: string; overload; inline; 64 | function ToInteger: integer; overload; inline; 65 | 66 | function Day: integer; 67 | function Month: integer; 68 | function Year: integer; 69 | 70 | function Hour: integer; 71 | function Minute: integer; 72 | function Second: integer; 73 | function Millisecond: integer; 74 | end; 75 | 76 | // TFont 77 | TAdvFont = type string; 78 | 79 | TAdvFontHelper = record helper for TAdvFont 80 | function ToString: string; 81 | procedure FromString(AString: string); 82 | end; 83 | 84 | // Canvas 85 | TCanvasHelper = class helper for TCanvas 86 | procedure DrawHighQuality(ARect: TRect; Bitmap: TBitmap; Opacity: Byte = 255; HighQuality: Boolean = False); overload; 87 | procedure DrawHighQuality(ARect: TRect; Graphic: TGraphic; Opacity: Byte = 255; HighQuality: Boolean = False); overload; 88 | 89 | procedure StretchDraw(DestRect, SrcRect: TRect; Bitmap: TBitmap; Opacity: Byte); overload; 90 | procedure StretchDraw(Rect: TRect; Graphic: TGraphic; AOpacity: Byte); overload; 91 | 92 | procedure MoveTo(P: TPoint); overload; 93 | procedure LineTo(P: TPoint); overload; 94 | 95 | procedure Line(P1, P2: TPoint); 96 | 97 | procedure CopyRect(const Dest: TRect; Canvas: TCanvas; const Source: TRect; Opacity: Byte); overload; 98 | 99 | procedure GDIText(Text: string; Rectangle: TRect; AlignH: TLayout = TLayout.Beginning; AlignV: TLayout = TLayout.Beginning; Angle: integer = 0); 100 | procedure GDITint(Rectangle: TRect; Color: TColor; Opacity: byte = 75); 101 | procedure GDIRectangle(Rectangle: TRect; Brush: TGDIBrush; Pen: TGDIPen); 102 | procedure GDIRoundRect(RoundRect: TRoundRect; Brush: TGDIBrush; Pen: TGDIPen); 103 | procedure GDICircle(Rectangle: TRect; Brush: TGDIBrush; Pen: TGDIPen); 104 | procedure GDIPolygon(Points: TArray; Brush: TGDIBrush; Pen: TGDIPen); 105 | procedure GDILine(Line: TLine; Pen: TGDIPen); 106 | procedure GDIRoundedLine(Line: TLine; Pen: TGDIPen); 107 | procedure GDIRoundedCornerLine(Points: TPointsF; Pen: TGDIPen; Radius: single); overload; 108 | procedure GDIGraphic(Graphic: TGraphic; Rect: TRect); overload; 109 | procedure GDIGraphic(Graphic: TGraphic; Rect: TRect; Angle: integer); overload; 110 | procedure GDIGraphicRound(Graphic: TGraphic; Rect: TRect; Round: real); 111 | end; 112 | 113 | // Registry 114 | TRegHelper = Cod.Registry.TRegHelper; 115 | 116 | implementation 117 | 118 | // Color 119 | function TColorHelper.ToString: string; 120 | begin 121 | Result := colortostring( Self ); 122 | end; 123 | 124 | function TColorHelper.ToInteger: integer; 125 | begin 126 | Result := ColorToRgb( Self ); 127 | end; 128 | 129 | function TColorHelper.ToRGB: CRGB; 130 | begin 131 | Result := GetRGB( Self ); 132 | end; 133 | 134 | // Date Time 135 | function TDateTimeHelper.ToString: string; 136 | begin 137 | Result := DateTimeToStr( Self ); 138 | end; 139 | 140 | function TDateTimeHelper.ToInteger: integer; 141 | begin 142 | Result := DateTimeToUnix(Self); 143 | end; 144 | 145 | function TDateTimeHelper.Day: integer; 146 | begin 147 | Result := DayOf( Self ); 148 | end; 149 | 150 | function TDateTimeHelper.Month: integer; 151 | begin 152 | Result := MonthOf( Self ); 153 | end; 154 | 155 | function TDateTimeHelper.Year: integer; 156 | begin 157 | Result := YearOf( Self ); 158 | end; 159 | 160 | function TDateTimeHelper.Hour: integer; 161 | begin 162 | Result := HourOf( Self ); 163 | end; 164 | 165 | function TDateTimeHelper.Minute: integer; 166 | begin 167 | Result := MinuteOf( Self ); 168 | end; 169 | 170 | function TDateTimeHelper.Second: integer; 171 | begin 172 | Result := SecondOf( Self ); 173 | end; 174 | 175 | function TDateTimeHelper.Millisecond: integer; 176 | begin 177 | Result := MillisecondOf( Self ); 178 | end; 179 | 180 | // TFont 181 | function TAdvFontHelper.ToString: string; 182 | begin 183 | 184 | end; 185 | 186 | procedure TAdvFontHelper.FromString(AString: string); 187 | begin 188 | //TFont(Self). 189 | end; 190 | 191 | { TCanvasHelper } 192 | procedure TCanvasHelper.DrawHighQuality(ARect: TRect; Bitmap: TBitmap; Opacity: Byte = 255; HighQuality: Boolean = False); 193 | begin 194 | DrawGraphicHighQuality(Self, ARect, Bitmap, Opacity, HighQuality); 195 | end; 196 | 197 | procedure TCanvasHelper.DrawHighQuality(ARect: TRect; Graphic: TGraphic; Opacity: Byte = 255; HighQuality: Boolean = False); 198 | begin 199 | DrawGraphicHighQuality(Self, ARect, Graphic, Opacity, HighQuality); 200 | end; 201 | 202 | procedure TCanvasHelper.StretchDraw(DestRect, SrcRect: TRect; Bitmap: TBitmap; Opacity: Byte); 203 | begin 204 | GraphicStretchDraw( Self, DestRect, SrcRect, BitMap, Opacity); 205 | end; 206 | 207 | procedure TCanvasHelper.StretchDraw(Rect: TRect; Graphic: TGraphic; AOpacity: Byte); 208 | begin 209 | GraphicStretchDraw(Self, Rect, Graphic, AOpacity); 210 | end; 211 | 212 | procedure TCanvasHelper.CopyRect(const Dest: TRect; Canvas: TCanvas; const Source: TRect; Opacity: Byte); 213 | var 214 | BlendFunction: TBlendFunction; 215 | begin 216 | // Set up the blending parameters 217 | BlendFunction.BlendOp := AC_SRC_OVER; 218 | BlendFunction.BlendFlags := 0; 219 | BlendFunction.SourceConstantAlpha := Opacity; 220 | BlendFunction.AlphaFormat := AC_SRC_OVER; 221 | 222 | // Perform the alpha blending 223 | AlphaBlend( 224 | Self.Handle, Dest.Left, Dest.Top, Dest.Width, Dest.Height, 225 | Canvas.Handle, Source.Left, Source.Top, Source.Width, Source.Height, 226 | BlendFunction 227 | ); 228 | end; 229 | 230 | procedure TCanvasHelper.GDIText(Text: string; Rectangle: TRect; AlignH, 231 | AlignV: TLayout; Angle: integer); 232 | var 233 | AFont: TGPFont; 234 | AFormat: TGPStringFormat; 235 | FontStyle: integer; 236 | begin 237 | // Font Style 238 | FontStyle := 0; 239 | if fsBold in Font.Style then 240 | FontStyle := FontStyle or FontStyleBold; 241 | if fsItalic in Font.Style then 242 | FontStyle := FontStyle or FontStyleItalic; 243 | if fsUnderline in Font.Style then 244 | FontStyle := FontStyle or FontStyleUnderline; 245 | if fsStrikeOut in Font.Style then 246 | FontStyle := FontStyle or FontStyleStrikeout; 247 | 248 | // Font 249 | AFont := TGPFont.Create(Font.Name, Font.Size, FontStyle, UnitPixel); 250 | AFormat:= TGPStringFormat.Create; 251 | try 252 | AFormat.SetAlignment(StringAlignment(integer(AlignH))); 253 | AFormat.SetLineAlignment(StringAlignment(integer(AlignV))); 254 | 255 | // Draw 256 | DrawText(Self, Text, Rectangle, AFont, AFormat, GetRGB(Font.Color).MakeGDIBrush, Angle); 257 | finally 258 | AFont.Free; 259 | AFormat.Free; 260 | end; 261 | end; 262 | 263 | procedure TCanvasHelper.GDITint(Rectangle: TRect; Color: TColor; Opacity: byte = 75); 264 | begin 265 | TintPicture(Self, Rectangle, Color, Opacity); 266 | end; 267 | 268 | procedure TCanvasHelper.Line(P1, P2: TPoint); 269 | begin 270 | MoveTo(P1); 271 | LineTo(P2); 272 | end; 273 | 274 | procedure TCanvasHelper.LineTo(P: TPoint); 275 | begin 276 | LineTo(P.X, P.Y); 277 | end; 278 | 279 | procedure TCanvasHelper.MoveTo(P: TPoint); 280 | begin 281 | MoveTo(P.X, P.Y); 282 | end; 283 | 284 | procedure TCanvasHelper.GDIRectangle(Rectangle: TRect; Brush: TGDIBrush; 285 | Pen: TGDIPen); 286 | begin 287 | DrawRectangle(Self, Rectangle, Brush, Pen); 288 | end; 289 | 290 | procedure TCanvasHelper.GDIRoundedCornerLine(Points: TPointsF; Pen: TGDIPen; Radius: single); 291 | begin 292 | DrawRoundedCornerLine(Self, Points, Pen, Radius); 293 | end; 294 | 295 | procedure TCanvasHelper.GDIRoundedLine(Line: TLine; Pen: TGDIPen); 296 | begin 297 | DrawRoundedLine(Self, Line, Pen); 298 | end; 299 | 300 | procedure TCanvasHelper.GDIRoundRect(RoundRect: TRoundRect; Brush: TGDIBrush; Pen: TGDIPen); 301 | begin 302 | DrawRoundRect(Self, RoundRect, Brush, Pen); 303 | end; 304 | 305 | procedure TCanvasHelper.GDICircle(Rectangle: TRect; Brush: TGDIBrush; Pen: TGDIPen); 306 | begin 307 | DrawCircle(Self, Rectangle, Brush, Pen); 308 | end; 309 | 310 | procedure TCanvasHelper.GDIPolygon(Points: TArray; Brush: TGDIBrush; Pen: TGDIPen); 311 | begin 312 | DrawPolygon(Self, Points, Brush, Pen); 313 | end; 314 | 315 | procedure TCanvasHelper.GDILine(Line: TLine; Pen: TGDIPen); 316 | begin 317 | DrawLine(Self, Line, Pen); 318 | end; 319 | 320 | procedure TCanvasHelper.GDIGraphic(Graphic: TGraphic; Rect: TRect); 321 | begin 322 | DrawGraphic(Self, Graphic, Rect, 0); 323 | end; 324 | 325 | procedure TCanvasHelper.GDIGraphic(Graphic: TGraphic; Rect: TRect; Angle: integer); 326 | begin 327 | DrawGraphic(Self, Graphic, Rect, Angle); 328 | end; 329 | 330 | procedure TCanvasHelper.GDIGraphicRound(Graphic: TGraphic; Rect: TRect; Round: real); 331 | begin 332 | DrawGraphicRound(Self, Graphic, Rect, Round); 333 | end; 334 | 335 | { TRectHelper } 336 | 337 | function TRectHelper.GetBottomLeft: TPoint; 338 | begin 339 | Result := Point(Left, Bottom); 340 | end; 341 | 342 | function TRectHelper.GetTopRight: TPoint; 343 | begin 344 | Result := Point(Right, Top); 345 | end; 346 | 347 | function TRectHelper.Normalised: boolean; 348 | begin 349 | Result := (Top <= Bottom) and (Left <= Right); 350 | end; 351 | 352 | { TPopupMenuHelper } 353 | 354 | procedure TPopupMenuHelper.Popup(P: TPoint); 355 | begin 356 | Popup(P.X, P.Y); 357 | end; 358 | 359 | procedure TPopupMenuHelper.PopupAtMouseCursor; 360 | begin 361 | Popup( Mouse.CursorPos ); 362 | end; 363 | 364 | { TPointHelper } 365 | 366 | constructor TPointHelper.FromString(S: string); 367 | begin 368 | const I = S.Split([','], 2); 369 | X := I[0].ToInteger; 370 | Y := I[1].ToInteger; 371 | end; 372 | 373 | function TPointHelper.ToString: string; 374 | begin 375 | Result := Format('%D,%D', [X, Y]); 376 | end; 377 | 378 | end. -------------------------------------------------------------------------------- /Source/Cod.Visual.Panels.pas: -------------------------------------------------------------------------------- 1 | unit Cod.Visual.Panels; 2 | 3 | interface 4 | 5 | uses 6 | SysUtils, 7 | Classes, 8 | Vcl.Controls, 9 | Vcl.Graphics, 10 | Vcl.ExtCtrls, 11 | Cod.ColorUtils, 12 | Cod.Graphics, 13 | Cod.SysUtils, 14 | Cod.Components; 15 | 16 | type 17 | CPanel = class(TPanel) 18 | public 19 | constructor Create(AOwner : TComponent); override; 20 | destructor Destroy; override; 21 | 22 | procedure Invalidate; override; 23 | 24 | private 25 | FAccent: CAccentColor; 26 | procedure SetUseAccentColor(const Value: CAccentColor); 27 | procedure ApplyAccentColor; 28 | 29 | published 30 | property UseAccentColor: CAccentColor read FAccent write SetUseAccentColor; 31 | 32 | end; 33 | 34 | CMinimisePanel = class(CPanel) 35 | constructor Create(AOwner : TComponent); override; 36 | destructor Destroy; override; 37 | private 38 | FHandleSize: integer; 39 | FHandleColor: TColor; 40 | FAutoHandleColor: boolean; 41 | FText: string; 42 | FMinimised: boolean; 43 | FAnimation: boolean; 44 | FHandleRound: integer; 45 | FUnderFill: boolean; 46 | FAutoCursor: boolean; 47 | FAutoFontColor: boolean; 48 | 49 | FBitmap: TBitMap; 50 | 51 | FAnGoTo, FAnStart: integer; 52 | FAnimTimer: TTimer; 53 | 54 | FAnimationSpeed: double; 55 | FPrevAutoSize: boolean; 56 | 57 | FSizeBeforeMin: integer; 58 | 59 | procedure DoneMinimise; 60 | 61 | procedure SetHandleSize(const Value: integer); 62 | procedure SetHandleRound(const Value: integer); 63 | procedure SetAutoHandeColor(const Value: boolean); 64 | procedure SetAccentFill(const Value: boolean); 65 | procedure StartToggle; 66 | procedure SetMinimiseState(statemin: boolean; instant: boolean = false); 67 | procedure SetMinimised(const Value: boolean); 68 | procedure AnimOnTimer(Sender: TObject); 69 | procedure SetBitMap(const Value: TBitMap); 70 | procedure SetText(const Value: string); 71 | procedure SetAutoColor(const Value: boolean); 72 | procedure SetAnimationSpeed(const Value: double); 73 | 74 | protected 75 | procedure Paint; override; 76 | 77 | procedure MouseUp(Button : TMouseButton; Shift: TShiftState; X, Y : integer); override; 78 | procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; 79 | 80 | public 81 | procedure ToggleMinimised; 82 | procedure ChangeMinimised(Minimised: boolean); 83 | 84 | published 85 | property OnMouseEnter; 86 | property OnMouseLeave; 87 | property OnMouseDown; 88 | property OnMouseUp; 89 | property OnMouseMove; 90 | property OnClick; 91 | 92 | property Align; 93 | property Anchors; 94 | property Cursor; 95 | property Visible; 96 | property Enabled; 97 | property Constraints; 98 | property DoubleBuffered; 99 | 100 | property HandleText: string read FText write SetText; 101 | property HandleSize: integer read FHandleSize write SetHandleSize; 102 | property HandleRoundness: integer read FHandleRound write SetHandleRound; 103 | property AutomaticHandleColor: boolean read FAutoHandleColor write SetAutoHandeColor; 104 | 105 | property IsMinimised: boolean read FMinimised write SetMinimised; 106 | property AccentShadeFill: boolean read FUnderFill write SetAccentFill; 107 | 108 | property AnimationSpeed: double read FAnimationSpeed write SetAnimationSpeed; 109 | property Animation: boolean read FAnimation write FAnimation; 110 | property Icon: TBitMap read FBitmap write SetBitMap; 111 | 112 | property AutomaticFontColor: boolean read FAutoFontColor write SetAutoColor; 113 | property DynamicCursor: boolean read FAutoCursor write FAutoCursor; 114 | end; 115 | 116 | implementation 117 | 118 | { CProgress } 119 | 120 | procedure CMinimisePanel.AnimOnTimer(Sender: TObject); 121 | var 122 | speed: integer; 123 | begin 124 | speed := 1; 125 | try 126 | //speed := trunc(abs(FAnGoTo - Height) / abs(FAnGoTo - FAnStart) * FSizeBeforeMin / 15); 127 | speed := trunc(abs(FAnGoTo - Height) / (11 - FAnimationSpeed)); 128 | except end; 129 | 130 | if speed <= 0 then 131 | speed := 1; 132 | 133 | if FAnGoTo < Height then 134 | Height := Height + speed * -1; 135 | 136 | if FAnGoTo > Height then 137 | Height := Height + speed; 138 | 139 | if FAnGoTo = Height then 140 | begin 141 | FAnimTimer.Enabled := false; 142 | 143 | // Done 144 | DoneMinimise; 145 | end; 146 | end; 147 | 148 | procedure CMinimisePanel.ChangeMinimised(Minimised: boolean); 149 | begin 150 | SetMinimiseState(Minimised); 151 | end; 152 | 153 | constructor CMinimisePanel.Create(AOwner: TComponent); 154 | begin 155 | inherited; 156 | Width := 350; 157 | Height := 200; 158 | 159 | ParentBackground := true; 160 | ShowCaption := false; 161 | TabStop := true; 162 | 163 | FAnimTimer := TTimer.Create(Self); 164 | with FAnimTimer do begin 165 | Interval := 1; 166 | Enabled := false; 167 | OnTimer := AnimOnTimer; 168 | end; 169 | 170 | Font.Size := 10; 171 | Font.Name := 'Segoe Ui'; 172 | 173 | if FBitMap = nil then 174 | FBitMap := TBitMap.Create; 175 | 176 | FAutoHandleColor := true; 177 | FHandleColor := clWhite;; 178 | FHandleRound := 20; 179 | 180 | FUnderFill := true; 181 | 182 | FAutoFontColor := true; 183 | 184 | FAnimationSpeed := 3.5; 185 | 186 | DoubleBuffered := true; 187 | 188 | FAnimation := true; 189 | FText := 'Minimised Panel'; 190 | 191 | ParentColor := true; 192 | 193 | FHandleSize := 30; 194 | end; 195 | 196 | destructor CMinimisePanel.Destroy; 197 | begin 198 | FAnimTimer.Enabled := false; 199 | FreeAndNil(FAnimTimer); 200 | FBitMap.Free; 201 | inherited; 202 | end; 203 | 204 | procedure CMinimisePanel.DoneMinimise; 205 | begin 206 | if not FMinimised then 207 | AutoSize := FPrevAutoSize; 208 | end; 209 | 210 | procedure CMinimisePanel.MouseMove(Shift: TShiftState; X, Y: Integer); 211 | begin 212 | inherited; 213 | if FAutoCursor then 214 | begin 215 | if Y <= FHandleSize then 216 | Cursor := crHandPoint 217 | else 218 | Cursor := crDefault; 219 | end; 220 | end; 221 | 222 | procedure CMinimisePanel.MouseUp(Button: TMouseButton; Shift: TShiftState; X, 223 | Y: integer); 224 | begin 225 | inherited; 226 | if Y <= FHandleSize then 227 | StartToggle; 228 | end; 229 | 230 | procedure CMinimisePanel.Paint; 231 | var 232 | tleft: integer; 233 | tmp: TBitMap; 234 | i: string; 235 | SColor: TColor; 236 | begin 237 | inherited; 238 | tmp := TBitMap.Create; 239 | tmp.Height := Height; 240 | tmp.Width := Width; 241 | 242 | SColor := ColorToRGB(Self.Color); 243 | 244 | with tmp.canvas do begin 245 | Brush.Color := SColor; 246 | FillRect(cliprect); 247 | 248 | Font.Assign(Self.Font); 249 | 250 | Pen.Style := psClear; 251 | 252 | if FUnderFill then 253 | begin 254 | if GetColorSat(SColor) >= 45 then 255 | Brush.Color := ChangeColorSat(SColor, -5) 256 | else 257 | Brush.Color := ChangeColorSat(SColor, 5); 258 | 259 | RoundRect(0, 0, Width, Height, FHandleRound, FHandleRound); 260 | end; 261 | 262 | if FAutoFontColor then 263 | begin 264 | if GetColorSat(SColor) >= 75 then 265 | Font.Color := clBlack 266 | else 267 | Font.Color := clWhite 268 | end; 269 | 270 | Brush.Color := FHandleColor; 271 | 272 | if FAutoHandleColor then 273 | begin 274 | if GetColorSat(SColor) >= 45 then 275 | Brush.Color := ChangeColorSat(SColor, -30) 276 | else 277 | Brush.Color := ChangeColorSat(SColor, 30); 278 | end; 279 | 280 | 281 | RoundRect(0, 0, Width, FHandleSize, FHandleRound, FHandleRound); 282 | 283 | if NOT FBitMap.Empty then 284 | begin 285 | tleft := trunc(FHandleSize * 1.1); 286 | 287 | FBitMap.Transparent := true; 288 | FBitMap.TransparentMode := tmAuto; 289 | 290 | StretchDraw(Rect(3, 3, FHandleSize - 3, FHandleSize - 3), FBitMap); 291 | end 292 | else 293 | tleft := 10; 294 | 295 | Brush.Style := bsClear; 296 | TextOut(tleft, FHandleSize div 2 - TextHeight(FText) div 2, FText); 297 | 298 | Pen.Style := psSolid; 299 | 300 | if FMinimised then 301 | i := '▼' 302 | else 303 | i := '▲'; 304 | 305 | Font.Size := GetMaxFontSize(tmp.Canvas, i, Width, FHandleSize); 306 | 307 | TextOut(Width - TextWidth(i) - 10, FHandleSize div 2 - TextHeight(i) div 2 - 3, i); 308 | end; 309 | 310 | canvas.CopyRect(canvas.ClipRect, tmp.Canvas, canvas.ClipRect); 311 | end; 312 | 313 | procedure CMinimisePanel.SetAccentFill(const Value: boolean); 314 | begin 315 | FUnderFill := Value; 316 | 317 | Paint; 318 | end; 319 | 320 | procedure CMinimisePanel.SetAnimationSpeed(const Value: double); 321 | begin 322 | FAnimationSpeed := Value; 323 | 324 | if FAnimationSpeed > 10 then 325 | FAnimationSpeed := 10; 326 | end; 327 | 328 | procedure CMinimisePanel.SetAutoColor(const Value: boolean); 329 | begin 330 | FAutoFontColor := Value; 331 | 332 | Paint; 333 | end; 334 | 335 | procedure CMinimisePanel.SetAutoHandeColor(const Value: boolean); 336 | begin 337 | FAutoHandleColor := Value; 338 | 339 | Paint; 340 | end; 341 | 342 | procedure CMinimisePanel.SetBitMap(const Value: TBitMap); 343 | begin 344 | FBitmap.Assign(Value); 345 | 346 | Paint; 347 | end; 348 | 349 | procedure CMinimisePanel.SetHandleRound(const Value: integer); 350 | begin 351 | FHandleRound := Value; 352 | 353 | Paint; 354 | end; 355 | 356 | procedure CMinimisePanel.SetHandleSize(const Value: integer); 357 | begin 358 | FHandleSize := Value; 359 | 360 | if FMinimised then 361 | Self.Height := Value; 362 | end; 363 | 364 | procedure CMinimisePanel.SetMinimised(const Value: boolean); 365 | begin 366 | FMinimised := Value; 367 | 368 | SetMinimiseState(Value, true); 369 | end; 370 | 371 | procedure CMinimisePanel.SetMinimiseState(statemin: boolean; instant: boolean); 372 | begin 373 | // Exit 374 | if statemin = FMinimised then 375 | Exit; 376 | 377 | FMinimised := NOT FMinimised; 378 | 379 | // Animation Timer 380 | if FAnimTimer.Enabled then 381 | begin 382 | if statemin then 383 | FAnGoTo := FHandleSize 384 | else 385 | FAnGoTo := FSizeBeforeMin; 386 | 387 | Exit; 388 | end; 389 | 390 | // Minimised State 391 | if statemin then 392 | begin 393 | FSizeBeforeMin := Height; 394 | FPrevAutoSize := AutoSize; 395 | 396 | // Requirements 397 | AutoSize := false; 398 | end; 399 | 400 | // Instant 401 | if (NOT FAnimation) or Instant then 402 | begin 403 | if statemin then 404 | Height := FHandleSize 405 | else 406 | Height := FSizeBeforeMin; 407 | 408 | // Done 409 | DoneMinimise; 410 | end 411 | else 412 | // Animation Based 413 | begin 414 | FAnStart := Height; 415 | 416 | if statemin then 417 | FAnGoTo := FHandleSize 418 | else 419 | FAnGoTo := FSizeBeforeMin; 420 | 421 | FAnimTimer.Enabled := true; 422 | end; 423 | end; 424 | 425 | procedure CMinimisePanel.SetText(const Value: string); 426 | begin 427 | FText := Value; 428 | 429 | Paint; 430 | end; 431 | 432 | procedure CMinimisePanel.StartToggle; 433 | begin 434 | SetMinimiseState(NOT FMinimised) 435 | end; 436 | 437 | procedure CMinimisePanel.ToggleMinimised; 438 | begin 439 | StartToggle; 440 | end; 441 | 442 | { CPanel } 443 | 444 | procedure CPanel.ApplyAccentColor; 445 | var 446 | AccColor: TColor; 447 | begin 448 | if FAccent = CAccentColor.None then 449 | Exit; 450 | 451 | AccColor := GetAccentColor(FAccent); 452 | 453 | Self.Color := AccColor; 454 | end; 455 | 456 | constructor CPanel.Create(AOwner: TComponent); 457 | begin 458 | inherited; 459 | 460 | BevelKind := bkNone; 461 | BevelOuter := bvNone; 462 | 463 | FAccent := CAccentColor.None; 464 | end; 465 | 466 | destructor CPanel.Destroy; 467 | begin 468 | 469 | inherited; 470 | end; 471 | 472 | procedure CPanel.Invalidate; 473 | begin 474 | inherited; 475 | 476 | ApplyAccentColor; 477 | end; 478 | 479 | procedure CPanel.SetUseAccentColor(const Value: CAccentColor); 480 | begin 481 | FAccent := Value; 482 | 483 | if Value <> CAccentColor.None then 484 | ParentColor := false; 485 | Invalidate; 486 | end; 487 | 488 | end. 489 | -------------------------------------------------------------------------------- /Source/Cod.Visual.SplashScreen.pas: -------------------------------------------------------------------------------- 1 | unit Cod.Visual.SplashScreen; 2 | 3 | interface 4 | 5 | uses 6 | SysUtils, 7 | Windows, 8 | Classes, 9 | Vcl.Controls, 10 | Vcl.Graphics, 11 | Vcl.ExtCtrls, 12 | Cod.Graphics, 13 | Cod.SysUtils, 14 | Types, 15 | Consts, 16 | Forms, 17 | Winapi.Messages, 18 | Messaging, 19 | Winapi.UxTheme, 20 | Vcl.TitleBarCtrls, 21 | Cod.Math, 22 | Cod.Types, 23 | Cod.Components; 24 | 25 | type 26 | CSplashScreen = class; 27 | 28 | CSplashScreenSizingMode = (szmForm, szmAlign, smzNone); 29 | CSplashScreenDoneSetup = procedure(Sender: CSplashScreen) of object; 30 | CSplashScreenFinalise = procedure(Sender: CSplashScreen) of object; 31 | 32 | CSplashScreen = class(TCustomControl) 33 | private 34 | FPicture: TPicture; 35 | FOnFindGraphicClass: TFindGraphicClassEvent; 36 | FIncrementalDisplay: Boolean; 37 | FTransparent: Boolean; 38 | FDrawing: Boolean; 39 | FMaxSize: integer; 40 | FExecuted: boolean; 41 | FDuration: integer; 42 | FTimer: TTimer; 43 | FSizeMode: CSplashScreenSizingMode; 44 | FOnSetupComplete: CSplashScreenDoneSetup; 45 | FOnFinalise: CSplashScreenFinalise; 46 | FTitleBar: TTitleBarPanel; 47 | FOpenSystemMenu: boolean; 48 | 49 | procedure PictureChanged(Sender: TObject); 50 | procedure SetPicture(Value: TPicture); 51 | procedure SetTransparent(Value: Boolean); 52 | procedure PrepareStart; 53 | 54 | procedure EndViewDuration(Sender: TObject); 55 | 56 | protected 57 | function DestRect: TRect; 58 | function DoPaletteChange: Boolean; 59 | procedure Paint; override; 60 | 61 | procedure FindGraphicClass(Sender: TObject; const Context: TFindGraphicClassContext; 62 | var GraphicClass: TGraphicClass); dynamic; 63 | procedure CMStyleChanged(var Message: TMessage); message CM_STYLECHANGED; 64 | 65 | procedure MouseUp(Button : TMouseButton; Shift: TShiftState; X, Y : integer); override; 66 | 67 | public 68 | constructor Create(AOwner: TComponent); override; 69 | destructor Destroy; override; 70 | 71 | procedure InvalidateControl; 72 | 73 | procedure EndScreen; 74 | 75 | published 76 | property Enabled; 77 | property Color; 78 | property ParentColor; 79 | property Duration: integer read FDuration write FDuration; 80 | property IncrementalDisplay: Boolean read FIncrementalDisplay write FIncrementalDisplay default False; 81 | property Picture: TPicture read FPicture write SetPicture; 82 | property PopupMenu; 83 | property ShowHint; 84 | property SuperiorCustomTitleBar: TTitleBarPanel read FTitleBar write FTitleBar; 85 | property OpenSystemMenu: boolean read FOpenSystemMenu write FOpenSystemMenu default true; 86 | property OnFinalise: CSplashScreenFinalise read FOnFinalise write FOnFinalise; 87 | property OnCompleteSetup: CSplashScreenDoneSetup read FOnSetupComplete write FOnSetupComplete; 88 | property Transparent: Boolean read FTransparent write SetTransparent default False; 89 | property SizingMode: CSplashScreenSizingMode read FSizeMode write FSizeMode; 90 | property Visible; 91 | property OnClick; 92 | property MaximumImageSize: integer read FMaxSize write FMaxSize; 93 | property OnFindGraphicClass: TFindGraphicClassEvent read FOnFindGraphicClass write FOnFindGraphicClass; 94 | property OnMouseActivate; 95 | property OnMouseDown; 96 | property OnMouseEnter; 97 | property OnMouseLeave; 98 | property OnMouseMove; 99 | property OnMouseUp; 100 | property OnStartDock; 101 | property OnStartDrag; 102 | end; 103 | 104 | implementation 105 | 106 | { CSplashScreen } 107 | 108 | procedure CSplashScreen.CMStyleChanged(var Message: TMessage); 109 | var 110 | G: TGraphic; 111 | begin 112 | inherited; 113 | if Transparent then 114 | begin 115 | G := Picture.Graphic; 116 | if (G <> nil) and not ((G is TMetaFile) or (G is TIcon)) and G.Transparent then 117 | begin 118 | G.Transparent := False; 119 | G.Transparent := True; 120 | end; 121 | end; 122 | end; 123 | 124 | constructor CSplashScreen.Create(AOwner: TComponent); 125 | begin 126 | inherited; 127 | FPicture := TPicture.Create; 128 | FPicture.OnChange := PictureChanged; 129 | FPicture.OnFindGraphicClass := FindGraphicClass; 130 | 131 | FOpenSystemMenu := true; 132 | 133 | ParentBackground := false; 134 | 135 | FExecuted := false; 136 | 137 | FDuration := 3000; 138 | 139 | FTimer := TTimer.Create(Self); 140 | with FTimer do begin 141 | Interval := FDuration; 142 | 143 | OnTimer := EndViewDuration; 144 | 145 | Enabled := false; 146 | end; 147 | 148 | FSizeMode := szmForm; 149 | 150 | Width := 75; 151 | Height := 75; 152 | end; 153 | 154 | function CSplashScreen.DestRect: TRect; 155 | var 156 | MRect: TRect; 157 | begin 158 | MRect := Rect(0, 0, Width, Height); 159 | 160 | if Picture.Graphic <> nil then begin 161 | const Rects = RectangleLayouts(TSize.Create(Picture.Graphic.Width, Picture.Graphic.Height), 162 | MRect, DrawModeToImageLayout(TDrawMode.Center)); 163 | Result := Rects[0]; 164 | end 165 | else 166 | Result := MRect; 167 | end; 168 | 169 | destructor CSplashScreen.Destroy; 170 | begin 171 | FPicture.Free; 172 | FreeAndNil(FTimer); 173 | inherited; 174 | end; 175 | 176 | function CSplashScreen.DoPaletteChange: Boolean; 177 | var 178 | ParentForm: TCustomForm; 179 | Tmp: TGraphic; 180 | begin 181 | Result := False; 182 | Tmp := Picture.Graphic; 183 | if Visible and (not (csLoading in ComponentState)) and (Tmp <> nil) and 184 | (Tmp.PaletteModified) then 185 | begin 186 | if (Tmp.Palette = 0) then 187 | Tmp.PaletteModified := False 188 | else 189 | begin 190 | ParentForm := GetParentForm(Self); 191 | if Assigned(ParentForm) and ParentForm.Active and Parentform.HandleAllocated then 192 | begin 193 | if FDrawing then 194 | ParentForm.Perform(wm_QueryNewPalette, 0, 0) 195 | else 196 | PostMessage(ParentForm.Handle, wm_QueryNewPalette, 0, 0); 197 | Result := True; 198 | Tmp.PaletteModified := False; 199 | end; 200 | end; 201 | end; 202 | end; 203 | 204 | procedure CSplashScreen.EndScreen; 205 | begin 206 | // Finalise 207 | Self.Visible := false; 208 | 209 | FTimer.Enabled := false; 210 | 211 | if Assigned(FOnFinalise) then 212 | FOnFinalise(Self); 213 | end; 214 | 215 | procedure CSplashScreen.EndViewDuration(Sender: TObject); 216 | begin 217 | EndScreen; 218 | end; 219 | 220 | procedure CSplashScreen.FindGraphicClass(Sender: TObject; 221 | const Context: TFindGraphicClassContext; var GraphicClass: TGraphicClass); 222 | begin 223 | if Assigned(FOnFindGraphicClass) then FOnFindGraphicClass(Sender, Context, GraphicClass); 224 | end; 225 | 226 | procedure CSplashScreen.InvalidateControl; 227 | begin 228 | Self.Invalidate; 229 | 230 | Paint; 231 | end; 232 | 233 | procedure CSplashScreen.MouseUp(Button: TMouseButton; Shift: TShiftState; X, 234 | Y: integer); 235 | begin 236 | inherited; 237 | if OpenSystemMenu and (Button = mbRight) then begin 238 | const Form = TForm(GetParentForm(Self)); 239 | if Form <> nil then 240 | OpenFormSystemMenu(Form); 241 | end; 242 | end; 243 | 244 | procedure CSplashScreen.Paint; 245 | procedure DoBufferedPaint(Canvas: TCanvas); 246 | var 247 | MemDC: HDC; 248 | Rect: TRect; 249 | PaintBuffer: HPAINTBUFFER; 250 | begin 251 | Rect := DestRect; 252 | PaintBuffer := BeginBufferedPaint(Canvas.Handle, Rect, BPBF_TOPDOWNDIB, nil, MemDC); 253 | try 254 | Canvas.Handle := MemDC; 255 | Canvas.StretchDraw(DestRect, Picture.Graphic); 256 | BufferedPaintMakeOpaque(PaintBuffer, Rect); 257 | finally 258 | EndBufferedPaint(PaintBuffer, True); 259 | end; 260 | end; 261 | 262 | function GetParentClientSize(Control: TControl): TPoint; {inline;} 263 | var 264 | LParent: TWinControl; 265 | begin 266 | LParent := Control.Parent; 267 | Result := Point(LParent.Width, LParent.Height); 268 | Dec(Result.X, LParent.Padding.Left + LParent.Padding.Right); 269 | Dec(Result.Y, LParent.Padding.Top + LParent.Padding.Bottom); 270 | end; 271 | 272 | var 273 | Save: Boolean; 274 | s: string; 275 | FRect: TRect; 276 | sz: TPoint; 277 | begin 278 | if csDesigning in ComponentState then 279 | with inherited Canvas do 280 | begin 281 | Pen.Style := psDash; 282 | Brush.Style := bsClear; 283 | Rectangle(0, 0, Width, Height); 284 | 285 | s := 'Splash Screen'; 286 | 287 | TextOut(Width div 2- TextWidth(s) div 2, Height div 2 - TextHeight(s) div 2, s); 288 | end; 289 | // 1st Setup 290 | if NOT (csDesigning in ComponentState) and Enabled then 291 | begin 292 | PrepareStart; 293 | 294 | // Sizing 295 | if FSizeMode = szmForm then 296 | begin 297 | Left := 0; 298 | Top := 0; 299 | 300 | sz := GetParentClientSize(Self); 301 | Width := sz.X; 302 | Height := sz.Y; 303 | end; 304 | end; 305 | 306 | 307 | 308 | // Draw 309 | Save := FDrawing; 310 | FDrawing := True; 311 | try 312 | if (csGlassPaint in ControlState) and (Picture.Graphic <> nil) and 313 | not Picture.Graphic.SupportsPartialTransparency then 314 | DoBufferedPaint(inherited Canvas) 315 | else 316 | with inherited Canvas do 317 | begin 318 | // Begin Draw 319 | if NOT Transparent then 320 | begin 321 | Brush.Color := Color; 322 | FillRect(ClipRect); 323 | end; 324 | 325 | FRect := DestRect; 326 | 327 | if (FRect.Height > FMaxSize) and (FRect.Width > FMaxSize) and (FMaxSize > 0) then 328 | begin 329 | FRect.Height := FMaxSize; 330 | FRect.Width := trunc(FMaxSize / Picture.Graphic.Height * Picture.Graphic.Width); 331 | 332 | CenterRectInRect(FRect, Rect(0, 0, Width, Height) ); 333 | end; 334 | 335 | StretchDraw(FRect, Picture.Graphic); 336 | end; 337 | finally 338 | FDrawing := Save; 339 | end; 340 | end; 341 | 342 | procedure CSplashScreen.PictureChanged(Sender: TObject); 343 | var 344 | G: TGraphic; 345 | D : TRect; 346 | begin 347 | if Observers.IsObserving(TObserverMapping.EditLinkID) then 348 | if TLinkObservers.EditLinkEdit(Observers) then 349 | TLinkObservers.EditLinkModified(Observers); 350 | 351 | if AutoSize and (Picture.Width > 0) and (Picture.Height > 0) then 352 | SetBounds(Left, Top, Picture.Width, Picture.Height); 353 | G := Picture.Graphic; 354 | if G <> nil then 355 | begin 356 | if not ((G is TMetaFile) or (G is TIcon)) then 357 | G.Transparent := FTransparent; 358 | D := DestRect; 359 | if (not G.Transparent) and (D.Left <= 0) and (D.Top <= 0) and 360 | (D.Right >= Width) and (D.Bottom >= Height) then 361 | ControlStyle := ControlStyle + [csOpaque] 362 | else // picture might not cover entire clientrect 363 | ControlStyle := ControlStyle - [csOpaque]; 364 | if DoPaletteChange and FDrawing then Update; 365 | end 366 | else ControlStyle := ControlStyle - [csOpaque]; 367 | if not FDrawing then Invalidate; 368 | 369 | if Observers.IsObserving(TObserverMapping.EditLinkID) then 370 | if TLinkObservers.EditLinkIsEditing(Observers) then 371 | TLinkObservers.EditLinkUpdate(Observers); 372 | end; 373 | 374 | procedure CSplashScreen.PrepareStart; 375 | begin 376 | if FExecuted then 377 | Exit; 378 | //Align := alClient; 379 | 380 | FExecuted := true; 381 | 382 | FTimer.Enabled := FDuration > 0; 383 | FTimer.Interval := FDuration; 384 | 385 | Visible := true; 386 | 387 | if FSizeMode = szmAlign then 388 | Align := alClient 389 | else 390 | if FSizeMode = szmForm then 391 | begin 392 | Top := 0; 393 | Left := 0; 394 | Width := GetParentForm(Self).ExplicitWidth; 395 | Height := GetParentForm(Self).ExplicitHeight - GetSystemMetrics(SM_CYCAPTION); 396 | end; 397 | 398 | BringToFront; 399 | 400 | if Assigned(FTitleBar) then 401 | FTitleBar.BringToFront; 402 | 403 | if Assigned(FOnSetupComplete) then 404 | FOnSetupComplete(Self); 405 | end; 406 | 407 | procedure CSplashScreen.SetPicture(Value: TPicture); 408 | begin 409 | Picture.Assign(Value); 410 | end; 411 | 412 | procedure CSplashScreen.SetTransparent(Value: Boolean); 413 | begin 414 | if Value <> FTransparent then 415 | begin 416 | FTransparent := Value; 417 | PictureChanged(Self); 418 | end; 419 | end; 420 | 421 | end. 422 | -------------------------------------------------------------------------------- /Source/Cod.Visual.ColorWheel.pas: -------------------------------------------------------------------------------- 1 | unit Cod.Visual.ColorWheel; 2 | 3 | interface 4 | 5 | uses 6 | SysUtils, 7 | Classes, 8 | Windows, 9 | Controls, 10 | Graphics, 11 | ExtCtrls, 12 | Cod.Components, 13 | Cod.Visual.CPSharedLib, 14 | System.Math, 15 | Styles, 16 | Cod.Visual.ColorBright, 17 | Forms, 18 | Themes, 19 | Types, 20 | Cod.SysUtils, 21 | Cod.Graphics, 22 | Cod.Types, 23 | Cod.VarHelpers, 24 | Imaging.pngimage; 25 | 26 | type 27 | CColorWheel = class; 28 | 29 | ColorWheelOverlay = (covNone, covEllipse, covLines); 30 | ColorWheelChangeColor = procedure(Sender: CColorWheel; Color: TColor; X, Y: integer) of object; 31 | ColorBrightItem = CColorBright; 32 | 33 | CColorWheel = class(TCustomTransparentControl) 34 | constructor Create(AOwner : TComponent); override; 35 | destructor Destroy; override; 36 | private 37 | Wheel: TBitMap; 38 | ColorCoord: TPoint; 39 | FColor: TColor; 40 | MouseIsDown, 41 | FEnableRadiusCoord, 42 | FEnableLineCoord, 43 | FTransparent, 44 | FirstStart, 45 | FSyncBgColor: boolean; 46 | Xo, Yo, 47 | FRadius: integer; 48 | FOverLay: ColorWheelOverlay; 49 | FChangeColor: ColorWheelChangeColor; 50 | FColorBright: ColorBrightItem; 51 | FTrueTransparent: boolean; 52 | 53 | function HSBtoColor(hue, sat, bri: Double): TColor; 54 | function ColorWheel(Width, Height: Integer; Background: TColor = clWhite): TBitMap; 55 | procedure RedrawWheel; 56 | procedure ChangeColor(color: TColor; x, y: integer); 57 | procedure SetFormSync(const Value: boolean); 58 | procedure SetColor(const Value: TColor); 59 | procedure SetTransparent(const Value: boolean); 60 | procedure SetTrueTransparent(const Value: boolean); 61 | 62 | protected 63 | procedure Paint; override; 64 | procedure KeyPress(var Key: Char); override; 65 | procedure MouseDown(Button : TMouseButton; Shift: TShiftState; X, Y : integer); override; 66 | procedure MouseUp(Button : TMouseButton; Shift: TShiftState; X, Y : integer); override; 67 | procedure MouseMove(Shift: TShiftState; X, Y : integer); override; 68 | procedure DoEnter; override; 69 | procedure DoExit; override; 70 | 71 | published 72 | property OnMouseEnter; 73 | property OnMouseLeave; 74 | property OnMouseDown; 75 | property OnMouseUp; 76 | property OnMouseMove; 77 | property OnClick; 78 | 79 | property TabStop; 80 | property TabOrder; 81 | 82 | property Color; 83 | property ParentColor; 84 | 85 | property Align; 86 | property Anchors; 87 | property Cursor; 88 | property Visible; 89 | property Enabled; 90 | property Constraints; 91 | property DoubleBuffered; 92 | property ColorBright: ColorBrightItem read FColorBright write FColorBright; 93 | property ChangeWheelColor: ColorWheelChangeColor read FChangeColor write FChangeColor; 94 | property FormSyncedColor : boolean read FSyncBgColor write SetFormSync; 95 | 96 | property TrueTransparency: boolean read FTrueTransparent write SetTrueTransparent; 97 | 98 | property EnableRadiusCoordonation: boolean read FEnableRadiusCoord write FEnableRadiusCoord; 99 | property EnableLineCoordonation: boolean read FEnableLineCoord write FEnableLineCoord; 100 | 101 | property Transparent: boolean read FTransparent write SetTransparent; 102 | property CurrentColor: TColor read FColor write SetColor; 103 | end; 104 | 105 | implementation 106 | 107 | { CColorWheel } 108 | 109 | function CColorWheel.HSBtoColor(hue, sat, bri: Double): TColor; 110 | var 111 | f, h: Double; 112 | u, p, q, t: Byte; 113 | begin 114 | u := Trunc(bri * 255 + 0.5); 115 | if sat = 0 then 116 | Exit(rgb(u, u, u)); 117 | 118 | h := (hue - Floor(hue)) * 6; 119 | f := h - Floor(h); 120 | p := Trunc(bri * (1 - sat) * 255 + 0.5); 121 | q := Trunc(bri * (1 - sat * f) * 255 + 0.5); 122 | t := Trunc(bri * (1 - sat * (1 - f)) * 255 + 0.5); 123 | 124 | case Trunc(h) of 125 | 0: 126 | result := rgb(u, t, p); 127 | 1: 128 | result := rgb(q, u, p); 129 | 2: 130 | result := rgb(p, u, t); 131 | 3: 132 | result := rgb(p, q, u); 133 | 4: 134 | result := rgb(t, p, u); 135 | 5: 136 | result := rgb(u, p, q); 137 | else 138 | result := clwhite; 139 | end; 140 | 141 | end; 142 | 143 | procedure CColorWheel.KeyPress(var Key: Char); 144 | var 145 | x, y: integer; 146 | begin 147 | if (key = 'a') then begin 148 | x := colorcoord.X - 3; 149 | if (x > 0) and (x < width)then 150 | MouseDown(mbLeft,[], x, colorcoord.Y); 151 | MouseUp(mbLeft,[],x,colorcoord.Y); 152 | end; 153 | if (key = 'd') then begin 154 | x := colorcoord.X + 3; 155 | if (x > 0) and (x < width)then 156 | MouseDown(mbLeft,[], x, colorcoord.Y); 157 | MouseUp(mbLeft,[],x,colorcoord.Y); 158 | end; 159 | if (key = 'w') then begin 160 | y := colorcoord.Y - 3; 161 | if (y > 0) and (y < height)then 162 | MouseDown(mbLeft,[], colorcoord.X, Y); 163 | MouseUp(mbLeft,[], colorcoord.X, Y); 164 | end; 165 | if (key = 's') then begin 166 | y := colorcoord.Y + 3; 167 | if (y > 0) and (y < height)then 168 | MouseDown(mbLeft,[], colorcoord.X, Y); 169 | MouseUp(mbLeft,[], colorcoord.X, Y); 170 | end; 171 | end; 172 | 173 | procedure CColorWheel.MouseDown(Button: TMouseButton; Shift: TShiftState; X, 174 | Y: integer); 175 | begin 176 | inherited; 177 | MouseIsDown := true; 178 | MouseMove(Shift, X, Y); 179 | end; 180 | 181 | procedure CColorWheel.MouseMove(Shift: TShiftState; X, Y: integer); 182 | var 183 | r{, ro}: real; 184 | np: TPoint; 185 | begin 186 | inherited; 187 | 188 | if NOT (Power((x - Xo), 2) + Power((y - Yo), 2) < Power(Xo, 2)) then 189 | Exit; 190 | 191 | //ro := sqrt( Power((colorcoord.x - Xo), 2) + Power((colorcoord.y - Yo), 2) ); 192 | 193 | r := sqrt( Power((x - Xo), 2) + Power((y - Yo), 2) ); 194 | 195 | FRadius := trunc(r); 196 | 197 | FOverLay := covNone; 198 | if FEnableRadiusCoord and (ssShift in Shift) then 199 | begin 200 | FOverLay := covEllipse; 201 | 202 | //Apply radius changes 203 | {sina := (y - yo) / FRadius; 204 | cosa := (x - xo) / FRadius; 205 | 206 | 207 | 208 | X := round(Xo + FRadius * sina); 209 | Y := round(Yo + FRadius * cosa); } 210 | 211 | np := RotatePointAroundPoint(Point(X, Y), Point(Xo, Yo), 0, 50); 212 | X := np.X; 213 | Y := np.Y; 214 | 215 | {if radiusold <> FRadius then } 216 | end; 217 | 218 | 219 | if MouseIsDown then begin 220 | ColorCoord.X := X; 221 | ColorCoord.Y := Y; 222 | 223 | ChangeColor(Wheel.Canvas.Pixels[trunc(x / width * wheel.Width), trunc(y / height * wheel.Width)], x, y); 224 | Paint; 225 | end; 226 | end; 227 | 228 | procedure CColorWheel.MouseUp(Button: TMouseButton; Shift: TShiftState; X, 229 | Y: integer); 230 | begin 231 | inherited; 232 | MouseIsDown := false; 233 | 234 | MouseIsDown := false; 235 | try 236 | Self.SetFocus; 237 | Paint; 238 | except 239 | end; 240 | end; 241 | 242 | procedure CColorWheel.ChangeColor(color: TColor; x, y: integer); 243 | begin 244 | FColor := color; 245 | if Assigned(FChangeColor) then FChangeColor(Self, color, x, y); 246 | if Assigned(FColorBright) then FColorBright.PureColor := color; 247 | end; 248 | 249 | function CColorWheel.ColorWheel(Width, Height: Integer; Background: TColor): TBitMap; 250 | var 251 | Center: TPoint; 252 | Radius: Integer; 253 | x, y: Integer; 254 | Hue, dy, dx, dist, theta: Double; 255 | Bmp: TBitmap; 256 | begin 257 | Bmp := TBitmap.Create; 258 | Bmp.SetSize(Width, Height); 259 | with Bmp.Canvas do 260 | begin 261 | Brush.Color := Background; 262 | FillRect(ClipRect); 263 | Center := ClipRect.CenterPoint; 264 | Radius := Center.X; 265 | if Center.Y < Radius then 266 | Radius := Center.Y; 267 | for y := 0 to Height - 1 do 268 | begin 269 | dy := y - Center.y; 270 | for x := 0 to Width - 1 do 271 | begin 272 | dx := x - Center.x; 273 | dist := Sqrt(Sqr(dx) + Sqr(dy)); 274 | if dist <= Radius then 275 | begin 276 | theta := ArcTan2(dy, dx); 277 | Hue := (theta + PI) / (2 * PI); 278 | Pixels[x, y] := HSBtoColor(Hue, 1, 1); 279 | end; 280 | end; 281 | end; 282 | end; 283 | 284 | Result := TBitMap.Create; 285 | Result.Assign(Bmp); 286 | Bmp.Free; 287 | end; 288 | 289 | constructor CColorWheel.Create(AOwner: TComponent); 290 | begin 291 | inherited; 292 | interceptmouse:=True; 293 | TabStop := true; 294 | 295 | FTransparent := false; 296 | FSyncBgColor := true; 297 | 298 | FEnableRadiusCoord := true; 299 | FEnableLineCoord := true; 300 | 301 | Width := 100; 302 | Height := 100; 303 | 304 | Xo := width div 2; 305 | Yo := height div 2; 306 | 307 | colorcoord := Point(Xo, Yo); 308 | end; 309 | 310 | destructor CColorWheel.Destroy; 311 | begin 312 | FreeAndNil(wheel); 313 | inherited; 314 | end; 315 | 316 | 317 | procedure CColorWheel.DoEnter; 318 | begin 319 | inherited; 320 | 321 | end; 322 | 323 | procedure CColorWheel.DoExit; 324 | begin 325 | inherited; 326 | Paint; 327 | end; 328 | 329 | procedure CColorWheel.Paint; 330 | begin 331 | inherited; 332 | 333 | if NOT FirstStart then begin 334 | RedrawWheel; 335 | FirstStart := true; 336 | end; 337 | 338 | //Set Center 339 | Xo := width div 2; 340 | Yo := height div 2; 341 | 342 | if width < height then height := width; 343 | if height < width then width := height; 344 | 345 | if (FTransparent) and (NOT Wheel.Transparent) then 346 | begin 347 | Wheel.Transparent := true; 348 | Wheel.TransparentColor := clWhite; 349 | Wheel.TransparentMode := tmAuto; 350 | end else if Wheel.Transparent then Wheel.Transparent := false; 351 | 352 | 353 | with canvas do begin 354 | Brush.Color := TStyleManager.ActiveStyle.GetSystemColor(Color); 355 | 356 | //Draw Color Wheel 357 | if FTrueTransparent then 358 | CopyRoundRect(wheel.Canvas, MakeRoundRect(Rect(0, 0, wheel.Width, wheel.Height), Width, Height), Canvas, canvas.ClipRect, 3) 359 | else 360 | StretchDraw(Rect(0, 0, width, height), wheel, 255); 361 | 362 | //Select Pen Color 363 | if Self.Focused then 364 | Pen.Color := clWhite 365 | else 366 | Pen.Color := clBlack; 367 | 368 | {TextOut(5,20,'Color Sat' + inttostr(CalculateLight(FColor) ) ); } 369 | 370 | //Draw Overlay 371 | Brush.Style := bsClear; 372 | case FOverLay of 373 | covEllipse: begin 374 | Ellipse( Xo - FRadius - 1, Yo - FRadius - 1, Xo + FRadius + 1, Yo + FRadius + 1); 375 | end; 376 | end; 377 | 378 | //Draw Icon 379 | Pen.Width := 1; 380 | Brush.Style := bsClear; 381 | //Rectangle(ColorCoord.X - 2, ColorCoord.Y - 2, ColorCoord.X + 2, ColorCoord.Y + 2); 382 | Ellipse(ColorCoord.X - 2, ColorCoord.Y - 2, ColorCoord.X + 2, ColorCoord.Y + 2); 383 | 384 | {Pen.Color := clBLack; 385 | Ellipse(ColorCoord.X - 3, ColorCoord.Y - 3, ColorCoord.X + 3, ColorCoord.Y + 3); } 386 | end; 387 | end; 388 | 389 | procedure CColorWheel.RedrawWheel; 390 | var 391 | bgc: TColor; 392 | begin 393 | bgc := Self.Color; 394 | 395 | if FSyncBgColor then 396 | begin 397 | if StrInArray(TStyleManager.ActiveStyle.Name, nothemes) then begin 398 | bgc := GetParentForm(Self).Color; 399 | end else begin 400 | bgc := TStyleManager.ActiveStyle.GetSystemColor(clBtnFace); 401 | end; 402 | end; 403 | 404 | if wheel = nil then 405 | wheel := TBitMap.Create; 406 | 407 | wheel := ColorWheel(Self.Width, Self.Height, bgc); 408 | end; 409 | 410 | procedure CColorWheel.SetColor(const Value: TColor); 411 | var 412 | Center: TPoint; 413 | dist, Hue: real; 414 | theta: single; 415 | radius, dx, dy, x, y: integer; 416 | begin 417 | FColor := Value; 418 | 419 | {if CalculateLight(FColor) > 60 then 420 | FColor := ChangeColorSat(FColor, -20); } 421 | 422 | Xo := width div 2; 423 | Yo := height div 2; 424 | 425 | Center := Point(Xo, Yo); 426 | Radius := Center.X; 427 | if Center.Y < Radius then 428 | Radius := Center.Y; 429 | for y := 0 to Height - 1 do 430 | begin 431 | dy := y - Center.y; 432 | for x := 0 to Width - 1 do 433 | begin 434 | dx := x - Center.x; 435 | dist := Sqrt(Sqr(dx) + Sqr(dy)); 436 | if dist <= Radius then 437 | begin 438 | theta := ArcTan2(dy, dx); 439 | Hue := (theta + PI) / (2 * PI); 440 | if FColor = HSBtoColor(Hue, 1, 1) then 441 | begin 442 | ColorCoord.X := X; 443 | ColorCoord.Y := Y; 444 | Paint; 445 | Exit; 446 | end; 447 | end; 448 | end; 449 | end; 450 | 451 | ColorCoord.X := Xo; 452 | ColorCoord.Y := Yo; 453 | Paint; 454 | end; 455 | 456 | procedure CColorWheel.SetFormSync(const Value: boolean); 457 | begin 458 | FSyncBgColor := Value; 459 | if FirstStart then 460 | RedrawWheel; 461 | Paint; 462 | end; 463 | 464 | procedure CColorWheel.SetTransparent(const Value: boolean); 465 | begin 466 | FTransparent := Value; 467 | end; 468 | 469 | procedure CColorWheel.SetTrueTransparent(const Value: boolean); 470 | begin 471 | FTrueTransparent := Value; 472 | 473 | if Value then 474 | Invalidate; 475 | end; 476 | 477 | end. 478 | -------------------------------------------------------------------------------- /Source/Cod.Visual.Chart.pas: -------------------------------------------------------------------------------- 1 | unit Cod.Visual.Chart; 2 | 3 | interface 4 | 5 | uses 6 | SysUtils, 7 | Classes, 8 | Vcl.Controls, 9 | Types, 10 | Vcl.ExtCtrls, 11 | Cod.Visual.CPSharedLib, 12 | Math, 13 | Vcl.Forms, 14 | WinApi.Windows, 15 | Vcl.Graphics, 16 | Vcl.Themes, 17 | Vcl.Styles, 18 | UITypes, 19 | Cod.Components, 20 | Cod.Types, 21 | Cod.Graphics; 22 | 23 | type 24 | CChart = class; 25 | 26 | CChartPresets = (ccpNone, ccpPie, ccpPieSimple, ccpBorderPie, ccpBorderPieModern); 27 | CChartChange = procedure(Sender : CChart; Position, Max: integer) of object; 28 | 29 | CChartOptions = class(TMPersistent) 30 | private 31 | //exceptpreset: boolean; 32 | published 33 | //property PresetException: boolean read exceptpreset write exceptpreset; 34 | end; 35 | 36 | CChartAnimate = class(TMPersistent) 37 | private 38 | FAnimations: boolean; 39 | FInterval, FStep, FAnimateTo: integer; 40 | published 41 | property Animations: boolean read FAnimations write FAnimations; 42 | property Interval: integer read FInterval write FInterval; 43 | property Step: integer read FStep write FStep; 44 | end; 45 | 46 | CChart = class(TCustomTransparentControl) 47 | constructor Create(AOwner : TComponent); override; 48 | destructor Destroy; override; 49 | private 50 | FAuthor, FSite, FVersion: string; 51 | FOptions: CChartOptions; 52 | FColor, 53 | FColorBG, 54 | FEmptyColor, 55 | FPenColor: TColor; 56 | FAnimation: CChartAnimate; 57 | FPreset: CChartPresets; 58 | FWid, 59 | FPenWid, 60 | FPosition, 61 | FMax, 62 | FStartAngle: integer; 63 | FOnChange: CChartChange; 64 | FAutoAngle, 65 | FEnableEColor, 66 | FSyncBgColor: boolean; 67 | FAnimationTimer: TTimer; 68 | FAccent: CAccentColor; 69 | 70 | procedure FAnimationTimerEvent(Sender: TObject); 71 | procedure ApplyPreset(const Value: CChartPresets); 72 | procedure SetPenWidth(const Value: integer); 73 | procedure SetColorBG(const Value: TColor); 74 | procedure SetPieColor(const Value: TColor); 75 | procedure SetPenColor(const Value: TColor); 76 | procedure SetPosition(const Value: integer); 77 | procedure SetMax(const Value: integer); 78 | procedure SetStartAngle(const Value: integer); 79 | procedure SetAutoAngle(const Value: boolean); 80 | procedure SetWid(const Value: integer); 81 | procedure SetEmptyColor(const Value: TColor); 82 | procedure SetEColor(const Value: boolean); 83 | procedure SetPresets(const Value: CChartPresets); 84 | procedure ApplyAccentColor; 85 | procedure SetAccentColor(const Value: CAccentColor); 86 | 87 | protected 88 | procedure Paint; override; 89 | 90 | published 91 | property OnMouseEnter; 92 | property OnMouseLeave; 93 | property OnMouseDown; 94 | property OnMouseUp; 95 | property OnMouseMove; 96 | property OnClick; 97 | 98 | property ShowHint; 99 | property Align; 100 | property Anchors; 101 | property Cursor; 102 | property Visible; 103 | property Enabled; 104 | property Constraints; 105 | property DoubleBuffered; 106 | property OnChange : CChartChange read FOnChange write FOnChange; 107 | 108 | property FormSyncedColor : boolean read FSyncBgColor write FSyncBgColor; 109 | 110 | property AccentColor: CAccentColor read FAccent write SetAccentColor; 111 | property ColorEmptyEnable: boolean read FEnableEColor write SetEColor; 112 | property AutoStartAngle : boolean read FAutoAngle write SetAutoAngle; 113 | property Presets : CChartPresets read FPreset write SetPresets; 114 | property Options : CChartOptions read FOptions write FOptions; 115 | property Color : TColor read FColor write SetPieColor; 116 | property ColorEmpty : TColor read FEmptyColor write SetEmptyColor; 117 | property ChartWidth: integer read FWid write SetWid; 118 | property PenColor : TColor read FPenColor write SetPenColor; 119 | property PenWidth: integer read FPenWid write SetPenWidth; 120 | property MaxValue: integer read FMax write SetMax; 121 | property Position: integer read FPosition write SetPosition; 122 | property StartingAngle: integer read Fstartangle write SetStartAngle; 123 | property ColorBackGround : TColor read FColorBG write SetColorBG; 124 | property Animations: CChartAnimate read FAnimation write FAnimation; 125 | 126 | property &&&Author: string Read FAuthor; 127 | property &&&Site: string Read FSite; 128 | property &&&Version: string Read FVersion; 129 | end; 130 | 131 | implementation 132 | 133 | { CChart } 134 | 135 | constructor CChart.Create(AOwner: TComponent); 136 | begin 137 | inherited; 138 | FAuthor := 'Petculescu Codrut'; 139 | FSite := 'https://www.codrutsoftware.cf'; 140 | FVersion := '1.4'; 141 | 142 | interceptmouse:=True; 143 | 144 | FAnimation := CChartAnimate.Create(self); 145 | with FAnimation do begin 146 | FAnimations := true; 147 | FInterval := 1; 148 | FStep := 1; 149 | end; 150 | 151 | FAnimationTimer := TTimer.Create(nil); 152 | with FAnimationTimer do begin 153 | Interval := FAnimation.Interval; 154 | OnTimer := FAnimationTimerEvent; 155 | Enabled := false; 156 | end; 157 | 158 | FSyncBgColor := true; 159 | 160 | FOptions := CChartOptions.Create(self); 161 | with FOptions do begin 162 | 163 | end; 164 | 165 | FPreset := CChartPresets.ccpNone; 166 | 167 | FEnableEColor := false; 168 | 169 | FPosition := 75; 170 | FStartAngle := 90; 171 | FAutoAngle := true; 172 | FMax := 100; 173 | 174 | FWid := 100; 175 | 176 | FColor := $00C57517; 177 | FColorBG := clBtnFace; 178 | FPenColor := $008E5611; 179 | FEmptyColor := clSilver; 180 | 181 | FPenWid := 3; 182 | 183 | FAccent := CAccentColor.AccentAdjust; 184 | ApplyAccentColor; 185 | 186 | Width := 100; 187 | Height := 100; 188 | end; 189 | 190 | destructor CChart.Destroy; 191 | begin 192 | FreeAndNil(FAnimation); 193 | FreeAndNil(FOptions); 194 | FAnimationTimer.Enabled := false; 195 | FreeAndNil(FAnimationTimer); 196 | inherited; 197 | end; 198 | 199 | procedure CChart.FAnimationTimerEvent(Sender: TObject); 200 | begin 201 | if FAnimationTimer.Tag = 0 then begin // -- 202 | if FPosition <= FAnimation.FANimateTo then begin 203 | FPosition := FAnimation.FAnimateTo; 204 | FAnimationTimer.Enabled := False; 205 | end else dec(FPosition,FAnimation.Step) 206 | end else if FAnimationTimer.Tag = 1 then begin // ++ 207 | if FPosition >= FAnimation.FAnimateTo then begin 208 | FPosition := FAnimation.FAnimateTo; 209 | FAnimationTimer.Enabled := False; 210 | end else inc(FPosition,FAnimation.Step) 211 | end; 212 | if Assigned(FOnChange) then FOnChange(self, FPosition, FMax); 213 | Paint; 214 | end; 215 | 216 | procedure CChart.Paint; 217 | var 218 | c, WRem: integer; 219 | a, b, percent, startp, r: real; 220 | P1, P2: TPoint; 221 | workon: TBitMap; 222 | bgcolor: TColor; 223 | begin 224 | inherited; 225 | ApplyAccentColor; 226 | ApplyPreset(FPreset); 227 | 228 | if Width > Height then Height := Width; 229 | if Height > Width then Width := Height; 230 | 231 | c := height div 2; 232 | 233 | workon := TBitMap.Create; 234 | workon.Width := Width; 235 | workon.Height := Height; 236 | try 237 | with workon.Canvas do begin 238 | Brush.Color := FColorBG; 239 | if FSyncBgColor then 240 | begin 241 | if StrInArray(TStyleManager.ActiveStyle.Name, nothemes) then begin 242 | Brush.Color := GetParentForm(Self).Color; 243 | end else 244 | Brush.Color := TStyleManager.ActiveStyle.GetSystemColor(clBtnFace); 245 | end; 246 | FillRect( Self.ClientRect ); 247 | bgcolor := Brush.Color; 248 | 249 | Pen.Width := FPenWid; 250 | Pen.Color := FPenColor; 251 | 252 | r := width - FPenWid * 4; 253 | 254 | if FAutoAngle then 255 | startp := FPosition - Fstartangle 256 | else 257 | startp := Fstartangle - 90; 258 | 259 | percent := trunc((FMax - FPosition) / FMax * 360); 260 | a := DegToRad(startp); 261 | b := DegToRad(startp + percent); 262 | p1.X := trunc(c + r * cos(a)); 263 | p1.Y := trunc(c + r * sin(a)); 264 | p2.X := trunc(c + r * cos(b)); 265 | p2.Y := trunc(c + r * sin(b)); 266 | 267 | if (FEnableEColor) or (FWid < 100) then begin 268 | Pen.Style := psClear; 269 | Brush.Color := FEmptyColor; 270 | Ellipse(FPenWid, FPenWid, width - FPenWid, height - FPenWid); 271 | end; 272 | 273 | Brush.Color := FColor; 274 | if FPenWid <> 0 then Pen.Style := psSolid else Pen.Style := psClear; 275 | Pie(FPenWid, FPenWid, width - FPenWid, height - FPenWid, p1.X, p1.Y, p2.X, p2.Y); 276 | 277 | if FWid < 100 then begin 278 | Pen.Width := 0; 279 | Pen.Style := psClear; 280 | Brush.Color := bgcolor; 281 | WRem := trunc(FWid / 100 * c); 282 | Ellipse(WRem, WRem, Width - WRem, Height - WRem); 283 | end; 284 | end; 285 | finally 286 | // Finalise 287 | //Canvas.CopyRect(Rect(0,0,width,height), workon.Canvas, workon.canvas.Self.ClientRect); 288 | CopyRoundRect(workon.Canvas, MakeRoundRect(Rect(3, 3, Width - 3, Height - 3), 1000, 1000), Canvas, Self.ClientRect); 289 | 290 | workon.Free; 291 | end; 292 | 293 | end; 294 | 295 | procedure CChart.SetAccentColor(const Value: CAccentColor); 296 | begin 297 | FAccent := Value; 298 | 299 | 300 | if Value <> CAccentColor.None then 301 | ApplyAccentColor; 302 | 303 | Paint; 304 | end; 305 | 306 | procedure CChart.SetAutoAngle(const Value: boolean); 307 | begin 308 | FAutoAngle := Value; 309 | end; 310 | 311 | procedure CChart.SetColorBG(const Value: TColor); 312 | begin 313 | FColorBG := Value; 314 | Paint; 315 | end; 316 | 317 | procedure CChart.SetEColor(const Value: boolean); 318 | begin 319 | FEnableEColor := Value; 320 | Paint; 321 | end; 322 | 323 | procedure CChart.SetEmptyColor(const Value: TColor); 324 | begin 325 | FEmptyColor := Value; 326 | Paint; 327 | end; 328 | 329 | procedure CChart.SetMax(const Value: integer); 330 | begin 331 | FMax := Value; 332 | Paint; 333 | end; 334 | 335 | procedure CChart.SetPenColor(const Value: TColor); 336 | begin 337 | FPenColor := Value; 338 | Paint; 339 | end; 340 | 341 | procedure CChart.SetPenWidth(const Value: integer); 342 | begin 343 | FPenWid := Value; 344 | Paint; 345 | end; 346 | 347 | procedure CChart.SetPieColor(const Value: TColor); 348 | begin 349 | FColor := Value; 350 | Paint; 351 | end; 352 | 353 | procedure CChart.SetPosition(const Value: integer); 354 | begin 355 | if Value <= FMax then begin 356 | if FAnimation.Animations then begin 357 | if Value < FPosition then 358 | FAnimationTimer.Tag :=0 // -- 359 | else if Value > Position then 360 | FAnimationTimer.Tag := 1; // ++ 361 | 362 | FAnimation.FAnimateTo := Value; 363 | FAnimationTimer.Interval := FAnimation.Interval; 364 | FAnimationTimer.Enabled := true; 365 | Paint; 366 | end else begin 367 | FPosition := Value; 368 | if Assigned(FOnChange) then FOnChange(self, FPosition, FMax); 369 | Paint; 370 | end; 371 | end; 372 | 373 | Paint; 374 | end; 375 | 376 | procedure CChart.SetPresets(const Value: CChartPresets); 377 | begin 378 | ApplyPreset(Value); 379 | Paint; 380 | end; 381 | 382 | procedure CChart.ApplyAccentColor; 383 | var 384 | AccColor: TColor; 385 | begin 386 | if FAccent = CAccentColor.None then 387 | Exit; 388 | 389 | AccColor := GetAccentColor(FAccent); 390 | 391 | FColor := AccColor; 392 | FPenColor := ChangeColorSat(AccColor, -40); 393 | end; 394 | 395 | procedure CChart.ApplyPreset(const Value: CChartPresets); 396 | begin 397 | FPreset := Value; 398 | 399 | if FPreset = ccpNone then Exit; 400 | 401 | 402 | case FPreset of 403 | ccpPie: begin 404 | FColor := $00C57517; 405 | FColorBG := clBtnFace; 406 | FPenColor := $008E5611; 407 | FEmptyColor := clSilver; 408 | 409 | FEnableEColor := false; 410 | 411 | FAnimation.FAnimations := true; 412 | FAnimation.FStep := 1; 413 | FAnimation.FInterval := 1; 414 | 415 | FWid := 100; 416 | FPosition := 50; 417 | FAutoAngle := true; 418 | FMax := 100; 419 | FPenWid := 3; 420 | 421 | FSyncBgColor := true; 422 | end; 423 | ccpPieSimple: begin 424 | FColor := $00C57517; 425 | FColorBG := clBtnFace; 426 | FPenColor := $008E5611; 427 | FEmptyColor := clSilver; 428 | 429 | FEnableEColor := false; 430 | 431 | FAnimation.FAnimations := true; 432 | FAnimation.FStep := 1; 433 | FAnimation.FInterval := 1; 434 | 435 | FWid := 100; 436 | FAutoAngle := true; 437 | FMax := 100; 438 | FPenWid := 0; 439 | 440 | FSyncBgColor := true; 441 | end; 442 | ccpBorderPie: begin 443 | FColor := $00C57517; 444 | FColorBG := clBtnFace; 445 | FPenColor := $008E5611; 446 | FEmptyColor := clSilver; 447 | 448 | FEnableEColor := true; 449 | 450 | FAnimation.FAnimations := true; 451 | FAnimation.FStep := 1; 452 | FAnimation.FInterval := 1; 453 | 454 | FWid := 35; 455 | FAutoAngle := true; 456 | FMax := 100; 457 | FPenWid := 0; 458 | 459 | FSyncBgColor := true; 460 | end; 461 | ccpBorderPieModern: begin 462 | FColor := $00C57517; 463 | FColorBG := clBtnFace; 464 | FPenColor := $008E5611; 465 | FEmptyColor := clSilver; 466 | 467 | FEnableEColor := true; 468 | 469 | FAnimation.FAnimations := true; 470 | FAnimation.FStep := 1; 471 | FAnimation.FInterval := 1; 472 | 473 | FWid := 35; 474 | FAutoAngle := true; 475 | FMax := 100; 476 | FPenWid := 3; 477 | 478 | FSyncBgColor := true; 479 | end; 480 | end; 481 | end; 482 | 483 | procedure CChart.SetStartAngle(const Value: integer); 484 | begin 485 | Fstartangle := Value; 486 | Paint; 487 | end; 488 | 489 | procedure CChart.SetWid(const Value: integer); 490 | begin 491 | FWid := Value; 492 | Paint; 493 | end; 494 | 495 | end. 496 | -------------------------------------------------------------------------------- /Dependencies/Cod.Windows.ThemeApi.pas: -------------------------------------------------------------------------------- 1 | {***********************************************************} 2 | { Cod Utils - Dark Mode Api } 3 | { } 4 | { version 1.0 } 5 | { } 6 | { } 7 | { This library is sourced from the following repos } 8 | { https://github.com/HemulGM/WindowDarkMode } 9 | { https://github.com/chuacw/Delphi-Dark-Mode-demo } 10 | { https://github.com/adzm/win32-custom-menubar-aero-theme } 11 | { } 12 | {***********************************************************} 13 | 14 | unit Cod.Windows.ThemeApi; 15 | {$WARN SYMBOL_PLATFORM OFF} 16 | {$ALIGN ON} 17 | {$MINENUMSIZE 4} 18 | 19 | interface 20 | 21 | uses 22 | Winapi.Windows; 23 | 24 | type 25 | TWinRoundType = (wrtDEFAULT = 0, wrtDONOTROUND = 1, wrtROUND = 2, wrtROUNDSMALL = 3); 26 | 27 | TDwmWindowAttribute = ( 28 | DWMWA_NCRENDERING_ENABLED = 1, // 29 | DWMWA_NCRENDERING_POLICY, // 30 | DWMWA_TRANSITIONS_FORCEDISABLED, // 31 | DWMWA_ALLOW_NCPAINT, // 32 | DWMWA_CAPTION_BUTTON_BOUNDS, // 33 | DWMWA_NONCLIENT_RTL_LAYOUT, // 34 | DWMWA_FORCE_ICONIC_REPRESENTATION, // 35 | DWMWA_FLIP3D_POLICY, // 36 | DWMWA_EXTENDED_FRAME_BOUNDS, // 37 | DWMWA_HAS_ICONIC_BITMAP, // 38 | DWMWA_DISALLOW_PEEK, // 39 | DWMWA_EXCLUDED_FROM_PEEK, // 40 | DWMWA_CLOAK, // 41 | DWMWA_CLOAKED, // 42 | DWMWA_FREEZE_REPRESENTATION, // 43 | DWMWA_PASSIVE_UPDATE_MODE, // 44 | DWMWA_USE_HOSTBACKDROPBRUSH, //17 45 | DWMWA_USE_IMMERSIVE_DARK_MODE_BEFORE_20H1 = 19, // 46 | DWMWA_USE_IMMERSIVE_DARK_MODE = 20, // 47 | DWMWA_WINDOW_CORNER_PREFERENCE = 33, // 48 | DWMWA_BORDER_COLOR, // 49 | DWMWA_CAPTION_COLOR, // 50 | DWMWA_TEXT_COLOR, // 51 | DWMWA_VISIBLE_FRAME_BORDER_THICKNESS, // 52 | DWMWA_SYSTEMBACKDROP_TYPE, // 53 | DWMWA_LAST); 54 | 55 | TDWMWindowCornerPreference = (DWMWCP_DEFAULT = 0, DWMWCP_DONOTROUND = 1, DWMWCP_ROUND = 2, DWMWCP_ROUNDSMALL = 3); 56 | TImmersiveHCCacheMode = (IHCM_USE_CACHED_VALUE, IHCM_REFRESH); 57 | TPreferredAppMode = (DefaultMode, AllowDarkMode, ForceDarkMode, ForceLightMode, ModeMax); 58 | 59 | TWindowCompositionAttribute = (WCA_UNDEFINED = 0, // 60 | WCA_NCRENDERING_ENABLED = 1, // 61 | WCA_NCRENDERING_POLICY = 2, // 62 | WCA_TRANSITIONS_FORCEDISABLED = 3, // 63 | WCA_ALLOW_NCPAINT = 4, // 64 | WCA_CAPTION_BUTTON_BOUNDS = 5, // 65 | WCA_NONCLIENT_RTL_LAYOUT = 6, // 66 | WCA_FORCE_ICONIC_REPRESENTATION = 7, // 67 | WCA_EXTENDED_FRAME_BOUNDS = 8, // 68 | WCA_HAS_ICONIC_BITMAP = 9, // 69 | WCA_THEME_ATTRIBUTES = 10, // 70 | WCA_NCRENDERING_EXILED = 11, // 71 | WCA_NCADORNMENTINFO = 12, // 72 | WCA_EXCLUDED_FROM_LIVEPREVIEW = 13, // 73 | WCA_VIDEO_OVERLAY_ACTIVE = 14, // 74 | WCA_FORCE_ACTIVEWINDOW_APPEARANCE = 15, // 75 | WCA_DISALLOW_PEEK = 16, // 76 | WCA_CLOAK = 17, // 77 | WCA_CLOAKED = 18, // 78 | WCA_ACCENT_POLICY = 19, // 79 | WCA_FREEZE_REPRESENTATION = 20, // 80 | WCA_EVER_UNCLOAKED = 21, // 81 | WCA_VISUAL_OWNER = 22, // 82 | WCA_HOLOGRAPHIC = 23, // 83 | WCA_EXCLUDED_FROM_DDA = 24, // 84 | WCA_PASSIVEUPDATEMODE = 25, // 85 | WCA_USEDARKMODECOLORS = 26, // 86 | WCA_LAST = 27); 87 | 88 | WINDOWCOMPOSITIONATTRIBDATA = record 89 | Attrib: TWindowCompositionAttribute; 90 | pvData: Pointer; 91 | cbData: SIZE_T; 92 | end; 93 | 94 | TWindowCompositionAttribData = WINDOWCOMPOSITIONATTRIBDATA; 95 | PWindowCompositionAttribData = ^TWindowCompositionAttribData; 96 | 97 | // DWM 98 | function DwmSetWindowAttribute(hwnd: HWND; dwAttribute: DWORD; pvAttribute: Pointer; cbAttribute: DWORD): HResult; stdcall; overload; 99 | function DwmSetWindowAttribute(hwnd: HWND; dwAttribute: TDwmWindowAttribute; var pvAttribute; cbAttribute: DWORD): HResult; stdcall; overload; 100 | function DwmSetWindowAttribute(hwnd: HWND; dwAttribute: TDwmWindowAttribute; var pvAttribute: TDWMWindowCornerPreference; cbAttribute: DWORD): HResult; stdcall; overload; 101 | 102 | /// 103 | /// Enables dark context menus which change automatically depending on the theme. 104 | /// 105 | procedure AllowDarkModeForApp(allow: BOOL); stdcall; 106 | /// 107 | /// Enables dark mode for window titlebar and border. 108 | /// 109 | function AllowDarkModeForWindow(hWnd: HWND; allow: Boolean): Boolean; stdcall; 110 | 111 | // See https://en.wikipedia.org/wiki/Windows_10_version_history 112 | function CheckBuildNumber(buildNumber: DWORD): Boolean; 113 | function IsWindows10OrGreater(buildNumber: DWORD = 10000): Boolean; 114 | function IsWindows11OrGreater(buildNumber: DWORD = 22000): Boolean; 115 | function IsDarkModeAllowedForWindow(hWnd: HWND): BOOL; stdcall; 116 | procedure RefreshImmersiveColorPolicyState; stdcall; 117 | procedure RefreshTitleBarThemeColor(hWnd: HWND); 118 | function ImmersiveDarkMode: TDwmWindowAttribute; 119 | 120 | // Theme 121 | function ShouldAppsUseDarkMode: BOOL; stdcall; 122 | function ShouldSystemUseDarkMode: BOOL; stdcall; 123 | 124 | const 125 | LOAD_LIBRARY_SEARCH_SYSTEM32 = $00000800; 126 | 127 | implementation 128 | 129 | uses 130 | System.Classes, System.SysUtils, UITypes, System.Win.Registry; 131 | 132 | const 133 | BackColor: TColor = $1E1E1E; 134 | TextColor: TColor = $F0F0F0; 135 | InputBackColor: TColor = $303030; 136 | Dwmapi = 'dwmapi.dll'; 137 | CDarkModeExplorer = 'DarkMode_Explorer'; 138 | CModeExplorer = 'Explorer'; 139 | CDarkModeControlCFD = 'DarkMode_CFD'; 140 | DWM_CLOAKED_APP = $0000001; 141 | DWM_CLOAKED_SHELL = $0000002; 142 | DWM_CLOAKED_INHERITED = $0000004; 143 | ODS_NOACCEL = $0100; 144 | WM_UAHDESTROYWINDOW = $0090; // handled by DefWindowProc 145 | WM_UAHDRAWMENU = $0091; // lParam is UAHMENU 146 | WM_UAHDRAWMENUITEM = $0092; // lParam is UAHDRAWMENUITEM 147 | WM_UAHINITMENU = $0093; // handled by DefWindowProc 148 | WM_UAHMEASUREMENUITEM = $0094; // lParam is UAHMEASUREMENUITEM 149 | WM_UAHNCPAINTMENUPOPUP = $0095; // handled by DefWindowProc 150 | WM_UAHUPDATE = $0096; 151 | 152 | var 153 | _AllowDarkModeForApp: function(allow: BOOL): BOOL; stdcall = nil; 154 | _AllowDarkModeForWindow: function(hWnd: HWND; allow: BOOL): BOOL; stdcall = nil; 155 | _GetIsImmersiveColorUsingHighContrast: function(mode: TImmersiveHCCacheMode): BOOL; stdcall = nil; 156 | _IsDarkModeAllowedForWindow: function(hWnd: HWND): BOOL; stdcall = nil; 157 | _OpenNcThemeData: function(hWnd: HWND; pszClassList: LPCWSTR): THandle; stdcall = nil; 158 | _RefreshImmersiveColorPolicyState: procedure; stdcall = nil; 159 | _SetPreferredAppMode: function(appMode: TPreferredAppMode): TPreferredAppMode; stdcall = nil; 160 | _SetWindowCompositionAttribute: function(hWnd: HWND; pData: PWindowCompositionAttribData): BOOL; stdcall = nil; 161 | _ShouldAppsUseDarkMode: function: BOOL; stdcall; 162 | _ShouldSystemUseDarkMode: function: BOOL; stdcall = nil; 163 | GDarkModeSupported: BOOL = False; // changed type to BOOL 164 | GDarkModeEnabled: BOOL = False; // ? 165 | GUxTheme: HMODULE = 0; 166 | 167 | function DwmSetWindowAttribute(hwnd: hwnd; dwAttribute: DWORD; pvAttribute: Pointer; cbAttribute: DWORD): HResult; stdcall; overload; external Dwmapi name 'DwmSetWindowAttribute' delayed; 168 | 169 | function DwmSetWindowAttribute(hwnd: hwnd; dwAttribute: TDwmWindowAttribute; var pvAttribute: TDWMWindowCornerPreference; cbAttribute: DWORD): HResult; stdcall; overload; external Dwmapi name 'DwmSetWindowAttribute' delayed; 170 | 171 | function GetThemeRegistryKey(Value: string; out ThemeValue: BOOL): boolean; 172 | begin 173 | Result := false; 174 | ThemeValue := true; // default (light theme) 175 | 176 | // Read from registry 177 | with TRegistry.Create do 178 | try 179 | RootKey := HKEY_CURRENT_USER; 180 | if OpenKeyReadOnly('Software\Microsoft\Windows\CurrentVersion\Themes\Personalize\') 181 | and ValueExists(Value) then begin 182 | Result := true; 183 | ThemeValue := ReadInteger(Value) <> 1; 184 | end; 185 | finally 186 | Free; 187 | end; 188 | end; 189 | 190 | procedure AllowDarkModeForApp(allow: BOOL); 191 | begin 192 | if Assigned(_AllowDarkModeForApp) then 193 | _AllowDarkModeForApp(allow) 194 | else if Assigned(_SetPreferredAppMode) then 195 | begin 196 | if allow then 197 | _SetPreferredAppMode(TPreferredAppMode.AllowDarkMode) 198 | else 199 | _SetPreferredAppMode(TPreferredAppMode.DefaultMode); 200 | end; 201 | end; 202 | 203 | function DwmSetWindowAttribute(hwnd: hwnd; dwAttribute: TDwmWindowAttribute; var pvAttribute; cbAttribute: DWORD): HResult; 204 | begin 205 | Result := DwmSetWindowAttribute(hwnd, Ord(dwAttribute), @pvAttribute, cbAttribute); 206 | end; 207 | 208 | function IsDarkModeAllowedForWindow(hWnd: hWnd): BOOL; 209 | begin 210 | Result := Assigned(_IsDarkModeAllowedForWindow) and _IsDarkModeAllowedForWindow(hWnd); 211 | end; 212 | 213 | function GetIsImmersiveColorUsingHighContrast(mode: TImmersiveHCCacheMode): BOOL; 214 | begin 215 | Result := Assigned(_GetIsImmersiveColorUsingHighContrast) and _GetIsImmersiveColorUsingHighContrast(mode); 216 | end; 217 | 218 | function ImmersiveDarkMode: TDwmWindowAttribute; 219 | begin 220 | if IsWindows10OrGreater(18985) then 221 | Result := DWMWA_USE_IMMERSIVE_DARK_MODE 222 | else 223 | Result := DWMWA_USE_IMMERSIVE_DARK_MODE_BEFORE_20H1; 224 | end; 225 | 226 | procedure RefreshImmersiveColorPolicyState; 227 | begin 228 | if Assigned(_RefreshImmersiveColorPolicyState) then 229 | _RefreshImmersiveColorPolicyState; 230 | end; 231 | 232 | function ShouldSystemUseDarkMode: BOOL; 233 | begin 234 | {if Assigned(_ShouldSystemUseDarkMode) then 235 | Result := _ShouldSystemUseDarkMode 236 | else} 237 | GetThemeRegistryKey('SystemUsesLightTheme', Result); 238 | end; 239 | function CheckBuildNumber(buildNumber: DWORD): Boolean; 240 | begin 241 | Result := 242 | IsWindows10OrGreater(20348) or 243 | IsWindows10OrGreater(19045) or // 244 | IsWindows10OrGreater(19044) or // 245 | IsWindows10OrGreater(19043) or // 246 | IsWindows10OrGreater(19042) or // 247 | IsWindows10OrGreater(19041) or // 2004 248 | IsWindows10OrGreater(18363) or // 1909 249 | IsWindows10OrGreater(18362) or // 1903 250 | IsWindows10OrGreater(17763); // 1809 251 | end; 252 | 253 | function IsWindows10OrGreater(buildNumber: DWORD): Boolean; 254 | begin 255 | Result := (TOSVersion.Major > 10) or ((TOSVersion.Major = 10) and (TOSVersion.Minor = 0) and (DWORD(TOSVersion.Build) >= buildNumber)); 256 | end; 257 | 258 | function IsWindows11OrGreater(buildNumber: DWORD): Boolean; 259 | begin 260 | Result := IsWindows10OrGreater(22000) or IsWindows10OrGreater(buildNumber); 261 | end; 262 | 263 | function AllowDarkModeForWindow(hWnd: hWnd; allow: Boolean): Boolean; 264 | begin 265 | Result := GDarkModeSupported and _AllowDarkModeForWindow(hWnd, allow); 266 | end; 267 | 268 | function IsHighContrast: Boolean; 269 | var 270 | highContrast: HIGHCONTRASTW; 271 | begin 272 | highContrast.cbSize := SizeOf(highContrast); 273 | if SystemParametersInfo(SPI_GETHIGHCONTRAST, SizeOf(highContrast), @highContrast, Ord(False)) then 274 | Result := highContrast.dwFlags and HCF_HIGHCONTRASTON <> 0 275 | else 276 | Result := False; 277 | end; 278 | 279 | procedure RefreshTitleBarThemeColor(hWnd: hWnd); 280 | var 281 | LUseDark: BOOL; 282 | LData: TWindowCompositionAttribData; 283 | begin 284 | LUseDark := _IsDarkModeAllowedForWindow(hWnd) and _ShouldAppsUseDarkMode and not IsHighContrast; 285 | if TOSVersion.Build < 18362 then 286 | SetProp(hWnd, 'UseImmersiveDarkModeColors', THandle(LUseDark)) 287 | else if Assigned(_SetWindowCompositionAttribute) then 288 | begin 289 | LData.Attrib := WCA_USEDARKMODECOLORS; 290 | LData.pvData := @LUseDark; 291 | LData.cbData := SizeOf(LUseDark); 292 | _SetWindowCompositionAttribute(hWnd, @LData); 293 | end; 294 | end; 295 | 296 | function ShouldAppsUseDarkMode: BOOL; 297 | begin 298 | {if Assigned(_ShouldAppsUseDarkMode) then 299 | Result := _ShouldAppsUseDarkMode 300 | else} 301 | GetThemeRegistryKey('AppsUseLightTheme', Result); 302 | end; 303 | 304 | initialization 305 | if ((TOSVersion.Major <> 10) or (TOSVersion.Minor <> 0) or not CheckBuildNumber(TOSVersion.Build)) then 306 | Exit; 307 | 308 | GUxTheme := LoadLibrary('uxtheme.dll'); 309 | if GUxTheme <> 0 then 310 | begin 311 | @_AllowDarkModeForWindow := GetProcAddress(GUxTheme, MAKEINTRESOURCEA(133)); 312 | @_GetIsImmersiveColorUsingHighContrast := GetProcAddress(GUxTheme, MAKEINTRESOURCEA(106)); 313 | @_IsDarkModeAllowedForWindow := GetProcAddress(GUxTheme, MAKEINTRESOURCEA(137)); 314 | @_RefreshImmersiveColorPolicyState := GetProcAddress(GUxTheme, MAKEINTRESOURCEA(104)); 315 | @_SetWindowCompositionAttribute := GetProcAddress(GetModuleHandle(user32), 'SetWindowCompositionAttribute'); 316 | @_ShouldAppsUseDarkMode := GetProcAddress(GUxTheme, MAKEINTRESOURCEA(132)); 317 | @_ShouldSystemUseDarkMode := GetProcAddress(GUxTheme, MAKEINTRESOURCEA(138)); 318 | 319 | var P := GetProcAddress(GUxTheme, MAKEINTRESOURCEA(135)); 320 | if TOSVersion.Build < 18362 then 321 | @_AllowDarkModeForApp := P 322 | else 323 | @_SetPreferredAppMode := P; 324 | 325 | if Assigned(_RefreshImmersiveColorPolicyState) and 326 | Assigned(_ShouldAppsUseDarkMode) and Assigned(_AllowDarkModeForWindow) and 327 | (Assigned(_AllowDarkModeForApp) or Assigned(_SetPreferredAppMode)) and 328 | Assigned(_IsDarkModeAllowedForWindow) then 329 | begin 330 | GDarkModeSupported := True; 331 | AllowDarkModeForApp(True); 332 | _RefreshImmersiveColorPolicyState; 333 | GDarkModeEnabled := ShouldAppsUseDarkMode and not IsHighContrast; 334 | end; 335 | end; 336 | 337 | finalization 338 | if GUxTheme <> 0 then 339 | FreeLibrary(GUxTheme); 340 | end. 341 | 342 | -------------------------------------------------------------------------------- /Dependencies/Cod.ColorUtils.pas: -------------------------------------------------------------------------------- 1 | {***********************************************************} 2 | { Codruts Color Utilities } 3 | { } 4 | { version 0.2 } 5 | { ALPHA } 6 | { } 7 | { } 8 | { } 9 | { } 10 | { } 11 | { -- WORK IN PROGRESS -- } 12 | {***********************************************************} 13 | 14 | unit Cod.ColorUtils; 15 | {$SCOPEDENUMS ON} 16 | 17 | interface 18 | uses 19 | Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, 20 | System.Classes, Vcl.Graphics, Vcl.Dialogs, Math, Winapi.GDIPOBJ, 21 | Winapi.GDIPAPI; 22 | 23 | type 24 | CRGBA = record 25 | public 26 | R, G, B, A: byte; 27 | 28 | function Create(Red, Green, Blue: Byte; Alpha: Byte = 255): CRGBA; 29 | 30 | function MakeGDIBrush: TGPSolidBrush; 31 | function MakeGDIColor: TGPColor; 32 | function MakeGDIPen(Width: Single = 1): TGPPen; 33 | 34 | function ToColor(Alpha: Byte = 255): TColor; 35 | procedure FromColor(Color: TColor; Alpha: Byte = 255); 36 | end; 37 | 38 | CRGB = CRGBA; 39 | 40 | // Color Conversion 41 | function GetRGB(Color: TColor; Alpha: Byte = 255): CRGBA; overload; 42 | function GetRGB(R, G, B: Byte; Alpha: Byte = 255): CRGBA; overload; 43 | function GetColor(Color: CRGBA): TColor; 44 | 45 | // HEX 46 | function ColorToHEX(Color: TColor): string; 47 | function HEXToColor(HEX: string): TColor; 48 | 49 | // HBS 50 | function HSBtoColor(hue, sat, bri: Double): TColor; 51 | 52 | // Extra Utilities 53 | function GetHBSCircleColor(Degree: integer): TColor; 54 | 55 | // Fix OutOfRange colors 56 | (* Singe Delphi 11.4, the RangeCheckError flag is enabled on new projects, 57 | this affects color functions that reqire a DWORD and the default system 58 | TColors from the Windows units, are invalid. To fix them, use ColorToRGB *) 59 | 60 | // Color alteration 61 | function ChangeColorSat(BaseColor: TColor; ByValue: integer): TColor; 62 | function ColorToGrayScale(BaseColor: TColor; ToneDown: integer = 3): TColor; 63 | function ColorBlend(Color1, Color2: TColor; A: Byte): TColor; 64 | function RandomLightColor(minimumlightness: byte): TColor; 65 | function RandomDarkColor(maximumlightness: byte): TColor; 66 | function RandomColor(min, max: byte): TColor; 67 | function InvertColor(Color: TColor): TColor; 68 | 69 | // Calculations 70 | function GetColorSat(BaseColor: CRGBA; ColorSize: integer = 255): integer; overload; 71 | function GetColorSat(BaseColor: TColor; ColorSize: integer = 255): integer; overload; 72 | 73 | // Extras 74 | function FontColorForBackground(bgcolor: TColor): TColor; 75 | 76 | type 77 | CColors = record 78 | const 79 | Aliceblue = TColor($FFF8F0); 80 | Antiquewhite = TColor($D7EBFA); 81 | Aqua = TColor($FFFF00); 82 | Aquamarine = TColor($D4FF7F); 83 | Azure = TColor($FFFFF0); 84 | Beige = TColor($DCF5F5); 85 | Bisque = TColor($C4E4FF); 86 | Black = TColor($000000); 87 | Blanchedalmond = TColor($CDEBFF); 88 | Blue = TColor($FF0000); 89 | Blueviolet = TColor($E22B8A); 90 | Brown = TColor($2A2AA5); 91 | Burlywood = TColor($87B8DE); 92 | Cadetblue = TColor($A09E5F); 93 | Chartreuse = TColor($00FF7F); 94 | Chocolate = TColor($1E69D2); 95 | Coral = TColor($507FFF); 96 | Cornflowerblue = TColor($ED9564); 97 | Cornsilk = TColor($DCF8FF); 98 | Crimson = TColor($3C14DC); 99 | Cyan = TColor($FFFF00); 100 | Darkblue = TColor($8B0000); 101 | Darkcyan = TColor($8B8B00); 102 | Darkgoldenrod = TColor($0B86B8); 103 | Darkgray = TColor($A9A9A9); 104 | Darkgreen = TColor($006400); 105 | Darkgrey = TColor($A9A9A9); 106 | Darkkhaki = TColor($6BB7BD); 107 | Darkmagenta = TColor($8B008B); 108 | Darkolivegreen = TColor($2F6B55); 109 | Darkorange = TColor($008CFF); 110 | Darkorchid = TColor($CC3299); 111 | Darkred = TColor($00008B); 112 | Darksalmon = TColor($7A96E9); 113 | Darkseagreen = TColor($8FBC8F); 114 | Darkslateblue = TColor($8B3D48); 115 | Darkslategray = TColor($4F4F2F); 116 | Darkslategrey = TColor($4F4F2F); 117 | Darkturquoise = TColor($D1CE00); 118 | Darkviolet = TColor($D30094); 119 | Deeppink = TColor($9314FF); 120 | Deepskyblue = TColor($FFBF00); 121 | Dimgray = TColor($696969); 122 | Dimgrey = TColor($696969); 123 | Dodgerblue = TColor($FF901E); 124 | Firebrick = TColor($2222B2); 125 | Floralwhite = TColor($F0FAFF); 126 | Forestgreen = TColor($228B22); 127 | Fuchsia = TColor($FF00FF); 128 | Gainsboro = TColor($DCDCDC); 129 | Ghostwhite = TColor($FFF8F8); 130 | Gold = TColor($00D7FF); 131 | Goldenrod = TColor($20A5DA); 132 | Gray = TColor($808080); 133 | Green = TColor($008000); 134 | Greenyellow = TColor($2FFFAD); 135 | Grey = TColor($808080); 136 | Honeydew = TColor($F0FFF0); 137 | Hotpink = TColor($B469FF); 138 | Indianred = TColor($5C5CCD); 139 | Indigo = TColor($82004B); 140 | Ivory = TColor($F0FFFF); 141 | Khaki = TColor($8CE6F0); 142 | Lavender = TColor($FAE6E6); 143 | Lavenderblush = TColor($F5F0FF); 144 | Lawngreen = TColor($00FC7C); 145 | Lemonchiffon = TColor($CDFAFF); 146 | Lightblue = TColor($E6D8AD); 147 | Lightcoral = TColor($8080F0); 148 | Lightcyan = TColor($FFFFE0); 149 | Lightgoldenrodyellow = TColor($D2FAFA); 150 | Lightgray = TColor($D3D3D3); 151 | Lightgreen = TColor($90EE90); 152 | Lightgrey = TColor($D3D3D3); 153 | Lightpink = TColor($C1B6FF); 154 | Lightsalmon = TColor($7AA0FF); 155 | Lightseagreen = TColor($AAB220); 156 | Lightskyblue = TColor($FACE87); 157 | Lightslategray = TColor($998877); 158 | Lightslategrey = TColor($998877); 159 | Lightsteelblue = TColor($DEC4B0); 160 | Lightyellow = TColor($E0FFFF); 161 | LtGray = TColor($C0C0C0); 162 | MedGray = TColor($A4A0A0); 163 | DkGray = TColor($808080); 164 | MoneyGreen = TColor($C0DCC0); 165 | LegacySkyBlue = TColor($F0CAA6); 166 | Cream = TColor($F0FBFF); 167 | Lime = TColor($00FF00); 168 | Limegreen = TColor($32CD32); 169 | Linen = TColor($E6F0FA); 170 | Magenta = TColor($FF00FF); 171 | Maroon = TColor($000080); 172 | Mediumaquamarine = TColor($AACD66); 173 | Mediumblue = TColor($CD0000); 174 | Mediumorchid = TColor($D355BA); 175 | Mediumpurple = TColor($DB7093); 176 | Mediumseagreen = TColor($71B33C); 177 | Mediumslateblue = TColor($EE687B); 178 | Mediumspringgreen = TColor($9AFA00); 179 | Mediumturquoise = TColor($CCD148); 180 | Mediumvioletred = TColor($8515C7); 181 | Midnightblue = TColor($701919); 182 | Mintcream = TColor($FAFFF5); 183 | Mistyrose = TColor($E1E4FF); 184 | Moccasin = TColor($B5E4FF); 185 | Navajowhite = TColor($ADDEFF); 186 | Navy = TColor($800000); 187 | Oldlace = TColor($E6F5FD); 188 | Olive = TColor($008080); 189 | Olivedrab = TColor($238E6B); 190 | Orange = TColor($00A5FF); 191 | Orangered = TColor($0045FF); 192 | Orchid = TColor($D670DA); 193 | Palegoldenrod = TColor($AAE8EE); 194 | Palegreen = TColor($98FB98); 195 | Paleturquoise = TColor($EEEEAF); 196 | Palevioletred = TColor($9370DB); 197 | Papayawhip = TColor($D5EFFF); 198 | Peachpuff = TColor($B9DAFF); 199 | Peru = TColor($3F85CD); 200 | Pink = TColor($CBC0FF); 201 | Plum = TColor($DDA0DD); 202 | Powderblue = TColor($E6E0B0); 203 | Purple = TColor($800080); 204 | Red = TColor($0000FF); 205 | Rosybrown = TColor($8F8FBC); 206 | Royalblue = TColor($E16941); 207 | Saddlebrown = TColor($13458B); 208 | Salmon = TColor($7280FA); 209 | Sandybrown = TColor($60A4F4); 210 | Seagreen = TColor($578B2E); 211 | Seashell = TColor($EEF5FF); 212 | Sienna = TColor($2D52A0); 213 | Silver = TColor($C0C0C0); 214 | Skyblue = TColor($EBCE87); 215 | Slateblue = TColor($CD5A6A); 216 | Slategray = TColor($908070); 217 | Slategrey = TColor($908070); 218 | Snow = TColor($FAFAFF); 219 | Springgreen = TColor($7FFF00); 220 | Steelblue = TColor($B48246); 221 | Tan = TColor($8CB4D2); 222 | Teal = TColor($808000); 223 | Thistle = TColor($D8BFD8); 224 | Tomato = TColor($4763FF); 225 | Turquoise = TColor($D0E040); 226 | Violet = TColor($EE82EE); 227 | Wheat = TColor($B3DEF5); 228 | White = TColor($FFFFFF); 229 | Whitesmoke = TColor($F5F5F5); 230 | Yellow = TColor($00FFFF); 231 | Yellowgreen = TColor($32CD9A); 232 | Null = TColor($00000000); 233 | end; 234 | 235 | implementation 236 | 237 | { ColorTools } 238 | 239 | function GetColorSat(BaseColor: CRGBA; ColorSize: integer): integer; 240 | var 241 | l1, l2, l3: real; 242 | begin 243 | l1 := BaseColor.R / 255 * ColorSize; 244 | l2 := BaseColor.G / 255 * ColorSize; 245 | l3 := BaseColor.B / 255 * ColorSize; 246 | 247 | Result := trunc((l1 + l2 + l3)/3); 248 | end; 249 | 250 | function GetColorSat(BaseColor: TColor; ColorSize: integer): integer; 251 | begin 252 | Result := GetColorSat(GetRGB(BaseColor), ColorSize); 253 | end; 254 | 255 | function ChangeColorSat(BaseColor: TColor; ByValue: integer): TColor; 256 | var 257 | RBGval: longint; 258 | R, G, B: integer; 259 | begin 260 | RBGval := ColorToRGB(BaseColor); 261 | R := GetRValue(RBGval); 262 | G := GetGValue(RBGval); 263 | B := GetBValue(RBGval); 264 | 265 | R := R + ByValue; 266 | G := G + ByValue; 267 | B := B + ByValue; 268 | 269 | if R < 0 then R := 0; 270 | if G < 0 then G := 0; 271 | if B < 0 then B := 0; 272 | 273 | if R > 255 then R := 255; 274 | if G > 255 then G := 255; 275 | if B > 255 then B := 255; 276 | 277 | Result := RGB(r,g,b); 278 | end; 279 | 280 | function ColorBlend(Color1, Color2: TColor; A: Byte): TColor; 281 | var 282 | RGB1, RGB2: CRGB; 283 | R, G, B: Byte; 284 | begin 285 | RGB1.FromColor(Color1); 286 | RGB2.FromColor(Color2); 287 | 288 | R := RGB1.R + (RGB2.R - RGB1.R) * A div 255; 289 | G := RGB1.G + (RGB2.G - RGB1.G) * A div 255; 290 | B := RGB1.B + (RGB2.B - RGB1.B) * A div 255; 291 | 292 | Result := RGB(R, G, B); 293 | end; 294 | 295 | function RandomLightColor(minimumlightness: byte): TColor; 296 | begin 297 | Result := rgb(minimumlightness+round(random*(255 - minimumlightness)), 298 | minimumlightness+round(random*(255 - minimumlightness)), 299 | minimumlightness+round(random*(255 - minimumlightness))) 300 | end; 301 | 302 | function RandomDarkColor(maximumlightness: byte): TColor; 303 | begin 304 | Result := rgb(round(random*(maximumlightness)), 305 | round(random*(maximumlightness)), 306 | round(random*(maximumlightness))) 307 | end; 308 | 309 | function RandomColor(min, max: byte): TColor; 310 | begin 311 | Result := rgb(randomrange(min, max), 312 | randomrange(min, max), 313 | randomrange(min, max)) 314 | end; 315 | 316 | function InvertColor(Color: TColor): TColor; 317 | var 318 | R, G, B: integer; 319 | begin 320 | R := 255 - GetRValue(Color); 321 | G := 255 - GetGValue(Color); 322 | B := 255 - GetBValue(Color); 323 | Result := RGB(R, G, B); 324 | end; 325 | function FontColorForBackground(bgcolor: TColor): TColor; 326 | begin 327 | if GetColorSat(bgcolor, 100) < 65 then 328 | Result := clWhite 329 | else 330 | Result := clBlack; 331 | end; 332 | 333 | function ColorToGrayScale(BaseColor: TColor; ToneDown: integer): TColor; 334 | var 335 | RBGval: longint; 336 | R, G, B: integer; 337 | begin 338 | RBGval := ColorToRGB(BaseColor); 339 | R := GetRValue(RBGval); 340 | G := GetGValue(RBGval); 341 | B := GetBValue(RBGval); 342 | 343 | R:= (R+G+B) div ToneDown; 344 | G:= R; B:=R; 345 | 346 | Result := RGB(r,g,b); 347 | end; 348 | 349 | function ColorToHEX(Color: TColor): string; 350 | begin 351 | Result := '#' + 352 | IntToHex( GetRValue( Color ), 2 ) + 353 | IntToHex( GetGValue( Color ), 2 ) + 354 | IntToHex( GetBValue( Color ), 2 ); 355 | end; 356 | 357 | function GetColor(Color: CRGBA): TColor; 358 | begin 359 | Result := RGB(Color.R, Color.G, Color.B); 360 | end; 361 | 362 | function GetRGB(Color: TColor; Alpha: Byte): CRGBA; 363 | begin 364 | Result.FromColor(Color, Alpha); 365 | end; 366 | 367 | function GetRGB(R, G, B: Byte; Alpha: Byte): CRGBA; 368 | begin 369 | Result.Create(R, G, B, Alpha); 370 | end; 371 | 372 | function HEXToColor(HEX: string): TColor; 373 | begin 374 | HEX := HEX.Replace('#', ''); 375 | try 376 | Result := 377 | RGB( 378 | StrToInt( '$'+Copy( HEX, 1, 2 ) ), 379 | StrToInt( '$'+Copy( HEX, 3, 2 ) ), 380 | StrToInt( '$'+Copy( HEX, 5, 2 ) ) 381 | ); 382 | except 383 | Result := 0; 384 | end; 385 | end; 386 | 387 | 388 | function HSBtoColor(hue, sat, bri: Double): TColor; 389 | var 390 | f, h: Double; 391 | u, p, q, t: Byte; 392 | begin 393 | u := Trunc(bri * 255 + 0.5); 394 | if sat = 0 then 395 | Exit(rgb(u, u, u)); 396 | 397 | h := (hue - Floor(hue)) * 6; 398 | f := h - Floor(h); 399 | p := Trunc(bri * (1 - sat) * 255 + 0.5); 400 | q := Trunc(bri * (1 - sat * f) * 255 + 0.5); 401 | t := Trunc(bri * (1 - sat * (1 - f)) * 255 + 0.5); 402 | 403 | case Trunc(h) of 404 | 0: 405 | result := rgb(u, t, p); 406 | 1: 407 | result := rgb(q, u, p); 408 | 2: 409 | result := rgb(p, u, t); 410 | 3: 411 | result := rgb(p, q, u); 412 | 4: 413 | result := rgb(t, p, u); 414 | 5: 415 | result := rgb(u, p, q); 416 | else 417 | result := clwhite; 418 | end; 419 | end; 420 | 421 | function GetHBSCircleColor(Degree: integer): TColor; 422 | begin 423 | Result := HSBtoColor( Degree / 360 * 1, 1, 1 ); 424 | end; 425 | 426 | { CRGB } 427 | 428 | function CRGBA.Create(Red, Green, Blue, Alpha: Byte): CRGBA; 429 | begin 430 | R := Red; 431 | G := Green; 432 | B := Blue; 433 | 434 | A := Alpha; 435 | 436 | Result := Self; 437 | end; 438 | 439 | procedure CRGBA.FromColor(Color: TColor; Alpha: Byte); 440 | var 441 | RBGval: longint; 442 | begin 443 | RBGval := ColorToRGB(Color); 444 | 445 | try 446 | R := GetRValue(RBGval); 447 | G := GetGValue(RBGval); 448 | B := GetBValue(RBGval); 449 | 450 | A := Alpha; 451 | finally 452 | 453 | end; 454 | end; 455 | 456 | function CRGBA.MakeGDIBrush: TGPSolidBrush; 457 | begin 458 | Result := TGPSolidBrush.Create( MakeGDIColor ); 459 | end; 460 | 461 | function CRGBA.MakeGDIColor: TGPColor; 462 | begin 463 | Result := MakeColor(A, R, G, B); 464 | end; 465 | 466 | function CRGBA.MakeGDIPen(Width: Single): TGPPen; 467 | begin 468 | Result := TGPPen.Create( MakeGDIColor, Width ); 469 | end; 470 | 471 | function CRGBA.ToColor(Alpha: Byte): TColor; 472 | begin 473 | Result := RGB(R, G, B); 474 | 475 | A := Alpha; 476 | end; 477 | 478 | end. --------------------------------------------------------------------------------